diff --git a/compiler.ss b/compiler.ss index 49a8582..a1c24d1 100755 --- a/compiler.ss +++ b/compiler.ss @@ -39,7 +39,8 @@ [(call/cc) '%call/cc] ) (cdr form))] - [(%bind %if %set! %lambda quote + [(quote) (if (eq? (second form) '()) '%nil form)] + [(%bind %if %set! %lambda %tail-call %apply %call/cc %cons %set-car! %car %set-cdr! %cdr %make-box %set-box! %unbox) @@ -47,56 +48,99 @@ [else (simplify-funcall form)]) (if (eq? form '()) '%nil form))) -(define (form-sets? form var [call-may-set? #t]) - (define (recurse simple-form) - (if (pair? simple-form) - (case (car simple-form) - [(%bind) (and (not (memq var (second simple-form))) - (ormap recurse (cddr simple-form)))] - [(%set!) (eq? (second simple-form) var)] - [(%tail-call %apply %call/cc) call-may-set?] - [(quote %lambda %if - %make-box %set-box! %unbox - %cons %set-car! %car %set-cdr! %cdr) - #f] - [else (error "Invalid simple form:" simple-form)]) - #f)) - (recurse (simplify-form form))) +(define (simple-value? form) + (or (not (pair? form)) + (eq? (first form) 'quote) + (eq? (first form) '%template))) -(define (form-uses? form var [call-may-use? #t] [descend? #t]) - (define (recurse simple-form) - (if (pair? simple-form) - (case (car simple-form) - [(%bind) (and (not (memq var (second simple-form))) - (ormap recurse (cddr simple-form)))] - [(%set!) (recurse (third simple-form))] - [(%tail-call %apply %call/cc) (and call-may-use? #t)] - [(%if %make-box %set-box! %unbox - %cons %set-car! %car %set-cdr! %cdr) - (ormap recurse (cdr simple-form))] - [(%lambda) (and descend? - (memq var (free-variables simple-form)) - #t)] - [(quote) #f] - [else (error "Invalid simple form:" simple-form)]) - (eq? simple-form var))) - (recurse (simplify-form form))) +(define (map-form form + #:bind [bind-fn (lambda (recurse op vars . subforms) + `(,op ,vars ,@(map recurse subforms)))] + #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) + `(,op ,g-vars ,i-vars ,(recurse bind)))] + #:set [set-fn (lambda (recurse op var value) + `(,op ,var ,(recurse value)))] -(define (form-captures? form var [input? #t] [output? #t]) - (define (recurse simple-form) - (if (pair? simple-form) - (case (car simple-form) - [(%bind) (and (not (memq var (second simple-form))) - (ormap recurse (cddr simple-form)))] - [(%set!) (recurse (third simple-form))] - [(%tail-call %apply %call/cc %if quote - %make-box %set-box! %unbox - %cons %set-car! %car %set-cdr! %cdr) - #f] - [(%lambda) (and (memq var (free-variables simple-form input? output?)) #t)] - [else (error "Invalid simple form:" simple-form)]) - #f)) - (recurse (simplify-form form))) + #:primitive [primitive-fn (lambda (recurse op . simple-values) + `(,op ,@(map recurse simple-values)))] + #:call [call-fn primitive-fn] + #:apply [apply-fn call-fn] + #:call/cc [call/cc-fn call-fn] + #:tail-call [tail-call-fn call-fn] + + #:simple [simple-fn (lambda (recurse kind form) form)] + #:variable [variable-fn simple-fn] + #:literal [literal-fn simple-fn] + + #:other [other-fn (lambda (recurse . form) + (error "Unsimplified form:" form))]) + (define (recurse subform) + (map-form subform + #:bind bind-fn + #:lambda lambda-fn + #:set set-fn + #:primitive primitive-fn + #:call call-fn + #:apply apply-fn + #:call/cc call/cc-fn + #:tail-call tail-call-fn + #:simple simple-fn + #:variable variable-fn + #:literal literal-fn + #:other other-fn)) + + (if (simple-value? form) + (if (and (symbol? form) (not (memq form '(%nil %undef)))) + (variable-fn recurse 'variable form) + (literal-fn recurse 'literal form)) + (apply (case (first form) + [(%bind) bind-fn] + [(%lambda) lambda-fn] + [(%set!) set-fn] + [(%apply) apply-fn] + [(%call/cc) call/cc-fn] + [(%tail-call) tail-call-fn] + + [(%if %cons %set-car! %car %set-cdr! %cdr %make-box %set-box! %unbox %make-lambda) + primitive-fn] + + [else other-fn]) + recurse form))) + +(define (form-sets? form variable [call-may-set? #t]) + (map-form (simplify-form form) + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:lambda (lambda _ #f) + #:set (lambda (recurse op var complex-value) (eq? var variable)) + #:primitive (lambda _ #f) + #:call (lambda _ call-may-set?) + #:simple (lambda _ #f))) + +(define (form-uses? form variable [call-may-use? #t] [descend? #t]) + (map-form (simplify-form form) + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:lambda (lambda (recurse op g-vars i-vars bind) (and descend? (recurse bind))) + #:set (lambda (recurse op var complex-value) (recurse complex-value)) + #:primitive (lambda (recurse op . simple-values) (ormap recurse simple-values)) + #:call (lambda (recurse op . simple-values) + (or call-may-use? (ormap recurse simple-values))) + #:simple (lambda _ #f) + #:variable (lambda (recurse op var) (eq? var variable)))) + +(define (form-captures? form variable [input? #t] [output? #t]) + (map-form (simplify-form form) + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:lambda (lambda (recurse op g-vars i-vars bind) + (and (memq variable (free-variables bind input? output?)) #t)) + #:set (lambda (recurse op var complex-value) (recurse complex-value)) + #:primitive (lambda _ #f) + #:simple (lambda _ #f))) (define (form-captures-input? form var) (form-captures? form var #t #f)) @@ -126,15 +170,15 @@ (define (simplify-primitive new-id value-forms) (define bindings (map (lambda (vf) - (if (pair? vf) - (list (gensym) vf) - (list vf vf))) + (let ([simple-vf (simplify-form vf)]) + (if (simple-value? simple-vf) + (list simple-vf #f) + (let ([tmp (gensym)]) + (list tmp (simplify-set! `(set! ,tmp ,simple-vf))))))) value-forms)) - (define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x)))) - bindings)) (simplify-form - `(let ,(map first temp-bindings) - ,@(map (lambda (x) `(set! ,(first x) ,(second x))) temp-bindings) + `(let ,(map first (filter second bindings)) + ,@(filter-map second bindings) (,new-id ,@(map first bindings))))) ; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel @@ -153,12 +197,11 @@ `(%bind () ,@(map simplify-form bodyexprs))] [(not (pair? (cdr bindings))) (let ([binding (first bindings)]) - (make-bindings-unique - `(%bind (,(if (pair? binding) (first binding) binding)) - ,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding) - ,(second binding)))) - '()) - ,@(map simplify-form bodyexprs))))] + `(%bind (,(if (pair? binding) (first binding) binding)) + ,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding) + ,(second binding)))) + '()) + ,@(map simplify-form bodyexprs)))] [else (let ([vars (map (lambda (x) (if (pair? x) (first x) x)) bindings)] [temp-bindings (append-map (lambda (x) @@ -171,10 +214,9 @@ bindings)]) `(%bind ,(map first temp-bindings) ,@(map second temp-bindings) - ,(make-bindings-unique - `(%bind ,vars - ,@(map third temp-bindings) - ,@(map simplify-form bodyexprs)))))]))) + (%bind ,vars + ,@(map third temp-bindings) + ,@(map simplify-form bodyexprs))))]))) ; (let* ...) ; eval exprs & bind variables serially ; => (let ([var-0 expr-0]) @@ -329,7 +371,7 @@ ,inner)) (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs) `(begin ,@bodyexprs))) - `(%lambda + `(%lambda () () ,((compose transform-to-cps (lambda (x) (add-tail-call k rval x)) flatten-binds) @@ -344,7 +386,7 @@ requireds)))))))) (define (narrow-binds simple-lambda-form) - (define bind (second simple-lambda-form)) + (define bind (fourth simple-lambda-form)) (define (at-top-level? var) (or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind)) (ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind)))) @@ -362,7 +404,7 @@ (filter-not captured-twice? (filter-not at-top-level? (second bind)))) - `(%lambda + `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form) (%bind ,(remove* extra-binds (second bind)) ,@(map (lambda (subform) (foldl (lambda (var subform) @@ -372,9 +414,11 @@ (eq? (first (third subform)) '%lambda)) (let* ([dest (second subform)] [value (third subform)] - [bind (second value)]) + [g-vars (second value)] + [i-vars (third value)] + [bind (fourth value)]) `(%set! ,dest ,(narrow-binds - `(%lambda + `(%lambda ,g-vars ,i-vars ,(if (form-captures? value var) `(%bind (,@(second bind) ,var) ,@(cddr bind)) @@ -384,51 +428,41 @@ extra-binds)) (cddr bind))))) -(define (promote-to-box var form) - (define (recurse subform) (promote-to-box var subform)) - (if (pair? form) - (case (car form) - [(%bind) - (flatten-binds - `(%bind ,(second form) - ,@(if (memq var (second form)) - `((%set! ,var (%make-box %undef))) - '()) - ,@(map recurse (cddr form))))] - [(%lambda) - `(%lambda ,(recurse (second form)))] - [(%set!) - (let ([value (recurse (third form))] - [kind (if (eq? (second form) var) '%set-box! '%set!)]) - ; If value is (%bind), could only come from clause below. - (if (and (pair? value) (eq? (first value) '%bind)) - (if (and (pair? (fourth value)) (not (eq? kind '%set!))) - (let ([tmp (gensym)]) - `(%bind (,@(second value) ,tmp) - ,(third value) - (%set! ,tmp ,(fourth value)) - (,kind ,(second form) ,tmp))) - `(%bind ,(second value) - ,(third value) - (,kind ,(second form) ,(fourth value)))) - (if (and (pair? value) (not (eq? kind '%set!))) - (let ([tmp (gensym)]) - `(%bind (,tmp) - (%set! ,tmp ,value) - (,kind ,(second form) ,tmp))) - `(,kind ,(second form) ,value))))] - [(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox) - (if (memq var (cdr form)) - (let ([tmp (gensym)]) - `(%bind (,tmp) - (%set! ,tmp (%unbox ,var)) - (,(first form) ,@(subst var tmp (cdr form))))) - form)] - [(quote) form] - [else (error "Unsimplified form:" form)]) - (if (eq? form var) - `(%unbox ,form) - form))) +(define (promote-to-box variable form) + (map-form form + #:bind (lambda (recurse op vars . subforms) + (flatten-binds + `(%bind ,(subst variable variable vars) + ,@(if (memq variable vars) + `((%set! ,variable (%make-box %undef))) + '()) + ,@(map recurse subforms)))) + #:set (lambda (recurse op var value) + (let ([new-value (recurse value)]) + (if (eq? var variable) + (if (simple-value? new-value) + `(%set-box! ,variable ,new-value) + (let ([tmp (gensym)]) + `(%bind (,tmp) + ,(simplify-set! `(set! ,tmp ,new-value)) + (%set-box! ,variable ,tmp)))) + (simplify-set! `(set! ,var ,new-value))))) + #:primitive (lambda (recurse op . simple-values) + (let ([new-args (map recurse simple-values)]) + ;; if any new-arg is not simple, must bind to a temp first + (let ([temps (map (lambda (x) + (if (simple-value? x) + (list x #f) + (let ([tmp (gensym)]) + (list tmp `(%set! ,tmp ,x))))) + new-args)]) + (if (ormap second temps) + `(%bind ,(map first (filter second temps)) + ,@(filter-map second temps) + (,op ,@(map first temps))) + `(,op ,@new-args))))) + #:variable (lambda (recurse op var) + (if (eq? var variable) `(%unbox ,variable) var)))) ; form needs to be flattened (%bind ...) (define (is-shared-var? var form) @@ -450,8 +484,8 @@ (set-after-first-use?))) (define (promote-shared-vars simple-lambda-form) - (define bind (second simple-lambda-form)) - `(%lambda + (define bind (fourth simple-lambda-form)) + `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form) ,(foldl (lambda (var frm) (if (is-shared-var? var frm) (promote-to-box var frm) @@ -459,24 +493,29 @@ bind (second bind)))) +(define (promote-free-vars simple-lambda-form) + (define bind (fourth simple-lambda-form)) + `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form) + ,(foldl promote-to-box bind (free-variables bind)))) + ; <= (%bind (var...) ; @before ; (%apply x y) ; @after)) ; => (%bind (var... k) ; @before -; (%set k (lambda _ @after)) +; (%set! k (lambda _ @after)) ; (%tail-call x y k))) ; <= (%bind (var...) ; @before -; (%set v (%apply x y)) +; (%set! v (%apply x y)) ; @after)) ; => (%bind (var... k) ; @before -; (%set k (lambda (x) -; (%set! v x) -; @after)) +; (%set! k (lambda (x) +; (%set! v x) +; @after)) ; (%tail-call x y k))) ; <= (%bind (var...) @@ -489,70 +528,69 @@ ; (%set! k-argv (%cons k %nil)) ; (%tail-call l k-argv k)) -(define (transform-to-cps form) +(define (transform-to-cps bind) + (define (cps-prepend subform after) + (cond + ; (%set! v (%apply x y)) + [(and (pair? subform) + (eq? (first subform) '%set!) + (pair? (third subform)) + (eq? (first (third subform)) '%apply)) + (let ([k (gensym)] + [x (gensym)]) + `((%bind (,k ,x) + (%set! ,k ,(simplify-form + `(lambda (,x . ,(gensym)) + (%set! ,(second subform) ,x) + ,@after))) + (%tail-call ,(second (third subform)) + ,(third (third subform)) + ,k))))] + ; (%apply x y) + [(and (pair? subform) + (eq? (first subform) '%apply)) + (let ([k (gensym)]) + `((%bind (,k) + (%set! ,k ,(simplify-form + `(lambda ,(gensym) + ,@after))) + (%tail-call ,(second subform) + ,(third subform) + ,k))))] + ; (%set! v (%call/cc x)) + [(and (pair? subform) + (eq? (first subform) '%set!) + (pair? (third subform)) + (eq? (first (third subform)) '%call/cc)) + (let ([k (gensym)] + [k-argv (gensym)] + [x (gensym)]) + `((%bind (,k ,k-argv) + (%set! ,k ,(simplify-form + `(lambda (,x . ,(gensym)) + (%set! ,(second subform) ,x) + ,@after))) + (%set! ,k-argv (%cons ,k %nil)) + (%tail-call ,(second (third subform)) + ,k-argv + ,k))))] + ; (%call/cc x) + [(and (pair? subform) + (eq? (first subform) '%call/cc)) + (let ([k (gensym)] + [k-argv (gensym)]) + `((%bind (,k ,k-argv) + (%set! ,k ,(simplify-form + `(lambda ,(gensym) + ,@after))) + (%set! ,k-argv (%cons ,k %nil)) + (%tail-call ,(second subform) + ,k-argv + ,k))))] + [else (cons subform after)])) (flatten-binds - `(%bind ,(second form) - ,@(foldr (lambda (subform after) - (cond - ; (%set! v (%apply x y)) - [(and (pair? subform) - (eq? (first subform) '%set!) - (pair? (third subform)) - (eq? (first (third subform)) '%apply)) - (let ([k (gensym)] - [x (gensym)]) - `((%bind (,k ,x) - (%set! ,k ,(simplify-form - `(lambda (,x . ,(gensym)) - (%set! ,(second subform) ,x) - ,@after))) - (%tail-call ,(second (third subform)) - ,(third (third subform)) - ,k))))] - ; (%apply x y) - [(and (pair? subform) - (eq? (first subform) '%apply)) - (let ([k (gensym)]) - `((%bind (,k) - (%set! ,k ,(simplify-form - `(lambda ,(gensym) - ,@after))) - (%tail-call ,(second subform) - ,(third subform) - ,k))))] - ; (%set! v (%call/cc x)) - [(and (pair? subform) - (eq? (first subform) '%set!) - (pair? (third subform)) - (eq? (first (third subform)) '%call/cc)) - (let ([k (gensym)] - [k-argv (gensym)] - [x (gensym)]) - `((%bind (,k ,k-argv) - (%set! ,k ,(simplify-form - `(lambda (,x . ,(gensym)) - (%set! ,(second subform) ,x) - ,@after))) - (%set! ,k-argv (%cons ,k %nil)) - (%tail-call ,(second (third subform)) - ,k-argv - ,k))))] - ; (%call/cc x) - [(and (pair? subform) - (eq? (first subform) '%call/cc)) - (let ([k (gensym)] - [k-argv (gensym)]) - `((%bind (,k ,k-argv) - (%set! ,k ,(simplify-form - `(lambda ,(gensym) - ,@after))) - (%set! ,k-argv (%cons ,k %nil)) - (%tail-call ,(second subform) - ,k-argv - ,k))))] - [else (cons subform after)])) - '() - (cddr form))))) + `(%bind ,(second bind) + ,@(foldr cps-prepend '() (cddr bind))))) ; (fn-expr arg-expr...) ; => (let ([fn-var fn-expr] arg-var... argv) @@ -577,77 +615,53 @@ (%apply ,fn-var ,argv)))) (define (subst-var old-var new-var form) - (define (recurse form) - (subst-var old-var new-var form)) - (if (pair? form) - (case (car form) - [(%bind) - (if (memq old-var (second form)) - form - `(%bind ,(second form) ,@(map recurse (cddr form))))] - [(quote) form] - [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox) - `(,(first form) ,@(map recurse (cdr form)))] - [else (error "Unsimplified form:" form)]) - (if (eq? form old-var) - new-var - form))) - -(define (make-bindings-unique form) - (if (pair? form) - (case (car form) - [(%bind) - (let ([new-vars (map (lambda _ (gensym)) (second form))]) - `(%bind ,new-vars - ,@(map (lambda (frm) - (foldl (lambda (pair s) - (subst-var (car pair) - (cdr pair) - s)) - frm - (map cons (second form) new-vars))) - (cddr form))))] - [(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form] - [else (error "Unsimplified form:" form)]) - form)) + (map-form form + #:bind (lambda (recurse op vars . subforms) + `(%bind ,(subst old-var new-var vars) ,@(map recurse subforms))) + #:set (lambda (recurse op var value) + `(,op ,(if (eq? var old-var) new-var var) ,(recurse value))) + #:variable (lambda (recurse op var) + (if (eq? var old-var) new-var var)))) (define (flatten-binds form) - (if (pair? form) - (case (car form) - [(%bind) - (let* ([bound-vars (second form)] - [subforms (append-map (lambda (new-form) - (if (and (pair? new-form) (eq? (car new-form) '%bind)) - (begin - (set! bound-vars (append bound-vars (second new-form))) - (cddr new-form)) - (list new-form))) - (map flatten-binds (cddr form)))]) - `(%bind ,bound-vars ,@subforms))] - [(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form] - [else (error "Unsimplified form:" form)]) - form)) + (define (make-bindings-unique bind) + (foldr (lambda (var bind) + (subst-var var (gensym) bind)) + bind + (second bind))) + + (if (and (pair? form) (eq? (car form) '%bind)) + (let* ([bound-vars (second form)] + [subforms (append-map (lambda (subform) + (if (and (pair? subform) (eq? (car subform) '%bind)) + (let ([unique-form (make-bindings-unique + (flatten-binds subform))]) + (set! bound-vars (append (second unique-form) bound-vars)) + (cddr unique-form)) + (list subform))) + (cddr form))]) + `(%bind ,bound-vars ,@subforms)) + form)) (define (free-variables form [input? #t] [output? #t]) - (define (recurse form) (free-variables form input? output?)) - (if (pair? form) - (case (car form) - [(%bind) - (remove* (second form) - (remove-duplicates (append-map recurse (cddr form))))] - [(%set!) (if output? - (cons (second form) (recurse (third form))) - (recurse (third form)))] - [(quote) '()] - [(%if %tail-call %apply %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox) - (remove-duplicates (append-map recurse (cdr form)))] - [else - (error "Unsimplified form:" form)]) - (if (and input? - (symbol? form) - (not (memq form '(%nil %undef %self %argv %ctx %k)))) - (list form) - '()))) + (map-form form + #:bind (lambda (recurse op vars . subforms) + (remove-duplicates (remove* vars (append-map recurse subforms)))) + #:lambda (lambda (recurse op g-vars i-vars bind) + (recurse bind)) + #:set (lambda (recurse op var value) + (let ([value-free (recurse value)]) + (if output? + (cons var value-free) + value-free))) + #:primitive (lambda (recurse op . simple-values) + (remove-duplicates (append-map recurse simple-values))) + #:simple (lambda (recurse kind form) + (if (and input? + (symbol? form) + (not (memq form '(%nil %undef %self %argv %ctx %k)))) + (list form) + '())))) (define (free-input-variables form) (free-variables form #t #f)) @@ -657,51 +671,99 @@ ; Don't bind variables which aren't referenced. (define (reduce-variables form) - (if (pair? form) - (case (car form) - [(%bind) - (let ([ref-vars (remove-duplicates (append-map free-variables (cddr form)))]) - `(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form)) - ,@(map reduce-variables (cddr form))))] - [(quote) form] - [(%if %tail-call %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox) - `(,(first form) ,@(map reduce-variables (cdr form)))] - [else (error "Unsimplified form:" form)]) - form)) + (map-form form + #:bind (lambda (recurse op vars . subforms) + (let ([ref-vars (remove-duplicates (append-map free-variables subforms))]) + `(%bind ,(filter (lambda (x) (memq x ref-vars)) vars) + ,@(map recurse subforms)))))) ; Don't set variables which won't be accessed later. (define (reduce-set! form) - (if (pair? form) - (case (car form) - [(%bind) - (let ([bound-vars (second form)]) - `(%bind ,bound-vars - ,@(foldr (lambda (subform after) + (map-form form + #:bind (lambda (recurse op vars . subforms) + (define (prepend-if-used subform after) (if (and (pair? subform) (eq? (first subform) '%set!) - (memq (second subform) bound-vars) + (memq (second subform) vars) (not (memq (second subform) (append-map free-input-variables after)))) after (cons subform after))) - '() - (map reduce-set! (cddr form)))))] - [(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form] - [(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))] - [else (error "Unsimplified form:" form)]) - form)) + `(%bind ,vars + ,@(foldr prepend-if-used '() (map recurse subforms)))))) (define (simplify-toplevel-lambda form) - (promote-shared-vars - (narrow-binds - (simplify-lambda form)))) + (promote-free-vars + (promote-shared-vars + (narrow-binds + (simplify-lambda form))))) (define (optimize-simplified-lambda form) (reduce-variables (reduce-set! form))) -(pretty-print (optimize-simplified-lambda (simplify-toplevel-lambda `(lambda () ,(read))))) -;(pretty-print (simplify-toplevel-lambda `(lambda () ,(read)))) +(define frame-vars + (for/list ([i (in-range 0 120)]) + (string->uninterned-symbol (string-append "%f" (number->string i))))) + +(define instance-vars + (for/list ([i (in-range 0 64)]) + (string->uninterned-symbol (string-append "%i" (number->string i))))) + +(define global-vars + (for/list ([i (in-range 1 64)]) + (string->uninterned-symbol (string-append "%g" (number->string i))))) + +(define (frame-var? var) (and (memq var frame-vars) #t)) +(define (instance-var? var) (and (memq var instance-vars) #t)) +(define (frame/instance-var? var) (or (frame-var? var) (instance-var? var))) + +(define (global-var? var) (and (memq var global-vars) #t)) + +(define (special-var? var) + (or (and (memq var '(%nil %self %argv %ctx %k)) #t) + (frame/instance-var? var) + (global-var? var))) + +(define (map-variables lambda/template-form) + (let ([bind (fourth lambda/template-form)] + [g-vars '()] + [unused-g-vars global-vars] + [i-vars '()]) + (define (add-g-var value) + (let/cc return + (for ([g-var (in-list global-vars)] + [val (in-list g-vars)]) + (when (eq? value val) (return g-var))) + (let ([g-var (first unused-g-vars)]) + (set! unused-g-vars (cdr unused-g-vars)) + (set! g-vars (append g-vars (list value))) + g-var))) + + (for ([free-var (in-list (filter frame/instance-var? (free-variables bind)))] + [inst-var (in-list instance-vars)]) + (set! i-vars (append i-vars (list free-var))) + (set! bind (subst-var free-var inst-var bind))) + (for ([bound-var (in-list (second bind))] + [frame-var (in-list frame-vars)]) + (set! bind (subst-var bound-var frame-var bind))) + (set! bind (map-form bind + #:lambda (lambda (recurse op inner-g-vars i-vars bind) + `(%make-lambda ,((compose add-g-var map-variables) + `(%template ,inner-g-vars ,i-vars ,bind)))) + #:variable (lambda (recurse kind form) + (if (special-var? form) form (add-g-var form))) + #:literal (lambda (recurse kind form) + (if (eq? form '%nil) form (add-g-var form))))) + `(,(if (pair? i-vars) '%template '%lambda) ,g-vars ,i-vars + ,bind))) + +((compose + pretty-print + map-variables + optimize-simplified-lambda + simplify-toplevel-lambda) + `(lambda () ,(read))) ; vim:set sw=2 expandtab: