diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index 17ef994..44b0914 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -145,13 +145,12 @@ (define (bound-var? var) (and (memq var vars) #t)) ; 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))) + (if (ormap bound-var? (free-variables `(%bind () ,@(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))) + (simplify-set! `(set! ,tmp ,(second binding))) `(%set! ,(first binding) ,tmp)))) (filter has-value? bindings))]) `(%bind ,(map first temp-bindings) @@ -279,12 +278,10 @@ (if (eq? var variable) `(%unbox ,variable) var)))) (define (is-shared-var? var forms) - (define captured-input? (ormap (lambda (f) (form-captures-input? f var)) forms)) - (define captured-output? (ormap (lambda (f) (form-captures-output? f var)) forms)) (define (set-after-first-capture?) (let/cc return (foldr (lambda (form set-after?) - (if (or set-after? (form-sets? form var captured-output?)) + (if (or set-after? (form-sets? form var #f)) (if (form-captures-input? form var) (return #t) #t) @@ -292,9 +289,8 @@ #f forms) #f)) - (or captured-output? - (and captured-input? - (set-after-first-capture?)))) + (or (ormap (lambda (f) (form-captures-output? f var)) forms) + (set-after-first-capture?))) (define (promote-shared-variables nested-bind) (define flat-bind (flatten-binds nested-bind)) @@ -312,8 +308,8 @@ (define flat-bind (flatten-binds nested-bind)) (define (at-top-level? var) - (or (ormap (lambda (x) (form-sets? x var #f)) (cddr flat-bind)) - (ormap (lambda (x) (form-uses? x var #f)) (cddr flat-bind)))) + (or (ormap (lambda (x) (form-uses? x var #f)) (cddr flat-bind)) + (ormap (lambda (x) (form-sets? x var #f)) (cddr flat-bind)))) (define (captured-twice? var) (let/cc return @@ -321,7 +317,7 @@ (if (form-captures? subform var) (if once? (return #t) #t) once?)) - (at-top-level? var) + #f (cddr flat-bind)) #f)) @@ -337,13 +333,10 @@ [`(%set! ,var (%lambda ,g-vars ,i-vars ,bind)) `(%set! ,var (%lambda ,g-vars ,i-vars ,(narrow-binds+promote - (foldl (lambda (var temp-bind) - (if (memq var (free-variables temp-bind)) - `(%bind (,@(second temp-bind) ,var) - ,@(cddr temp-bind)) - temp-bind)) - bind - extra-bindings))))] + (let ([free-vars (free-variables bind)]) + (define (free-var? v) (memq v free-vars)) + `(%bind (,@(second bind) ,@(filter free-var? extra-bindings)) + ,@(cddr bind))))))] [_ subform])) (cddr flat-bind))))) diff --git a/libcompiler/utilities.scm b/libcompiler/utilities.scm index 7b69c94..7d37391 100644 --- a/libcompiler/utilities.scm +++ b/libcompiler/utilities.scm @@ -32,6 +32,9 @@ free-variables free-input-variables free-output-variables + free-variable? + free-input-variable? + free-output-variable? value-used?) (define (trace fn . args) @@ -231,25 +234,30 @@ #:set (lambda (recurse op var value-form) (or (eq? var variable) (recurse value-form))) + #:primitive (lambda _ #f) #:call (lambda _ call-may-set?))) (define (form-uses? form variable [call-may-use? #t]) (search-form form - #:bind (lambda (recurse op vars . subforms) - (and (not (memq variable vars)) - (ormap recurse subforms))) - #:lambda (lambda (recurse . form) #f) - #:call (lambda (recurse op . simple-values) - (or call-may-use? (ormap recurse simple-values))) - #:variable (lambda (recurse op var) (eq? var variable)))) + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:lambda (lambda (recurse . form) #f) + #:primitive (lambda (recurse op . simple-values) + (and (memq variable simple-values) #t)) + #:call (lambda (recurse op . simple-values) + (or call-may-use? (and (memq variable simple-values) #t))) + #:variable (lambda (recurse op var) (eq? var variable)))) (define (form-captures? form variable [input? #t] [output? #t]) (search-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)))) + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:lambda (lambda (recurse op g-vars i-vars bind) + (free-variable? variable bind input? output?)) + #:primitive (lambda _ #f) + #:simple (lambda _ #f))) (define (form-captures-input? form var) (form-captures? form var #t #f)) @@ -258,12 +266,12 @@ (form-captures? form var #f #t)) (define (value-used? variable forms) - (cond - [(null? forms) #f] - [(form-captures-input? (first forms) variable) #t] - [(form-uses? (first forms) variable #f) #t] - [(form-sets? (first forms) variable #f) #f] - [else (value-used? variable (cdr forms))])) + (and (not (null? forms)) + (let ([form (first forms)]) + (or (form-captures-input? form variable) + (form-uses? form variable #f) + (and (not (form-sets? form variable #f)) + (value-used? variable (cdr forms))))))) (define (subst-var old-var new-var form) (map-form form @@ -337,4 +345,21 @@ (define (free-output-variables form) (free-variables form #f #t)) +(define (free-variable? variable form [input? #t] [output? #t]) + (search-form form + #:bind (lambda (recurse op vars . subforms) + (and (not (memq variable vars)) + (ormap recurse subforms))) + #:set (lambda (recurse op var value) + (or (and output? (eq? var variable)) + (recurse value))) + #:variable (lambda (recurse kind var) + (and input? (eq? var variable))))) + +(define (free-input-variable? var form) + (free-variable? var form #t #f)) + +(define (free-output-variable? var form) + (free-variable? var form #f #t)) + ; vim:set sw=2 expandtab: