diff --git a/compiler.ss b/compiler.ss index 847b6af..fd921c9 100755 --- a/compiler.ss +++ b/compiler.ss @@ -327,23 +327,30 @@ (form-captures? form var #f #t)) (define (simplify-set! form) - (let ([value-form (simplify-form (third form))]) + (let ([variable (second form)] + [value-form (simplify-form (third form))]) (if (and (pair? value-form) (eq? (first value-form) '%bind)) - (simplify-form - `(let ,(second value-form) - ,@(foldr (lambda (subform after) - (cond - [(pair? after) (cons subform after)] - [(and (pair? subform) (eq? (first subform) '%values)) - ; Requires at least one value; ignores extras. - (if (null? (cdr subform)) - (error "Attempted to set variable to void in:" form) - `((set! ,(second form) ,(second subform))))] - [(value-form? subform) `((set! ,(second form) ,subform))] - [else (error "Attempted to set variable to void in:" form)])) - '() - (cddr value-form)))) - `(%set! ,(second form) ,value-form)))) + (if (memq variable (second value-form)) + (let ([tmp (gensym)]) + `(%bind (,tmp) + ; guaranteed not to cause unbounded recursion: tmp is unique + ,(simplify-set! `(set! ,tmp ,value-form)) + (%set! ,variable ,tmp))) + `(%bind ,(second value-form) + ,@(foldr (lambda (subform after) + (cond + [(pair? after) (cons subform after)] + [(and (pair? subform) (eq? (first subform) '%values)) + ; Requires at least one value; ignores extras. + (if (null? (cdr subform)) + (error "Attempted to set variable to void in:" form) + `((%set! ,variable ,(second subform))))] + [(value-form? subform) + (list (simplify-set! `(set! ,variable ,subform)))] + [else (error "Attempted to set variable to void in:" form)])) + '() + (cddr value-form)))) + `(%set! ,variable ,value-form)))) (define (simplify-primitive simple-op value-forms) (define (value->binding value-form) @@ -379,28 +386,27 @@ (define vars (map first bindings)) (define (bound-var? var) (and (memq var vars) #t)) - (flatten-binds - ; If the value of any binding refers to one of the variable names being bound... - (if (ormap (lambda (value) (ormap bound-var? (free-variables value))) - (map second (filter has-value? bindings))) - ; ...then bind the values to temps first, before binding the real names. - (let ([temp-bindings (map (lambda (binding) - (let ([tmp (gensym)]) - (list tmp - (simplify-form `(set! ,tmp ,(second binding))) - `(%set! ,(first binding) ,tmp)))) - (filter has-value? bindings))]) - `(%bind ,(map first temp-bindings) - ,@(map second temp-bindings) - (%bind ,vars - ,@(map third temp-bindings) - ,@(map simplify-form bodyexprs)))) - ; Otherwise, just bind the real names directly. - `(%bind ,vars - ,@(map (lambda (binding) - (simplify-set! `(set! ,@binding))) - (filter has-value? bindings)) - ,@(map simplify-form bodyexprs))))) + ; If the value of any binding refers to one of the variable names being bound... + (if (ormap (lambda (value) (ormap bound-var? (free-variables value))) + (map second (filter has-value? bindings))) + ; ...then bind the values to temps first, before binding the real names. + (let ([temp-bindings (map (lambda (binding) + (let ([tmp (gensym)]) + (list tmp + (simplify-form `(set! ,tmp ,(second binding))) + `(%set! ,(first binding) ,tmp)))) + (filter has-value? bindings))]) + `(%bind ,(map first temp-bindings) + ,@(map second temp-bindings) + (%bind ,vars + ,@(map third temp-bindings) + ,@(map simplify-form bodyexprs)))) + ; Otherwise, just bind the real names directly. + `(%bind ,vars + ,@(map (lambda (binding) + (simplify-set! `(set! ,@binding))) + (filter has-value? bindings)) + ,@(map simplify-form bodyexprs)))) ; (let* ...) ; eval exprs & bind variables serially ; => (let ([var-0 expr-0]) @@ -489,9 +495,10 @@ [else (let-values ([(req opt rst) (split-arglist (cdr arglist))]) (values (cons (car arglist) req) opt rst))])) -(define (add-return ctx k form) +(define (add-return ctx k nested-bind) + (define flat-bind (flatten-binds nested-bind)) (define argv (gensym)) - `(%bind (,@(second form) ,argv) + `(%bind (,@(second flat-bind) ,argv) ,@(foldr (lambda (subform after) (cond [(pair? after) @@ -519,44 +526,42 @@ `(,subform (%tail-call ,k %nil #f #f))])) '() - (cddr form)))) + (cddr flat-bind)))) (define (simplify-lambda form) (define arglist (car (cdr form))) (define bodyexprs (cdr (cdr form))) (define-values (requireds optionals rest) (split-arglist arglist)) - (define argv-temp (gensym)) + (define argv (gensym)) (define ctx (gensym)) (define k (gensym)) - (define (add-req req inner) `(let ([,req (car ,argv-temp)]) - (set! ,argv-temp (cdr ,argv-temp)) + (define (add-req req inner) `(let ([,req (car ,argv)]) + (set! ,argv (cdr ,argv)) ,inner)) (define (add-opt opt-list inner) `(let (,(car opt-list)) - (if (pair? ,argv-temp) + (if (pair? ,argv) (begin - (set! ,(first opt-list) (car ,argv-temp)) - (set! ,argv-temp (cdr ,argv-temp))) + (set! ,(first opt-list) (car ,argv)) + (set! ,argv (cdr ,argv))) (set! ,(first opt-list) ,(second opt-list))) ,inner)) - (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs) + (define rest+bodyexprs (if rest `(let ([,rest ,argv]) ,@bodyexprs) `(begin ,@bodyexprs))) (narrow-binds `(%lambda () () ,((compose (lambda (bind) (transform-to-cps ctx bind)) - (lambda (bind) (add-return ctx k bind)) - flatten-binds) - `(%bind (,ctx ,k) - (%set! ,ctx %ctx) - (%set! ,k %k) - ,(simplify-form - `(let ([,argv-temp %argv]) - ,(foldr add-req - (foldr add-opt - rest+bodyexprs - optionals) - requireds)))))))) + (lambda (bind) (add-return ctx k bind))) + (simplify-form + `(let ([,argv %argv] + [,ctx %ctx] + [,k %k]) + ,(foldr add-req + (foldr add-opt + rest+bodyexprs + optionals) + requireds))))))) (define (narrow-binds simple-lambda-form) (define bind (fourth simple-lambda-form)) @@ -705,7 +710,8 @@ ; (%set! k-argv (%cons k %nil)) ; (%tail-call l k-argv ctx k)) -(define (transform-to-cps ctx bind) +(define (transform-to-cps ctx nested-bind) + (define flat-bind (flatten-binds nested-bind)) (define (cps-prepend subform after) (cond ; (%set! v (%apply x y)) @@ -774,8 +780,8 @@ ; discard any form without side-effects [else after])) (flatten-binds - `(%bind ,(second bind) - ,@(foldr cps-prepend '() (cddr bind))))) + `(%bind ,(second flat-bind) + ,@(foldr cps-prepend '() (cddr flat-bind))))) ; (fn-expr arg-expr...) ; => (let ([fn-var fn-expr] arg-var... argv)