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

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.
This commit is contained in:
Jesse D. McDonald 2010-04-20 11:44:10 -05:00
parent 4ab23f6877
commit c5cf95b867
1 changed files with 503 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

780
compiler.ss
View File

@ -3,7 +3,7 @@
(define (trace fn . args) (define (trace fn . args)
(let ([x (apply fn args)]) (let ([x (apply fn args)])
(pretty-print x) (pretty-print (list fn x))
x)) x))
(define (subst old new lst) (define (subst old new lst)
@ -22,43 +22,54 @@
(when (eq? y x) (return i))) (when (eq? y x) (return i)))
#f)) #f))
(define (simplify-form form) (define (variable-value? form)
(if (pair? form) (and (symbol? form)
(case (car form) (not (eq? form '%undef))))
[(let) (simplify-let form)]
[(let*) (simplify-let* form)] (define (special-value? var)
[(letrec) (simplify-letrec form)] (and (memq var '(%nil %self %argv %ctx %k)) #t))
[(if) (simplify-if form)]
[(lambda) (simplify-lambda form)] (define (literal-value? form)
[(begin) (simplify-form `(let () ,@(cdr form)))] (and (not (variable-value? form))
[(set!) (simplify-set! form)] (or (not (pair? form))
[(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))] (eq? (first form) 'quote)
[(car cdr cons call/cc) (eq? (first form) '%template))))
(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 (simple-value? form) (define (simple-value? form)
(or (not (pair? form)) (or (variable-value? form)
(eq? (first form) 'quote) (literal-value? form)))
(eq? (first form) '%template)))
; 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 (define (map-form form
#:bind [bind-fn (lambda (recurse op vars . subforms) #:bind [bind-fn (lambda (recurse op vars . subforms)
@ -96,58 +107,129 @@
#:literal literal-fn #:literal literal-fn
#:other other-fn)) #:other other-fn))
(if (simple-value? form) (cond
(if (and (symbol? form) (not (memq form '(%nil %undef)))) [(variable-value? form) (variable-fn recurse 'variable form)]
(variable-fn recurse 'variable form) [(literal-value? form) (literal-fn recurse 'literal form)]
(literal-fn recurse 'literal form)) [else
(apply (case (first form) (let ([handler (case (first form)
[(%bind) bind-fn] [(%bind) bind-fn]
[(%lambda) lambda-fn] [(%lambda) lambda-fn]
[(%set!) set-fn] [(%set!) set-fn]
[(%apply) apply-fn] [(%apply) apply-fn]
[(%call/cc) call/cc-fn] [(%call/cc) call/cc-fn]
[(%tail-call) tail-call-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) ; Like map-form, but intended for boolean results. (Just different defaults.)
primitive-fn] (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]) #:primitive [primitive-fn (lambda (recurse op . simple-values)
recurse form))) (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]) (define (form-sets? form variable [call-may-set? #t])
(map-form (simplify-form form) (search-form (simplify-form form)
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(and (not (memq variable vars)) (and (not (memq variable vars))
(ormap recurse subforms))) (ormap recurse subforms)))
#:lambda (lambda _ #f) #:lambda (lambda _ #f)
#:set (lambda (recurse op var complex-value) (eq? var variable)) #:set (lambda (recurse op var complex-value)
#:primitive (lambda _ #f) (eq? var variable))
#:call (lambda _ call-may-set?) #:call (lambda _ call-may-set?)))
#:simple (lambda _ #f)))
(define (form-uses? form variable [call-may-use? #t] [descend? #t]) (define (form-uses? form variable [call-may-use? #t] [descend? #t])
(map-form (simplify-form form) (search-form (simplify-form form)
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(and (not (memq variable vars)) (and (not (memq variable vars))
(ormap recurse subforms))) (ormap recurse subforms)))
#:lambda (lambda (recurse op g-vars i-vars bind) (and descend? (recurse bind))) #:lambda (lambda (recurse op g-vars i-vars bind)
#:set (lambda (recurse op var complex-value) (recurse complex-value)) (and descend? (recurse bind)))
#:primitive (lambda (recurse op . simple-values) (ormap recurse simple-values)) #:call (lambda (recurse op . simple-values)
#:call (lambda (recurse op . simple-values) (or call-may-use? (ormap recurse simple-values)))
(or call-may-use? (ormap recurse simple-values))) #:variable (lambda (recurse op var) (eq? var variable))))
#:simple (lambda _ #f)
#:variable (lambda (recurse op var) (eq? var variable))))
(define (form-captures? form variable [input? #t] [output? #t]) (define (form-captures? form variable [input? #t] [output? #t])
(map-form (simplify-form form) (search-form (simplify-form form)
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(and (not (memq variable vars)) (and (not (memq variable vars))
(ormap recurse subforms))) (ormap recurse subforms)))
#:lambda (lambda (recurse op g-vars i-vars bind) #:lambda (lambda (recurse op g-vars i-vars bind)
(and (memq variable (free-variables bind input? output?)) #t)) (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)))
(define (form-captures-input? form var) (define (form-captures-input? form var)
(form-captures? form var #t #f)) (form-captures? form var #t #f))
@ -163,30 +245,31 @@
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(cond (cond
[(pair? after) (cons subform after)] [(pair? after) (cons subform after)]
[(or (not (pair? subform)) [(and (pair? subform) (eq? (first subform) '%values))
(memq (first subform) '(%apply %call/cc %car %cdr %cons %bind %if %unbox quote))) ; Requires at least one value; ignores extras.
`((set! ,(second form) ,subform))] (if (null? (cdr subform))
[(and (pair? subform) (eq? (first subform) '%tail-call)) (error "Attempted to set variable to void in:" form)
`(,subform)] ; The %set! wouldn't be executed anyway. `((set! ,(second form) ,(second subform))))]
[else [(value-form? subform) `((set! ,(second form) ,subform))]
`(,subform [else (error "Attempted to set variable to non-value in:" form)]))
(%set! ,(second form) %void))]))
'() '()
(cddr value-form)))) (cddr value-form))))
`(%set! ,(second form) ,value-form)))) `(%set! ,(second form) ,value-form))))
(define (simplify-primitive new-id value-forms) (define (simplify-primitive simple-op value-forms)
(define bindings (map (lambda (vf) (define (value->binding value-form)
(let ([simple-vf (simplify-form vf)]) (let ([simple-value-form (simplify-form value-form)])
(if (simple-value? simple-vf) (if (simple-value? simple-value-form)
(list simple-vf #f) (list simple-value-form #f)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
(list tmp (simplify-set! `(set! ,tmp ,simple-vf))))))) (list tmp (simplify-set! `(set! ,tmp ,simple-value-form)))))))
value-forms))
(define bindings (map value->binding value-forms))
(simplify-form (simplify-form
`(let ,(map first (filter second bindings)) `(let ,(map first (filter second bindings))
,@(filter-map 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 ; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
; => (%bind (tmp...) ; => (%bind (tmp...)
@ -196,34 +279,39 @@
; bodyexpr...)) ; bodyexpr...))
(define (simplify-let form) (define (simplify-let form)
(define bindings (second form)) (define (simplify-binding binding)
(define bodyexprs (cdr (cdr form))) (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 (flatten-binds
(cond ; If the value of any binding refers to one of the variable names being bound...
[(not (pair? bindings)) (if (ormap (lambda (value) (ormap bound-var? (free-variables value)))
`(%bind () ,@(map simplify-form bodyexprs))] (map second (filter has-value? bindings)))
[(not (pair? (cdr bindings))) ; ...then bind the values to temps first, before binding the real names.
(let ([binding (first bindings)]) (let ([temp-bindings (map (lambda (binding)
`(%bind (,(if (pair? binding) (first binding) binding)) (let ([tmp (gensym)])
,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding) (list tmp
,(second binding)))) (simplify-form `(set! ,tmp ,(second binding)))
'()) `(%set! ,(first binding) ,tmp))))
,@(map simplify-form bodyexprs)))] (filter has-value? bindings))])
[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)])
`(%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.
`(%bind ,vars
,@(map (lambda (binding)
(simplify-set! `(set! ,@binding)))
(filter has-value? bindings))
,@(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])
@ -233,7 +321,7 @@
(define (simplify-let* form) (define (simplify-let* form)
(define bindings (second form)) (define bindings (second form))
(define bodyexprs (cdr (cdr form))) (define bodyexprs (cddr form))
(define (add-binding bind bodyexpr) (define (add-binding bind bodyexpr)
`(let (,bind) ,bodyexpr)) `(let (,bind) ,bodyexpr))
(simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings))) (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
@ -245,7 +333,7 @@
(define (simplify-letrec form) (define (simplify-letrec form)
(define bindings (second form)) (define bindings (second form))
(define bodyexprs (cdr (cdr form))) (define bodyexprs (cddr form))
(simplify-form (simplify-form
`(let (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings)) `(let (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
,@(append-map ,@(append-map
@ -257,21 +345,24 @@
,@bodyexprs))) ,@bodyexprs)))
(define (simplify-if form) (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) (define-values (cond-expr true-expr false-expr)
(apply values (cdr form))) (apply values (cdr form)))
(simplify-form (let ([true-form (simplify-form true-expr)]
(if (or (pair? true-expr) (pair? false-expr)) [false-form (simplify-form false-expr)]
`(let ([,cond-val ,cond-expr] [cond-val (gensym)])
[,true-fn (lambda () ,true-expr)] (simplify-form
[,false-fn (lambda () ,false-expr)]) (if (and (simple-value? true-form)
(let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)]) (simple-value? false-form))
(%apply ,next-fn %nil))) `(let ([,cond-val ,cond-expr])
`(let ([,cond-val ,cond-expr]) (%if ,cond-val ,true-form ,false-form))
(%if ,cond-val ,(simplify-form true-expr) ,(simplify-form false-expr)))))) (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 (required... [optional default-expr]... . rest) bodyexpr...)
; => (lambda argv ; => (lambda argv
@ -309,49 +400,32 @@
(values (cons (car arglist) req) opt rst))) (values (cons (car arglist) req) opt rst)))
(values '() '() #f))) (values '() '() #f)))
(define (add-return ctx k rval form) (define (add-return ctx k form)
(define k-argv (gensym)) (define argv (gensym))
`(%bind (,@(second form) ,k-argv) `(%bind (,@(second form) ,argv)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(cond (cond
[(pair? after) [(pair? after)
(cons subform after)] (cons subform after)]
[(and (pair? subform) [(simple-value? subform)
(eq? (first subform) '%set!) `((%set! ,argv (%cons ,subform %nil))
(eq? (second subform) rval) (%tail-call ,k ,argv #f #f))]
(pair? (third subform)) [(eq? (first subform) '%apply)
(eq? (first (third subform)) '%apply)) `((%tail-call ,(second subform) ,(third subform) ,ctx ,k))]
(let ([fn (second (third subform))] [(eq? (first subform) '%call/cc)
[argv (third (third subform))]) `((%set! ,argv (%cons %k %nil))
`((%tail-call ,fn ,argv ,ctx ,k)))] (%tail-call ,(second subform) ,argv ,ctx %k))]
[(and (pair? subform) [(eq? (first subform) '%values)
(eq? (first subform) '%set!) `((%set! ,argv %nil)
(eq? (second subform) rval) ,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
(pair? (third subform)) (reverse (cdr subform)))
(eq? (first (third subform)) '%call/cc)) (%tail-call ,k ,argv #f #f))]
(let ([fn (second (third subform))]) [(value-form? subform)
`((%set! ,k-argv (%cons %k %nil)) `((%set! ,argv ,subform)
(%tail-call ,fn ,k-argv ,ctx %k)))] (%set! ,argv (%cons ,argv %nil))
[(and (pair? subform) (%tail-call ,k ,argv #f #f))]
(eq? (first subform) '%tail-call)) [(eq? (first subform) '%tail-call)
`(,subform)] `(,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 [else
`(,subform `(,subform
(%tail-call ,k %nil #f #f))])) (%tail-call ,k %nil #f #f))]))
@ -366,7 +440,6 @@
(define argv-temp (gensym)) (define argv-temp (gensym))
(define ctx (gensym)) (define ctx (gensym))
(define k (gensym)) (define k (gensym))
(define rval (gensym))
(define (add-req req inner) `(let ([,req (car ,argv-temp)]) (define (add-req req inner) `(let ([,req (car ,argv-temp)])
(set! ,argv-temp (cdr ,argv-temp)) (set! ,argv-temp (cdr ,argv-temp))
@ -380,20 +453,21 @@
,inner)) ,inner))
(define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs) (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
`(begin ,@bodyexprs))) `(begin ,@bodyexprs)))
`(%lambda () () (narrow-binds
,((compose (lambda (x) (transform-to-cps ctx x)) `(%lambda () ()
(lambda (x) (add-return ctx k rval x)) ,((compose (lambda (bind) (transform-to-cps ctx bind))
flatten-binds) (lambda (bind) (add-return ctx k bind))
`(%bind (,rval ,ctx ,k) flatten-binds)
(%set! ,ctx %ctx) `(%bind (,ctx ,k)
(%set! ,k %k) (%set! ,ctx %ctx)
,(simplify-form (%set! ,k %k)
`(set! ,rval (let ([,argv-temp %argv]) ,(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))
@ -420,25 +494,25 @@
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form) `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
(%bind ,(remove* extra-binds (second bind)) (%bind ,(remove* extra-binds (second bind))
,@(map (lambda (subform) ,@(map (lambda (subform)
(foldl (lambda (var subform) (if (and (pair? subform)
(if (and (pair? subform) (eq? (first subform) '%set!)
(eq? (first subform) '%set!) (pair? (third subform))
(pair? (third subform)) (eq? (first (third subform)) '%lambda))
(eq? (first (third subform)) '%lambda)) (let* ([dest (second subform)]
(let* ([dest (second subform)] [value (third subform)]
[value (third subform)] [g-vars (second value)]
[g-vars (second value)] [i-vars (third value)])
[i-vars (third value)] `(%set! ,dest ,(foldl (lambda (var temp-value)
[bind (fourth value)]) (define temp-bind (fourth temp-value))
`(%set! ,dest ,(narrow-binds (if (form-captures? temp-value var)
`(%lambda ,g-vars ,i-vars (narrow-binds
,(if (form-captures? value var) `(%lambda ,g-vars ,i-vars
`(%bind (,@(second bind) ,var) (%bind (,@(second temp-bind) ,var)
,@(cddr bind)) ,@(cddr temp-bind))))
bind))))) temp-value))
subform)) value
subform extra-binds)))
extra-binds)) subform))
(cddr bind))))) (cddr bind)))))
(define (promote-to-box variable form) (define (promote-to-box variable form)
@ -478,9 +552,9 @@
(if (eq? var variable) `(%unbox ,variable) var)))) (if (eq? var variable) `(%unbox ,variable) var))))
; form needs to be flattened (%bind ...) ; form needs to be flattened (%bind ...)
(define (is-shared-var? var form) (define (is-shared-var? var bind)
(define captured-input? (ormap (lambda (f) (form-captures-input? f var)) (cddr form))) (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 form))) (define captured-output? (ormap (lambda (f) (form-captures-output? f var)) (cddr bind)))
(define (set-after-first-use?) (define (set-after-first-use?)
(let/cc return (let/cc return
(foldr (lambda (subform set-after?) (foldr (lambda (subform set-after?)
@ -490,9 +564,10 @@
#t) #t)
#f)) #f))
#f #f
(cddr form)) (cddr bind))
#f)) #f))
(and (or captured-input? (and (not (special-value? var))
(or captured-input?
captured-output?) captured-output?)
(set-after-first-use?))) (set-after-first-use?)))
@ -605,8 +680,7 @@
,ctx ,ctx
,k))))] ,k))))]
; keep all other forms with side-effects as-is ; keep all other forms with side-effects as-is
[(and (pair? subform) [(statement-form? subform)
(memq (first subform) '(%set! %set-box! %set-car! %set-cdr! %tail-call)))
(cons subform after)] (cons subform after)]
; discard any form without side-effects ; discard any form without side-effects
[else after])) [else after]))
@ -646,24 +720,31 @@
(if (eq? var old-var) new-var var)))) (if (eq? var old-var) new-var var))))
(define (flatten-binds form) (define (flatten-binds form)
(define (make-bindings-unique bind) (define (make-bindings-unique bind rename-vars)
(foldr (lambda (var bind) (define (needs-rename? var) (memq var rename-vars))
(subst-var var (gensym) bind)) (define (make-binding-unique var bind)
bind (let* ([prefix (string-append (symbol->string var) "->g")]
(second bind))) [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)) (map-form form
(let* ([bound-vars (second form)] #:bind (lambda (recurse op bound-vars . original-subforms)
[subforms (append-map (lambda (subform) (define rename-vars
(if (and (pair? subform) (eq? (car subform) '%bind)) (remove-duplicates
(let ([unique-form (make-bindings-unique (append (free-variables `(,op ,bound-vars ,@original-subforms))
(flatten-binds subform))]) bound-vars)))
(set! bound-vars (append (second unique-form) bound-vars)) (define (form->list subform)
(cddr unique-form)) (if (bind-form? subform)
(list subform))) (let ([unique-form (make-bindings-unique
(cddr form))]) (recurse subform)
`(%bind ,bound-vars ,@subforms)) rename-vars)])
form)) (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]) (define (free-variables form [input? #t] [output? #t])
(map-form form (map-form form
@ -680,8 +761,8 @@
(remove-duplicates (append-map recurse simple-values))) (remove-duplicates (append-map recurse simple-values)))
#:simple (lambda (recurse kind form) #:simple (lambda (recurse kind form)
(if (and input? (if (and input?
(symbol? form) (variable-value? form)
(not (memq form '(%nil %undef %self %argv %ctx %k)))) (not (memq form '(%nil %self %argv %ctx %k))))
(list form) (list form)
'())))) '()))))
@ -693,37 +774,128 @@
; Don't bind variables which aren't referenced. ; Don't bind variables which aren't referenced.
(define (reduce-variables form) (define (reduce-variables form)
(map-form form (define (bind-fn recurse op vars . subforms)
#:bind (lambda (recurse op vars . subforms) (let* ([reduced-forms (map recurse subforms)]
(let ([ref-vars (remove-duplicates (append-map free-variables subforms))]) [ref-vars (remove-duplicates (append-map free-variables reduced-forms))])
`(%bind ,(filter (lambda (x) (memq x ref-vars)) vars) (define (referenced? var) (and (memq var ref-vars) #t))
,@(map recurse subforms)))))) `(%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. ; Don't set variables which won't be accessed later.
(define (reduce-set! form) (define (reduce-set! form)
(map-form form (define (bind-fn recurse op vars . subforms)
#:bind (lambda (recurse op vars . subforms) (define (prepend-if-used subform after)
(define (prepend-if-used subform after) (if (and (pair? subform)
(if (and (pair? subform) (eq? (first subform) '%set!)
(eq? (first subform) '%set!) (or (memq (second subform) vars)
(memq (second subform) vars) (error "Setting unbound var:" subform))
(not (memq (second subform) (not (value-used? (second subform) after)))
(append-map free-input-variables after)))) after
after (cons subform after)))
(cons subform after))) `(%bind ,vars
`(%bind ,vars ,@(foldr prepend-if-used '() (map recurse subforms))))
,@(foldr prepend-if-used '() (map recurse subforms)))))) (narrow-binds
(map-form form #:bind bind-fn)))
(define (simplify-toplevel-lambda form) (define (propogate-value variable value invalidates? forms)
(promote-free-vars (if (null? forms)
(promote-shared-vars forms
(narrow-binds (let* ([form (car forms)]
(simplify-lambda form))))) [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) ; Simple values (literals, variables) can replace arguments as well as %set! values.
(reduce-variables (define (propogate-simple-value variable value invalidates? forms)
(reduce-set! (if (null? forms)
form))) 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 (define frame-vars
(for/list ([i (in-range 0 120)]) (for/list ([i (in-range 0 120)])
@ -743,8 +915,8 @@
(define (global-var? var) (and (memq var global-vars) #t)) (define (global-var? var) (and (memq var global-vars) #t))
(define (special-var? var) (define (machine-var? var)
(or (and (memq var '(%nil %self %argv %ctx %k)) #t) (or (special-value? var)
(frame/instance-var? var) (frame/instance-var? var)
(global-var? var))) (global-var? var)))
@ -754,38 +926,92 @@
[unused-g-vars global-vars] [unused-g-vars global-vars]
[i-vars '()]) [i-vars '()])
(define (add-g-var value) (define (add-g-var value)
(let/cc return (let ([value (if (and (pair? value) (eq? (first value) 'quote))
(for ([g-var (in-list global-vars)] (second value)
[val (in-list g-vars)]) value)])
(when (eq? value val) (return g-var))) (let/cc return
(let ([g-var (first unused-g-vars)]) (for ([g-var (in-list global-vars)]
(set! unused-g-vars (cdr unused-g-vars)) [val (in-list g-vars)])
(set! g-vars (append g-vars (list value))) (when (eq? value val) (return g-var)))
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)))] (for ([free-var (in-list (filter frame/instance-var? (free-variables bind)))]
[inst-var (in-list instance-vars)]) [inst-var (in-list instance-vars)])
(set! i-vars (append i-vars (list free-var))) (set! i-vars (append i-vars (list free-var)))
(set! bind (subst-var free-var inst-var bind))) (set! bind (subst-var free-var inst-var bind)))
(for ([bound-var (in-list (second bind))] (for ([bound-var (in-list (second bind))]
[frame-var (in-list frame-vars)]) [frame-var (in-list frame-vars)])
(set! bind (subst-var bound-var frame-var bind))) (set! bind (subst-var bound-var frame-var bind)))
(set! bind (map-form bind (set! bind (map-form bind
#:lambda (lambda (recurse op inner-g-vars i-vars bind) #:lambda (lambda (recurse op inner-g-vars i-vars bind)
`(%make-lambda ,((compose add-g-var map-variables) `(%make-lambda ,((compose add-g-var map-variables)
`(%template ,inner-g-vars ,i-vars ,bind)))) `(%template ,inner-g-vars ,i-vars ,bind))))
#:variable (lambda (recurse kind form) #: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) #:literal (lambda (recurse kind form)
(if (eq? form '%nil) form (add-g-var 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))) ,bind)))
((compose (define (variable->code var)
pretty-print (or (and (eq? var '%nil) #x00)
map-variables (let ([index (find var global-vars)])
optimize-simplified-lambda (and index (+ #x01 index)))
simplify-toplevel-lambda) (let ([index (find var instance-vars)])
`(lambda () ,(read))) (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: ; vim:set sw=2 expandtab: