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:
parent
5c8625a1f1
commit
67ea700ac2
132
compiler.ss
132
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue