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

Implement register allocation. 

All that remains is to convert the result to bytecode & format as rosella source code.
This commit is contained in:
Jesse D. McDonald 2010-04-18 05:14:43 -05:00
parent c3e46525db
commit 35059dfebf
1 changed files with 344 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

626
compiler.ss
View File

@ -39,7 +39,8 @@
[(call/cc) '%call/cc] [(call/cc) '%call/cc]
) )
(cdr form))] (cdr form))]
[(%bind %if %set! %lambda quote [(quote) (if (eq? (second form) '()) '%nil form)]
[(%bind %if %set! %lambda
%tail-call %apply %call/cc %tail-call %apply %call/cc
%cons %set-car! %car %set-cdr! %cdr %cons %set-car! %car %set-cdr! %cdr
%make-box %set-box! %unbox) %make-box %set-box! %unbox)
@ -47,56 +48,99 @@
[else (simplify-funcall form)]) [else (simplify-funcall form)])
(if (eq? form '()) '%nil form))) (if (eq? form '()) '%nil form)))
(define (form-sets? form var [call-may-set? #t]) (define (simple-value? form)
(define (recurse simple-form) (or (not (pair? form))
(if (pair? simple-form) (eq? (first form) 'quote)
(case (car simple-form) (eq? (first form) '%template)))
[(%bind) (and (not (memq var (second simple-form)))
(ormap recurse (cddr simple-form)))]
[(%set!) (eq? (second simple-form) var)]
[(%tail-call %apply %call/cc) call-may-set?]
[(quote %lambda %if
%make-box %set-box! %unbox
%cons %set-car! %car %set-cdr! %cdr)
#f]
[else (error "Invalid simple form:" simple-form)])
#f))
(recurse (simplify-form form)))
(define (form-uses? form var [call-may-use? #t] [descend? #t]) (define (map-form form
(define (recurse simple-form) #:bind [bind-fn (lambda (recurse op vars . subforms)
(if (pair? simple-form) `(,op ,vars ,@(map recurse subforms)))]
(case (car simple-form) #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
[(%bind) (and (not (memq var (second simple-form))) `(,op ,g-vars ,i-vars ,(recurse bind)))]
(ormap recurse (cddr simple-form)))] #:set [set-fn (lambda (recurse op var value)
[(%set!) (recurse (third simple-form))] `(,op ,var ,(recurse value)))]
[(%tail-call %apply %call/cc) (and call-may-use? #t)]
[(%if %make-box %set-box! %unbox
%cons %set-car! %car %set-cdr! %cdr)
(ormap recurse (cdr simple-form))]
[(%lambda) (and descend?
(memq var (free-variables simple-form))
#t)]
[(quote) #f]
[else (error "Invalid simple form:" simple-form)])
(eq? simple-form var)))
(recurse (simplify-form form)))
(define (form-captures? form var [input? #t] [output? #t]) #:primitive [primitive-fn (lambda (recurse op . simple-values)
(define (recurse simple-form) `(,op ,@(map recurse simple-values)))]
(if (pair? simple-form) #:call [call-fn primitive-fn]
(case (car simple-form) #:apply [apply-fn call-fn]
[(%bind) (and (not (memq var (second simple-form))) #:call/cc [call/cc-fn call-fn]
(ormap recurse (cddr simple-form)))] #:tail-call [tail-call-fn call-fn]
[(%set!) (recurse (third simple-form))]
[(%tail-call %apply %call/cc %if quote #:simple [simple-fn (lambda (recurse kind form) form)]
%make-box %set-box! %unbox #:variable [variable-fn simple-fn]
%cons %set-car! %car %set-cdr! %cdr) #:literal [literal-fn simple-fn]
#f]
[(%lambda) (and (memq var (free-variables simple-form input? output?)) #t)] #:other [other-fn (lambda (recurse . form)
[else (error "Invalid simple form:" simple-form)]) (error "Unsimplified form:" form))])
#f)) (define (recurse subform)
(recurse (simplify-form form))) (map-form subform
#: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))
(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]
[(%if %cons %set-car! %car %set-cdr! %cdr %make-box %set-box! %unbox %make-lambda)
primitive-fn]
[else other-fn])
recurse 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)))
(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))))
(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)))
(define (form-captures-input? form var) (define (form-captures-input? form var)
(form-captures? form var #t #f)) (form-captures? form var #t #f))
@ -126,15 +170,15 @@
(define (simplify-primitive new-id value-forms) (define (simplify-primitive new-id value-forms)
(define bindings (map (lambda (vf) (define bindings (map (lambda (vf)
(if (pair? vf) (let ([simple-vf (simplify-form vf)])
(list (gensym) vf) (if (simple-value? simple-vf)
(list vf vf))) (list simple-vf #f)
(let ([tmp (gensym)])
(list tmp (simplify-set! `(set! ,tmp ,simple-vf)))))))
value-forms)) value-forms))
(define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x))))
bindings))
(simplify-form (simplify-form
`(let ,(map first temp-bindings) `(let ,(map first (filter second bindings))
,@(map (lambda (x) `(set! ,(first x) ,(second x))) temp-bindings) ,@(filter-map second bindings)
(,new-id ,@(map first bindings))))) (,new-id ,@(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
@ -153,12 +197,11 @@
`(%bind () ,@(map simplify-form bodyexprs))] `(%bind () ,@(map simplify-form bodyexprs))]
[(not (pair? (cdr bindings))) [(not (pair? (cdr bindings)))
(let ([binding (first bindings)]) (let ([binding (first bindings)])
(make-bindings-unique `(%bind (,(if (pair? binding) (first binding) binding))
`(%bind (,(if (pair? binding) (first binding) binding)) ,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding)
,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding) ,(second binding))))
,(second binding)))) '())
'()) ,@(map simplify-form bodyexprs)))]
,@(map simplify-form bodyexprs))))]
[else [else
(let ([vars (map (lambda (x) (if (pair? x) (first x) x)) bindings)] (let ([vars (map (lambda (x) (if (pair? x) (first x) x)) bindings)]
[temp-bindings (append-map (lambda (x) [temp-bindings (append-map (lambda (x)
@ -171,10 +214,9 @@
bindings)]) bindings)])
`(%bind ,(map first temp-bindings) `(%bind ,(map first temp-bindings)
,@(map second temp-bindings) ,@(map second temp-bindings)
,(make-bindings-unique (%bind ,vars
`(%bind ,vars ,@(map third temp-bindings)
,@(map third temp-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])
@ -329,7 +371,7 @@
,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 `(%lambda () ()
,((compose transform-to-cps ,((compose transform-to-cps
(lambda (x) (add-tail-call k rval x)) (lambda (x) (add-tail-call k rval x))
flatten-binds) flatten-binds)
@ -344,7 +386,7 @@
requireds)))))))) requireds))))))))
(define (narrow-binds simple-lambda-form) (define (narrow-binds simple-lambda-form)
(define bind (second simple-lambda-form)) (define bind (fourth simple-lambda-form))
(define (at-top-level? var) (define (at-top-level? var)
(or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind)) (or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind))
(ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind)))) (ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind))))
@ -362,7 +404,7 @@
(filter-not captured-twice? (filter-not captured-twice?
(filter-not at-top-level? (filter-not at-top-level?
(second bind)))) (second bind))))
`(%lambda `(%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) (foldl (lambda (var subform)
@ -372,9 +414,11 @@
(eq? (first (third subform)) '%lambda)) (eq? (first (third subform)) '%lambda))
(let* ([dest (second subform)] (let* ([dest (second subform)]
[value (third subform)] [value (third subform)]
[bind (second value)]) [g-vars (second value)]
[i-vars (third value)]
[bind (fourth value)])
`(%set! ,dest ,(narrow-binds `(%set! ,dest ,(narrow-binds
`(%lambda `(%lambda ,g-vars ,i-vars
,(if (form-captures? value var) ,(if (form-captures? value var)
`(%bind (,@(second bind) ,var) `(%bind (,@(second bind) ,var)
,@(cddr bind)) ,@(cddr bind))
@ -384,51 +428,41 @@
extra-binds)) extra-binds))
(cddr bind))))) (cddr bind)))))
(define (promote-to-box var form) (define (promote-to-box variable form)
(define (recurse subform) (promote-to-box var subform)) (map-form form
(if (pair? form) #:bind (lambda (recurse op vars . subforms)
(case (car form) (flatten-binds
[(%bind) `(%bind ,(subst variable variable vars)
(flatten-binds ,@(if (memq variable vars)
`(%bind ,(second form) `((%set! ,variable (%make-box %undef)))
,@(if (memq var (second form)) '())
`((%set! ,var (%make-box %undef))) ,@(map recurse subforms))))
'()) #:set (lambda (recurse op var value)
,@(map recurse (cddr form))))] (let ([new-value (recurse value)])
[(%lambda) (if (eq? var variable)
`(%lambda ,(recurse (second form)))] (if (simple-value? new-value)
[(%set!) `(%set-box! ,variable ,new-value)
(let ([value (recurse (third form))] (let ([tmp (gensym)])
[kind (if (eq? (second form) var) '%set-box! '%set!)]) `(%bind (,tmp)
; If value is (%bind), could only come from clause below. ,(simplify-set! `(set! ,tmp ,new-value))
(if (and (pair? value) (eq? (first value) '%bind)) (%set-box! ,variable ,tmp))))
(if (and (pair? (fourth value)) (not (eq? kind '%set!))) (simplify-set! `(set! ,var ,new-value)))))
(let ([tmp (gensym)]) #:primitive (lambda (recurse op . simple-values)
`(%bind (,@(second value) ,tmp) (let ([new-args (map recurse simple-values)])
,(third value) ;; if any new-arg is not simple, must bind to a temp first
(%set! ,tmp ,(fourth value)) (let ([temps (map (lambda (x)
(,kind ,(second form) ,tmp))) (if (simple-value? x)
`(%bind ,(second value) (list x #f)
,(third value) (let ([tmp (gensym)])
(,kind ,(second form) ,(fourth value)))) (list tmp `(%set! ,tmp ,x)))))
(if (and (pair? value) (not (eq? kind '%set!))) new-args)])
(let ([tmp (gensym)]) (if (ormap second temps)
`(%bind (,tmp) `(%bind ,(map first (filter second temps))
(%set! ,tmp ,value) ,@(filter-map second temps)
(,kind ,(second form) ,tmp))) (,op ,@(map first temps)))
`(,kind ,(second form) ,value))))] `(,op ,@new-args)))))
[(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox) #:variable (lambda (recurse op var)
(if (memq var (cdr form)) (if (eq? var variable) `(%unbox ,variable) var))))
(let ([tmp (gensym)])
`(%bind (,tmp)
(%set! ,tmp (%unbox ,var))
(,(first form) ,@(subst var tmp (cdr form)))))
form)]
[(quote) form]
[else (error "Unsimplified form:" form)])
(if (eq? form var)
`(%unbox ,form)
form)))
; form needs to be flattened (%bind ...) ; form needs to be flattened (%bind ...)
(define (is-shared-var? var form) (define (is-shared-var? var form)
@ -450,8 +484,8 @@
(set-after-first-use?))) (set-after-first-use?)))
(define (promote-shared-vars simple-lambda-form) (define (promote-shared-vars simple-lambda-form)
(define bind (second simple-lambda-form)) (define bind (fourth simple-lambda-form))
`(%lambda `(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
,(foldl (lambda (var frm) ,(foldl (lambda (var frm)
(if (is-shared-var? var frm) (if (is-shared-var? var frm)
(promote-to-box var frm) (promote-to-box var frm)
@ -459,24 +493,29 @@
bind bind
(second bind)))) (second bind))))
(define (promote-free-vars simple-lambda-form)
(define bind (fourth simple-lambda-form))
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
,(foldl promote-to-box bind (free-variables bind))))
; <= (%bind (var...) ; <= (%bind (var...)
; @before ; @before
; (%apply x y) ; (%apply x y)
; @after)) ; @after))
; => (%bind (var... k) ; => (%bind (var... k)
; @before ; @before
; (%set k (lambda _ @after)) ; (%set! k (lambda _ @after))
; (%tail-call x y k))) ; (%tail-call x y k)))
; <= (%bind (var...) ; <= (%bind (var...)
; @before ; @before
; (%set v (%apply x y)) ; (%set! v (%apply x y))
; @after)) ; @after))
; => (%bind (var... k) ; => (%bind (var... k)
; @before ; @before
; (%set k (lambda (x) ; (%set! k (lambda (x)
; (%set! v x) ; (%set! v x)
; @after)) ; @after))
; (%tail-call x y k))) ; (%tail-call x y k)))
; <= (%bind (var...) ; <= (%bind (var...)
@ -489,70 +528,69 @@
; (%set! k-argv (%cons k %nil)) ; (%set! k-argv (%cons k %nil))
; (%tail-call l k-argv k)) ; (%tail-call l k-argv k))
(define (transform-to-cps form) (define (transform-to-cps bind)
(define (cps-prepend subform after)
(cond
; (%set! v (%apply x y))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
(eq? (first (third subform)) '%apply))
(let ([k (gensym)]
[x (gensym)])
`((%bind (,k ,x)
(%set! ,k ,(simplify-form
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%tail-call ,(second (third subform))
,(third (third subform))
,k))))]
; (%apply x y)
[(and (pair? subform)
(eq? (first subform) '%apply))
(let ([k (gensym)])
`((%bind (,k)
(%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%tail-call ,(second subform)
,(third subform)
,k))))]
; (%set! v (%call/cc x))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
(eq? (first (third subform)) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)]
[x (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second (third subform))
,k-argv
,k))))]
; (%call/cc x)
[(and (pair? subform)
(eq? (first subform) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second subform)
,k-argv
,k))))]
[else (cons subform after)]))
(flatten-binds (flatten-binds
`(%bind ,(second form) `(%bind ,(second bind)
,@(foldr (lambda (subform after) ,@(foldr cps-prepend '() (cddr bind)))))
(cond
; (%set! v (%apply x y))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
(eq? (first (third subform)) '%apply))
(let ([k (gensym)]
[x (gensym)])
`((%bind (,k ,x)
(%set! ,k ,(simplify-form
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%tail-call ,(second (third subform))
,(third (third subform))
,k))))]
; (%apply x y)
[(and (pair? subform)
(eq? (first subform) '%apply))
(let ([k (gensym)])
`((%bind (,k)
(%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%tail-call ,(second subform)
,(third subform)
,k))))]
; (%set! v (%call/cc x))
[(and (pair? subform)
(eq? (first subform) '%set!)
(pair? (third subform))
(eq? (first (third subform)) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)]
[x (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda (,x . ,(gensym))
(%set! ,(second subform) ,x)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second (third subform))
,k-argv
,k))))]
; (%call/cc x)
[(and (pair? subform)
(eq? (first subform) '%call/cc))
(let ([k (gensym)]
[k-argv (gensym)])
`((%bind (,k ,k-argv)
(%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(%set! ,k-argv (%cons ,k %nil))
(%tail-call ,(second subform)
,k-argv
,k))))]
[else (cons subform after)]))
'()
(cddr form)))))
; (fn-expr arg-expr...) ; (fn-expr arg-expr...)
; => (let ([fn-var fn-expr] arg-var... argv) ; => (let ([fn-var fn-expr] arg-var... argv)
@ -577,77 +615,53 @@
(%apply ,fn-var ,argv)))) (%apply ,fn-var ,argv))))
(define (subst-var old-var new-var form) (define (subst-var old-var new-var form)
(define (recurse form) (map-form form
(subst-var old-var new-var form)) #:bind (lambda (recurse op vars . subforms)
(if (pair? form) `(%bind ,(subst old-var new-var vars) ,@(map recurse subforms)))
(case (car form) #:set (lambda (recurse op var value)
[(%bind) `(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
(if (memq old-var (second form)) #:variable (lambda (recurse op var)
form (if (eq? var old-var) new-var var))))
`(%bind ,(second form) ,@(map recurse (cddr form))))]
[(quote) form]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox)
`(,(first form) ,@(map recurse (cdr form)))]
[else (error "Unsimplified form:" form)])
(if (eq? form old-var)
new-var
form)))
(define (make-bindings-unique form)
(if (pair? form)
(case (car form)
[(%bind)
(let ([new-vars (map (lambda _ (gensym)) (second form))])
`(%bind ,new-vars
,@(map (lambda (frm)
(foldl (lambda (pair s)
(subst-var (car pair)
(cdr pair)
s))
frm
(map cons (second form) new-vars)))
(cddr form))))]
[(%if %tail-call %apply %lambda %set! %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
[else (error "Unsimplified form:" form)])
form))
(define (flatten-binds form) (define (flatten-binds form)
(if (pair? form) (define (make-bindings-unique bind)
(case (car form) (foldr (lambda (var bind)
[(%bind) (subst-var var (gensym) bind))
(let* ([bound-vars (second form)] bind
[subforms (append-map (lambda (new-form) (second bind)))
(if (and (pair? new-form) (eq? (car new-form) '%bind))
(begin (if (and (pair? form) (eq? (car form) '%bind))
(set! bound-vars (append bound-vars (second new-form))) (let* ([bound-vars (second form)]
(cddr new-form)) [subforms (append-map (lambda (subform)
(list new-form))) (if (and (pair? subform) (eq? (car subform) '%bind))
(map flatten-binds (cddr form)))]) (let ([unique-form (make-bindings-unique
`(%bind ,bound-vars ,@subforms))] (flatten-binds subform))])
[(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form] (set! bound-vars (append (second unique-form) bound-vars))
[else (error "Unsimplified form:" form)]) (cddr unique-form))
form)) (list subform)))
(cddr form))])
`(%bind ,bound-vars ,@subforms))
form))
(define (free-variables form [input? #t] [output? #t]) (define (free-variables form [input? #t] [output? #t])
(define (recurse form) (free-variables form input? output?)) (map-form form
(if (pair? form) #:bind (lambda (recurse op vars . subforms)
(case (car form) (remove-duplicates (remove* vars (append-map recurse subforms))))
[(%bind) #:lambda (lambda (recurse op g-vars i-vars bind)
(remove* (second form) (recurse bind))
(remove-duplicates (append-map recurse (cddr form))))] #:set (lambda (recurse op var value)
[(%set!) (if output? (let ([value-free (recurse value)])
(cons (second form) (recurse (third form))) (if output?
(recurse (third form)))] (cons var value-free)
[(quote) '()] value-free)))
[(%if %tail-call %apply %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox) #:primitive (lambda (recurse op . simple-values)
(remove-duplicates (append-map recurse (cdr form)))] (remove-duplicates (append-map recurse simple-values)))
[else #:simple (lambda (recurse kind form)
(error "Unsimplified form:" form)]) (if (and input?
(if (and input? (symbol? form)
(symbol? form) (not (memq form '(%nil %undef %self %argv %ctx %k))))
(not (memq form '(%nil %undef %self %argv %ctx %k)))) (list form)
(list form) '()))))
'())))
(define (free-input-variables form) (define (free-input-variables form)
(free-variables form #t #f)) (free-variables form #t #f))
@ -657,51 +671,99 @@
; Don't bind variables which aren't referenced. ; Don't bind variables which aren't referenced.
(define (reduce-variables form) (define (reduce-variables form)
(if (pair? form) (map-form form
(case (car form) #:bind (lambda (recurse op vars . subforms)
[(%bind) (let ([ref-vars (remove-duplicates (append-map free-variables subforms))])
(let ([ref-vars (remove-duplicates (append-map free-variables (cddr form)))]) `(%bind ,(filter (lambda (x) (memq x ref-vars)) vars)
`(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form)) ,@(map recurse subforms))))))
,@(map reduce-variables (cddr form))))]
[(quote) form]
[(%if %tail-call %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox)
`(,(first form) ,@(map reduce-variables (cdr form)))]
[else (error "Unsimplified form:" form)])
form))
; 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)
(if (pair? form) (map-form form
(case (car form) #:bind (lambda (recurse op vars . subforms)
[(%bind) (define (prepend-if-used subform after)
(let ([bound-vars (second form)])
`(%bind ,bound-vars
,@(foldr (lambda (subform after)
(if (and (pair? subform) (if (and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '%set!)
(memq (second subform) bound-vars) (memq (second subform) vars)
(not (memq (second subform) (not (memq (second subform)
(append-map free-input-variables after)))) (append-map free-input-variables after))))
after after
(cons subform after))) (cons subform after)))
'() `(%bind ,vars
(map reduce-set! (cddr form)))))] ,@(foldr prepend-if-used '() (map recurse subforms))))))
[(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
[(%set! %lambda) `(,(first form) ,@(map reduce-set! (cdr form)))]
[else (error "Unsimplified form:" form)])
form))
(define (simplify-toplevel-lambda form) (define (simplify-toplevel-lambda form)
(promote-shared-vars (promote-free-vars
(narrow-binds (promote-shared-vars
(simplify-lambda form)))) (narrow-binds
(simplify-lambda form)))))
(define (optimize-simplified-lambda form) (define (optimize-simplified-lambda form)
(reduce-variables (reduce-variables
(reduce-set! (reduce-set!
form))) form)))
(pretty-print (optimize-simplified-lambda (simplify-toplevel-lambda `(lambda () ,(read))))) (define frame-vars
;(pretty-print (simplify-toplevel-lambda `(lambda () ,(read)))) (for/list ([i (in-range 0 120)])
(string->uninterned-symbol (string-append "%f" (number->string i)))))
(define instance-vars
(for/list ([i (in-range 0 64)])
(string->uninterned-symbol (string-append "%i" (number->string i)))))
(define global-vars
(for/list ([i (in-range 1 64)])
(string->uninterned-symbol (string-append "%g" (number->string i)))))
(define (frame-var? var) (and (memq var frame-vars) #t))
(define (instance-var? var) (and (memq var instance-vars) #t))
(define (frame/instance-var? var) (or (frame-var? var) (instance-var? var)))
(define (global-var? var) (and (memq var global-vars) #t))
(define (special-var? var)
(or (and (memq var '(%nil %self %argv %ctx %k)) #t)
(frame/instance-var? var)
(global-var? var)))
(define (map-variables lambda/template-form)
(let ([bind (fourth lambda/template-form)]
[g-vars '()]
[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)))
(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)))
#:literal (lambda (recurse kind form)
(if (eq? form '%nil) form (add-g-var form)))))
`(,(if (pair? i-vars) '%template '%lambda) ,g-vars ,i-vars
,bind)))
((compose
pretty-print
map-variables
optimize-simplified-lambda
simplify-toplevel-lambda)
`(lambda () ,(read)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab: