From c5cf95b867fc42c3b2b3fb7d411e9c6154952d81 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Tue, 20 Apr 2010 11:44:10 -0500 Subject: [PATCH] Implement basic value-propogation and support for multiple return values. Also performed misc. cleanup, corrected use of temp variables in (let ...), changed make-bindings-unique to preserve original names as prefixes, improved detection of unused %set! forms in reduce-set!, and fixed map-variables to extract the real value from (quote ...) literal forms. --- compiler.ss | 780 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 503 insertions(+), 277 deletions(-) diff --git a/compiler.ss b/compiler.ss index 95ab8c1..e65ef9f 100755 --- a/compiler.ss +++ b/compiler.ss @@ -3,7 +3,7 @@ (define (trace fn . args) (let ([x (apply fn args)]) - (pretty-print x) + (pretty-print (list fn x)) x)) (define (subst old new lst) @@ -22,43 +22,54 @@ (when (eq? y x) (return i))) #f)) -(define (simplify-form form) - (if (pair? form) - (case (car form) - [(let) (simplify-let form)] - [(let*) (simplify-let* form)] - [(letrec) (simplify-letrec form)] - [(if) (simplify-if form)] - [(lambda) (simplify-lambda form)] - [(begin) (simplify-form `(let () ,@(cdr form)))] - [(set!) (simplify-set! form)] - [(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))] - [(car cdr cons call/cc) - (simplify-primitive (case (first form) - [(make-box) '%make-box] - [(set-box!) '%set-box!] - [(unbox) '%unbox] - [(cons) '%cons] - [(set-car!) '%set-car!] - [(car) '%car] - [(set-cdr!) '%set-cdr!] - [(cdr) '%cdr] - [(call/cc) '%call/cc] - ) - (cdr form))] - [(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) - form] - [else (simplify-funcall form)]) - (if (eq? form '()) '%nil form))) +(define (variable-value? form) + (and (symbol? form) + (not (eq? form '%undef)))) + +(define (special-value? var) + (and (memq var '(%nil %self %argv %ctx %k)) #t)) + +(define (literal-value? form) + (and (not (variable-value? form)) + (or (not (pair? form)) + (eq? (first form) 'quote) + (eq? (first form) '%template)))) (define (simple-value? form) - (or (not (pair? form)) - (eq? (first form) 'quote) - (eq? (first form) '%template))) + (or (variable-value? form) + (literal-value? form))) + +; A value-form is any simple form which can appear on the right-hand side of a (set! ...). +; If there are any side-effect they occur before the variable is updated. +(define (value-form? form) + (define value-ops + '(%bind %if %apply %call/cc %make-lambda + %make-box %unbox %cons %car %cdr %values)) + (or (simple-value? form) (memq (first form) value-ops))) + +; A pure-form is any simple form known to be free of side effects. +; Creation of a new object is not counted as a side-effect. +; Pure-forms are a subset of value-forms. +(define (pure-form? form) + (define pure-ops + '(%if %make-lambda %make-box %unbox %cons %car %cdr %values)) + (or (simple-value? form) (memq (first form) pure-ops))) + +; A statement-form is any simple form which has, or may have, side-effects. +(define (statement-form? form) + (define statement-ops + '(%set! %set-box! %set-car! %set-cdr! %apply %call/cc %tail-call)) + (and (pair? form) (memq (first form) statement-ops))) + +(define (primitive-form? form) + (define primitives + '(%make-box %set-box! %unbox + %cons %set-car! %car %set-cdr! %cdr + %if %make-lambda %values)) + (and (pair? form) (memq (first form) primitives))) + +(define (bind-form? form) + (and (pair? form) (eq? (first form) '%bind))) (define (map-form form #:bind [bind-fn (lambda (recurse op vars . subforms) @@ -96,58 +107,129 @@ #: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] + (cond + [(variable-value? form) (variable-fn recurse 'variable form)] + [(literal-value? form) (literal-fn recurse 'literal form)] + [else + (let ([handler (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] + [else (if (primitive-form? form) + primitive-fn + other-fn)])]) + (apply handler recurse form))])) - [(%if %cons %set-car! %car %set-cdr! %cdr %make-box %set-box! %unbox %make-lambda) - primitive-fn] +; Like map-form, but intended for boolean results. (Just different defaults.) +(define (search-form form + #:merge-with [merge-fn ormap] + #:base-value [base-value #f] + #:bind [bind-fn (lambda (recurse op vars . subforms) + (merge-fn recurse subforms))] + #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) + (recurse bind))] + #:set [set-fn (lambda (recurse op var value) + (recurse value))] - [else other-fn]) - recurse form))) + #:primitive [primitive-fn (lambda (recurse op . simple-values) + (merge-fn 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) base-value)] + #:variable [variable-fn simple-fn] + #:literal [literal-fn simple-fn] + + #:other [other-fn (lambda (recurse . form) + (error "Unsimplified form:" form))]) + (map-form form + #: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)) + +(define (simplify-form form) + (define (same-form recurse . form) form) + (map-form form + #:bind same-form + #:lambda same-form + #:set same-form + #:primitive same-form + #:simple (lambda (recurse kind form) form) + #:literal (lambda (recurse kind form) + (if (and (pair? form) + (eq? (first form) 'quote) + (eq? (second form) '())) + '%nil + form)) + #:other (lambda (recurse op . others) + (case op + [(let) (simplify-let form)] + [(let*) (simplify-let* form)] + [(letrec) (simplify-letrec form)] + [(if) (simplify-if form)] + [(lambda) (simplify-lambda form)] + [(begin) (simplify-form `(let () ,@(cdr form)))] + [(set!) (simplify-set! form)] + [(let/cc) (simplify-form + `(call/cc (lambda (,(second form)) ,@(cddr form))))] + [(call/cc values make-box set-box! unbox + cons set-car! car set-cdr! cdr) + (simplify-primitive (case (first form) + [(call/cc) '%call/cc] + [(values) '%values] + [(make-box) '%make-box] + [(set-box!) '%set-box!] + [(unbox) '%unbox] + [(cons) '%cons] + [(set-car!) '%set-car!] + [(car) '%car] + [(set-cdr!) '%set-cdr!] + [(cdr) '%cdr]) + (cdr form))] + [else (simplify-funcall 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))) + (search-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)) + #:call (lambda _ call-may-set?))) (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)))) + (search-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))) + #:call (lambda (recurse op . simple-values) + (or call-may-use? (ormap recurse simple-values))) + #: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))) + (search-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)))) (define (form-captures-input? form var) (form-captures? form var #t #f)) @@ -163,30 +245,31 @@ ,@(foldr (lambda (subform after) (cond [(pair? after) (cons subform after)] - [(or (not (pair? subform)) - (memq (first subform) '(%apply %call/cc %car %cdr %cons %bind %if %unbox quote))) - `((set! ,(second form) ,subform))] - [(and (pair? subform) (eq? (first subform) '%tail-call)) - `(,subform)] ; The %set! wouldn't be executed anyway. - [else - `(,subform - (%set! ,(second form) %void))])) + [(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 non-value in:" form)])) '() (cddr value-form)))) `(%set! ,(second form) ,value-form)))) -(define (simplify-primitive new-id value-forms) - (define bindings (map (lambda (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 (simplify-primitive simple-op value-forms) + (define (value->binding value-form) + (let ([simple-value-form (simplify-form value-form)]) + (if (simple-value? simple-value-form) + (list simple-value-form #f) + (let ([tmp (gensym)]) + (list tmp (simplify-set! `(set! ,tmp ,simple-value-form))))))) + + (define bindings (map value->binding value-forms)) + (simplify-form `(let ,(map first (filter second bindings)) ,@(filter-map second bindings) - (,new-id ,@(map first bindings))))) + (,simple-op ,@(map first bindings))))) ; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel ; => (%bind (tmp...) @@ -196,34 +279,39 @@ ; bodyexpr...)) (define (simplify-let form) - (define bindings (second form)) - (define bodyexprs (cdr (cdr form))) + (define (simplify-binding binding) + (if (pair? binding) + (list (first binding) (simplify-form (second binding))) + (list binding))) + (define bindings (map simplify-binding (second form))) + (define bodyexprs (cddr form)) + + (define (has-value? binding) (pair? (cdr binding))) + (define vars (map first bindings)) + (define (bound-var? var) (and (memq var vars) #t)) + (flatten-binds - (cond - [(not (pair? bindings)) - `(%bind () ,@(map simplify-form bodyexprs))] - [(not (pair? (cdr bindings))) - (let ([binding (first bindings)]) - `(%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) - (if (pair? x) - (let ([tmp (gensym)]) - `((,tmp - ,(simplify-form `(set! ,tmp ,(second x))) - (%set! ,(first x) ,tmp)))) - '())) - bindings)]) + ; 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))))]))) + ,@(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]) @@ -233,7 +321,7 @@ (define (simplify-let* form) (define bindings (second form)) - (define bodyexprs (cdr (cdr form))) + (define bodyexprs (cddr form)) (define (add-binding bind bodyexpr) `(let (,bind) ,bodyexpr)) (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings))) @@ -245,7 +333,7 @@ (define (simplify-letrec form) (define bindings (second form)) - (define bodyexprs (cdr (cdr form))) + (define bodyexprs (cddr form)) (simplify-form `(let (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings)) ,@(append-map @@ -257,21 +345,24 @@ ,@bodyexprs))) (define (simplify-if form) - (define cond-val (gensym)) - (define next-fn (gensym)) - (define true-fn (gensym)) - (define false-fn (gensym)) (define-values (cond-expr true-expr false-expr) (apply values (cdr form))) - (simplify-form - (if (or (pair? true-expr) (pair? false-expr)) - `(let ([,cond-val ,cond-expr] - [,true-fn (lambda () ,true-expr)] - [,false-fn (lambda () ,false-expr)]) - (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)]) - (%apply ,next-fn %nil))) - `(let ([,cond-val ,cond-expr]) - (%if ,cond-val ,(simplify-form true-expr) ,(simplify-form false-expr)))))) + (let ([true-form (simplify-form true-expr)] + [false-form (simplify-form false-expr)] + [cond-val (gensym)]) + (simplify-form + (if (and (simple-value? true-form) + (simple-value? false-form)) + `(let ([,cond-val ,cond-expr]) + (%if ,cond-val ,true-form ,false-form)) + (let ([next-fn (gensym)] + [true-fn (gensym)] + [false-fn (gensym)]) + `(let ([,cond-val ,cond-expr] + [,true-fn (lambda () ,true-form)] + [,false-fn (lambda () ,false-form)]) + (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)]) + (%apply ,next-fn %nil)))))))) ; (lambda (required... [optional default-expr]... . rest) bodyexpr...) ; => (lambda argv @@ -309,49 +400,32 @@ (values (cons (car arglist) req) opt rst))) (values '() '() #f))) -(define (add-return ctx k rval form) - (define k-argv (gensym)) - `(%bind (,@(second form) ,k-argv) +(define (add-return ctx k form) + (define argv (gensym)) + `(%bind (,@(second form) ,argv) ,@(foldr (lambda (subform after) (cond [(pair? after) (cons subform after)] - [(and (pair? subform) - (eq? (first subform) '%set!) - (eq? (second subform) rval) - (pair? (third subform)) - (eq? (first (third subform)) '%apply)) - (let ([fn (second (third subform))] - [argv (third (third subform))]) - `((%tail-call ,fn ,argv ,ctx ,k)))] - [(and (pair? subform) - (eq? (first subform) '%set!) - (eq? (second subform) rval) - (pair? (third subform)) - (eq? (first (third subform)) '%call/cc)) - (let ([fn (second (third subform))]) - `((%set! ,k-argv (%cons %k %nil)) - (%tail-call ,fn ,k-argv ,ctx %k)))] - [(and (pair? subform) - (eq? (first subform) '%tail-call)) + [(simple-value? subform) + `((%set! ,argv (%cons ,subform %nil)) + (%tail-call ,k ,argv #f #f))] + [(eq? (first subform) '%apply) + `((%tail-call ,(second subform) ,(third subform) ,ctx ,k))] + [(eq? (first subform) '%call/cc) + `((%set! ,argv (%cons %k %nil)) + (%tail-call ,(second subform) ,argv ,ctx %k))] + [(eq? (first subform) '%values) + `((%set! ,argv %nil) + ,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv))) + (reverse (cdr subform))) + (%tail-call ,k ,argv #f #f))] + [(value-form? subform) + `((%set! ,argv ,subform) + (%set! ,argv (%cons ,argv %nil)) + (%tail-call ,k ,argv #f #f))] + [(eq? (first subform) '%tail-call) `(,subform)] - [(and (pair? subform) - (eq? (first subform) '%apply)) - `((%tail-call ,(second subform) - ,(third subform) - ,ctx - ,k))] - [(and (pair? subform) - (eq? (first subform) '%set!) - (eq? (second subform) rval) - (eq? (third subform) '%void)) - `((%tail-call ,k %nil #f #f))] - [(and (pair? subform) - (eq? (first subform) '%set!) - (eq? (second subform) rval)) - `(,subform - (%set! ,rval (%cons ,rval %nil)) - (%tail-call ,k ,rval #f #f))] [else `(,subform (%tail-call ,k %nil #f #f))])) @@ -366,7 +440,6 @@ (define argv-temp (gensym)) (define ctx (gensym)) (define k (gensym)) - (define rval (gensym)) (define (add-req req inner) `(let ([,req (car ,argv-temp)]) (set! ,argv-temp (cdr ,argv-temp)) @@ -380,20 +453,21 @@ ,inner)) (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs) `(begin ,@bodyexprs))) - `(%lambda () () - ,((compose (lambda (x) (transform-to-cps ctx x)) - (lambda (x) (add-return ctx k rval x)) - flatten-binds) - `(%bind (,rval ,ctx ,k) - (%set! ,ctx %ctx) - (%set! ,k %k) - ,(simplify-form - `(set! ,rval (let ([,argv-temp %argv]) - ,(foldr add-req - (foldr add-opt - rest+bodyexprs - optionals) - requireds)))))))) + (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)))))))) (define (narrow-binds simple-lambda-form) (define bind (fourth simple-lambda-form)) @@ -420,25 +494,25 @@ `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form) (%bind ,(remove* extra-binds (second bind)) ,@(map (lambda (subform) - (foldl (lambda (var subform) - (if (and (pair? subform) - (eq? (first subform) '%set!) - (pair? (third subform)) - (eq? (first (third subform)) '%lambda)) - (let* ([dest (second subform)] - [value (third subform)] - [g-vars (second value)] - [i-vars (third value)] - [bind (fourth value)]) - `(%set! ,dest ,(narrow-binds - `(%lambda ,g-vars ,i-vars - ,(if (form-captures? value var) - `(%bind (,@(second bind) ,var) - ,@(cddr bind)) - bind))))) - subform)) - subform - extra-binds)) + (if (and (pair? subform) + (eq? (first subform) '%set!) + (pair? (third subform)) + (eq? (first (third subform)) '%lambda)) + (let* ([dest (second subform)] + [value (third subform)] + [g-vars (second value)] + [i-vars (third value)]) + `(%set! ,dest ,(foldl (lambda (var temp-value) + (define temp-bind (fourth temp-value)) + (if (form-captures? temp-value var) + (narrow-binds + `(%lambda ,g-vars ,i-vars + (%bind (,@(second temp-bind) ,var) + ,@(cddr temp-bind)))) + temp-value)) + value + extra-binds))) + subform)) (cddr bind))))) (define (promote-to-box variable form) @@ -478,9 +552,9 @@ (if (eq? var variable) `(%unbox ,variable) var)))) ; form needs to be flattened (%bind ...) -(define (is-shared-var? var form) - (define captured-input? (ormap (lambda (f) (form-captures-input? f var)) (cddr form))) - (define captured-output? (ormap (lambda (f) (form-captures-output? f var)) (cddr form))) +(define (is-shared-var? var bind) + (define captured-input? (ormap (lambda (f) (form-captures-input? f var)) (cddr bind))) + (define captured-output? (ormap (lambda (f) (form-captures-output? f var)) (cddr bind))) (define (set-after-first-use?) (let/cc return (foldr (lambda (subform set-after?) @@ -490,9 +564,10 @@ #t) #f)) #f - (cddr form)) + (cddr bind)) #f)) - (and (or captured-input? + (and (not (special-value? var)) + (or captured-input? captured-output?) (set-after-first-use?))) @@ -605,8 +680,7 @@ ,ctx ,k))))] ; keep all other forms with side-effects as-is - [(and (pair? subform) - (memq (first subform) '(%set! %set-box! %set-car! %set-cdr! %tail-call))) + [(statement-form? subform) (cons subform after)] ; discard any form without side-effects [else after])) @@ -646,24 +720,31 @@ (if (eq? var old-var) new-var var)))) (define (flatten-binds form) - (define (make-bindings-unique bind) - (foldr (lambda (var bind) - (subst-var var (gensym) bind)) - bind - (second bind))) + (define (make-bindings-unique bind rename-vars) + (define (needs-rename? var) (memq var rename-vars)) + (define (make-binding-unique var bind) + (let* ([prefix (string-append (symbol->string var) "->g")] + [unique-var (gensym prefix)]) + (subst-var var unique-var bind))) + (foldr make-binding-unique bind (filter needs-rename? (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)) + (map-form form + #:bind (lambda (recurse op bound-vars . original-subforms) + (define rename-vars + (remove-duplicates + (append (free-variables `(,op ,bound-vars ,@original-subforms)) + bound-vars))) + (define (form->list subform) + (if (bind-form? subform) + (let ([unique-form (make-bindings-unique + (recurse subform) + rename-vars)]) + (set! bound-vars (append (second unique-form) bound-vars)) + (cddr unique-form)) + (list subform))) + (let ([subforms (append-map form->list original-subforms)]) + `(%bind ,bound-vars ,@subforms))) + #:lambda (lambda (recurse . form) form))) (define (free-variables form [input? #t] [output? #t]) (map-form form @@ -680,8 +761,8 @@ (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)))) + (variable-value? form) + (not (memq form '(%nil %self %argv %ctx %k)))) (list form) '())))) @@ -693,37 +774,128 @@ ; Don't bind variables which aren't referenced. (define (reduce-variables 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)))))) + (define (bind-fn recurse op vars . subforms) + (let* ([reduced-forms (map recurse subforms)] + [ref-vars (remove-duplicates (append-map free-variables reduced-forms))]) + (define (referenced? var) (and (memq var ref-vars) #t)) + `(%bind ,(filter referenced? vars) + ,@reduced-forms))) + (map-form form #:bind bind-fn)) + +(define (value-used? variable forms) + (cond + [(null? forms) #f] + [(form-uses? (first forms) variable #f #t) #t] + [(form-sets? (first forms) variable #f) #f] + [else (value-used? variable (cdr forms))])) ; Don't set variables which won't be accessed later. (define (reduce-set! form) - (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) vars) - (not (memq (second subform) - (append-map free-input-variables after)))) - after - (cons subform after))) - `(%bind ,vars - ,@(foldr prepend-if-used '() (map recurse subforms)))))) + (define (bind-fn recurse op vars . subforms) + (define (prepend-if-used subform after) + (if (and (pair? subform) + (eq? (first subform) '%set!) + (or (memq (second subform) vars) + (error "Setting unbound var:" subform)) + (not (value-used? (second subform) after))) + after + (cons subform after))) + `(%bind ,vars + ,@(foldr prepend-if-used '() (map recurse subforms)))) + (narrow-binds + (map-form form #:bind bind-fn))) -(define (simplify-toplevel-lambda form) - (promote-free-vars - (promote-shared-vars - (narrow-binds - (simplify-lambda form))))) +(define (propogate-value variable value invalidates? forms) + (if (null? forms) + forms + (let* ([form (car forms)] + [after (cdr forms)] + [new-form (case (first form) + [(%set!) (if (eq? (third form) variable) + `(%set! ,(second form) ,value) + form)] + [else form])]) + (if (or (and (eq? (first (car forms)) '%set!) + (eq? (second (car forms)) variable)) + (invalidates? new-form)) + (cons new-form after) + (cons new-form (propogate-value variable value invalidates? after)))))) -(define (optimize-simplified-lambda form) - (reduce-variables - (reduce-set! - form))) +; Simple values (literals, variables) can replace arguments as well as %set! values. +(define (propogate-simple-value variable value invalidates? forms) + (if (null? forms) + forms + (let* ([form (car forms)] + [after (cdr forms)] + [new-form (case (first form) + [(%set!) + (let ([set-value (if (eq? (third form) variable) value (third form))]) + (if (simple-value? set-value) + `(%set! ,(second form) ,set-value) + `(%set! ,(second form) + (,(first set-value) + ,@(subst variable value (cdr set-value))))))] + [else `(,(first form) ,@(subst variable value (cdr form)))])]) + (if (or (and (eq? (first (car forms)) '%set!) + (eq? (second (car forms)) variable)) + (invalidates? new-form)) + (cons new-form after) + (cons new-form (propogate-simple-value variable value invalidates? after)))))) + +; When value of var2 is known, change (%set! var1 var2) to (%set! var1 value). +; Known values are: +; literals, always +; var, until (%set! var ...) +; (%unbox var), until (%set-box! var ...) or (%set! var) +; (%car var), until (%set-car! var) or (%set! var) +; (%cdr var), until (%set-cdr! var) or (%set! var) +(define (propogate-set! form) + (define (bind-fn recurse op vars . subforms) + (define (prepend subform after) + (if (eq? (first subform) '%set!) + (let ([var (second subform)] + [value (third subform)]) + (cons + subform + (cond + [(simple-value? value) + (propogate-simple-value var value + (lambda (form) + (and (eq? (first form) '%set!) + (eq? (second form) value))) + after)] + [(eq? (first value) '%unbox) + (let ([box-var (second value)]) + (propogate-value var value + (lambda (form) + (or (and (eq? (first form) '%set!) + (eq? (second form) box-var)) + (and (eq? (first form) '%set-box!) + (eq? (second form) box-var)))) + after))] + [(eq? (first value) '%car) + (let ([pair-var (second value)]) + (propogate-value var value + (lambda (form) + (or (and (eq? (first form) '%set!) + (eq? (second form) pair-var)) + (and (eq? (first form) '%set-car!) + (eq? (second form) pair-var)))) + after))] + [(eq? (first value) '%cdr) + (let ([pair-var (second value)]) + (propogate-value var value + (lambda (form) + (or (and (eq? (first form) '%set!) + (eq? (second form) pair-var)) + (and (eq? (first form) '%set-cdr!) + (eq? (second form) pair-var)))) + after))] + [else after]))) + (cons subform after))) + `(%bind ,vars + ,@(foldr prepend '() (map recurse subforms)))) + (map-form form #:bind bind-fn)) (define frame-vars (for/list ([i (in-range 0 120)]) @@ -743,8 +915,8 @@ (define (global-var? var) (and (memq var global-vars) #t)) -(define (special-var? var) - (or (and (memq var '(%nil %self %argv %ctx %k)) #t) +(define (machine-var? var) + (or (special-value? var) (frame/instance-var? var) (global-var? var))) @@ -754,38 +926,92 @@ [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))) + (let ([value (if (and (pair? value) (eq? (first value) 'quote)) + (second value) + 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))) + (if (machine-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 + + `(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars ,bind))) -((compose - pretty-print - map-variables - optimize-simplified-lambda - simplify-toplevel-lambda) - `(lambda () ,(read))) +(define (variable->code var) + (or (and (eq? var '%nil) #x00) + (let ([index (find var global-vars)]) + (and index (+ #x01 index))) + (let ([index (find var instance-vars)]) + (and index (+ #x40 index))) + (let ([index (find var frame-vars)]) + (and index (+ #x80 index))) + (let ([index (find var '(%self %argv %ctx %k))]) + (and index (+ #xfc index))) + (error "No bytecode for variable:" var))) + +(define (statement->code form) + (case (first form) + [(%set!) (let ([out (variable->code (second form))] + [value (third form)]) + (if (machine-var? value) + (list #x00 out #x01 (variable->code value) form) + (case (first value) + [(%unbox) (list #x00 out #x02 (variable->code (second value)) form)] + [(%car) (list #x00 out #x03 (variable->code (second value)) form)] + [(%cdr) (list #x00 out #x04 (variable->code (second value)) form)] + [(%make-lambda) (list #x00 out #x1b (variable->code (second value)) form)] + [else (error "Unknown statement type:" form)])))] + [(%set-box!) (list #x50 (variable->code (second form)) (variable->code (third form)) #x00 form)] + [(%set-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00 form)] + [(%set-cdr!) (list #x52 (variable->code (second form)) (variable->code (third form)) #x00 form)] + [else (error "Unknown statement type:" form)])) + +(define (simplify-function lambda-form) + ((compose + promote-free-vars + promote-shared-vars + simplify-lambda + ) + lambda-form)) + +(define (optimize-function simple-lambda-form) + ((compose + reduce-variables + reduce-set! + propogate-set! + ) + simple-lambda-form)) + +(define (compile-function lambda-form) + ((compose pretty-print + map-variables + optimize-function + simplify-function + ) + lambda-form)) + +(compile-function `(lambda () ,(read))) ; vim:set sw=2 expandtab: