nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix handling of (set! var (let (var) ...)) and similar cases. 

Was moving (set!) into the (%bind) form, and thus setting the wrong variable.
Now, if set! var is bound, will create a temporary for result of %bind first,
and set! original variable to temporary in the proper scope.

Also, normalize rules for nested (%bind)s:
* The (%bind) inside a (%lambda) is always flat.
   - This is a responsiblity of simplify-lambda, and any function which
     may change structure after simplification (e.g. promote-to-box).
* Any other (%bind) may be nested, unless otherwise noted.
This commit is contained in:
Jesse D. McDonald 2010-04-21 11:31:11 -05:00
parent 5c8625a1f1
commit 67ea700ac2
1 changed files with 69 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

132
compiler.ss
View File

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