Implement register allocation.
All that remains is to convert the result to bytecode & format as rosella source code.
This commit is contained in:
parent
c3e46525db
commit
35059dfebf
626
compiler.ss
626
compiler.ss
|
|
@ -39,7 +39,8 @@
|
|||
[(call/cc) '%call/cc]
|
||||
)
|
||||
(cdr form))]
|
||||
[(%bind %if %set! %lambda quote
|
||||
[(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)
|
||||
|
|
@ -47,56 +48,99 @@
|
|||
[else (simplify-funcall form)])
|
||||
(if (eq? form '()) '%nil form)))
|
||||
|
||||
(define (form-sets? form var [call-may-set? #t])
|
||||
(define (recurse simple-form)
|
||||
(if (pair? simple-form)
|
||||
(case (car simple-form)
|
||||
[(%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 (simple-value? form)
|
||||
(or (not (pair? form))
|
||||
(eq? (first form) 'quote)
|
||||
(eq? (first form) '%template)))
|
||||
|
||||
(define (form-uses? form var [call-may-use? #t] [descend? #t])
|
||||
(define (recurse simple-form)
|
||||
(if (pair? simple-form)
|
||||
(case (car simple-form)
|
||||
[(%bind) (and (not (memq var (second simple-form)))
|
||||
(ormap recurse (cddr simple-form)))]
|
||||
[(%set!) (recurse (third simple-form))]
|
||||
[(%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 (map-form form
|
||||
#:bind [bind-fn (lambda (recurse op vars . subforms)
|
||||
`(,op ,vars ,@(map recurse subforms)))]
|
||||
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
|
||||
`(,op ,g-vars ,i-vars ,(recurse bind)))]
|
||||
#:set [set-fn (lambda (recurse op var value)
|
||||
`(,op ,var ,(recurse value)))]
|
||||
|
||||
(define (form-captures? form var [input? #t] [output? #t])
|
||||
(define (recurse simple-form)
|
||||
(if (pair? simple-form)
|
||||
(case (car simple-form)
|
||||
[(%bind) (and (not (memq var (second simple-form)))
|
||||
(ormap recurse (cddr simple-form)))]
|
||||
[(%set!) (recurse (third simple-form))]
|
||||
[(%tail-call %apply %call/cc %if quote
|
||||
%make-box %set-box! %unbox
|
||||
%cons %set-car! %car %set-cdr! %cdr)
|
||||
#f]
|
||||
[(%lambda) (and (memq var (free-variables simple-form input? output?)) #t)]
|
||||
[else (error "Invalid simple form:" simple-form)])
|
||||
#f))
|
||||
(recurse (simplify-form form)))
|
||||
#:primitive [primitive-fn (lambda (recurse op . simple-values)
|
||||
`(,op ,@(map 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) form)]
|
||||
#:variable [variable-fn simple-fn]
|
||||
#:literal [literal-fn simple-fn]
|
||||
|
||||
#:other [other-fn (lambda (recurse . form)
|
||||
(error "Unsimplified form:" form))])
|
||||
(define (recurse subform)
|
||||
(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)
|
||||
(form-captures? form var #t #f))
|
||||
|
|
@ -126,15 +170,15 @@
|
|||
|
||||
(define (simplify-primitive new-id value-forms)
|
||||
(define bindings (map (lambda (vf)
|
||||
(if (pair? vf)
|
||||
(list (gensym) vf)
|
||||
(list vf 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 temp-bindings (filter (lambda (x) (not (eq? (first x) (second x))))
|
||||
bindings))
|
||||
(simplify-form
|
||||
`(let ,(map first temp-bindings)
|
||||
,@(map (lambda (x) `(set! ,(first x) ,(second x))) temp-bindings)
|
||||
`(let ,(map first (filter second bindings))
|
||||
,@(filter-map second bindings)
|
||||
(,new-id ,@(map first bindings)))))
|
||||
|
||||
; (let ([var expr]...) bodyexpr...) ; first eval exprs, then assign bindings in parallel
|
||||
|
|
@ -153,12 +197,11 @@
|
|||
`(%bind () ,@(map simplify-form bodyexprs))]
|
||||
[(not (pair? (cdr bindings)))
|
||||
(let ([binding (first bindings)])
|
||||
(make-bindings-unique
|
||||
`(%bind (,(if (pair? binding) (first binding) binding))
|
||||
,@(if (pair? binding) `(,(simplify-set! `(set! ,(first binding)
|
||||
,(second binding))))
|
||||
'())
|
||||
,@(map simplify-form bodyexprs))))]
|
||||
`(%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)
|
||||
|
|
@ -171,10 +214,9 @@
|
|||
bindings)])
|
||||
`(%bind ,(map first temp-bindings)
|
||||
,@(map second temp-bindings)
|
||||
,(make-bindings-unique
|
||||
`(%bind ,vars
|
||||
,@(map third temp-bindings)
|
||||
,@(map simplify-form bodyexprs)))))])))
|
||||
(%bind ,vars
|
||||
,@(map third temp-bindings)
|
||||
,@(map simplify-form bodyexprs))))])))
|
||||
|
||||
; (let* ...) ; eval exprs & bind variables serially
|
||||
; => (let ([var-0 expr-0])
|
||||
|
|
@ -329,7 +371,7 @@
|
|||
,inner))
|
||||
(define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
|
||||
`(begin ,@bodyexprs)))
|
||||
`(%lambda
|
||||
`(%lambda () ()
|
||||
,((compose transform-to-cps
|
||||
(lambda (x) (add-tail-call k rval x))
|
||||
flatten-binds)
|
||||
|
|
@ -344,7 +386,7 @@
|
|||
requireds))))))))
|
||||
|
||||
(define (narrow-binds simple-lambda-form)
|
||||
(define bind (second simple-lambda-form))
|
||||
(define bind (fourth simple-lambda-form))
|
||||
(define (at-top-level? var)
|
||||
(or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind))
|
||||
(ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind))))
|
||||
|
|
@ -362,7 +404,7 @@
|
|||
(filter-not captured-twice?
|
||||
(filter-not at-top-level?
|
||||
(second bind))))
|
||||
`(%lambda
|
||||
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
|
||||
(%bind ,(remove* extra-binds (second bind))
|
||||
,@(map (lambda (subform)
|
||||
(foldl (lambda (var subform)
|
||||
|
|
@ -372,9 +414,11 @@
|
|||
(eq? (first (third subform)) '%lambda))
|
||||
(let* ([dest (second subform)]
|
||||
[value (third subform)]
|
||||
[bind (second value)])
|
||||
[g-vars (second value)]
|
||||
[i-vars (third value)]
|
||||
[bind (fourth value)])
|
||||
`(%set! ,dest ,(narrow-binds
|
||||
`(%lambda
|
||||
`(%lambda ,g-vars ,i-vars
|
||||
,(if (form-captures? value var)
|
||||
`(%bind (,@(second bind) ,var)
|
||||
,@(cddr bind))
|
||||
|
|
@ -384,51 +428,41 @@
|
|||
extra-binds))
|
||||
(cddr bind)))))
|
||||
|
||||
(define (promote-to-box var form)
|
||||
(define (recurse subform) (promote-to-box var subform))
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(flatten-binds
|
||||
`(%bind ,(second form)
|
||||
,@(if (memq var (second form))
|
||||
`((%set! ,var (%make-box %undef)))
|
||||
'())
|
||||
,@(map recurse (cddr form))))]
|
||||
[(%lambda)
|
||||
`(%lambda ,(recurse (second form)))]
|
||||
[(%set!)
|
||||
(let ([value (recurse (third form))]
|
||||
[kind (if (eq? (second form) var) '%set-box! '%set!)])
|
||||
; If value is (%bind), could only come from clause below.
|
||||
(if (and (pair? value) (eq? (first value) '%bind))
|
||||
(if (and (pair? (fourth value)) (not (eq? kind '%set!)))
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,@(second value) ,tmp)
|
||||
,(third value)
|
||||
(%set! ,tmp ,(fourth value))
|
||||
(,kind ,(second form) ,tmp)))
|
||||
`(%bind ,(second value)
|
||||
,(third value)
|
||||
(,kind ,(second form) ,(fourth value))))
|
||||
(if (and (pair? value) (not (eq? kind '%set!)))
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,tmp)
|
||||
(%set! ,tmp ,value)
|
||||
(,kind ,(second form) ,tmp)))
|
||||
`(,kind ,(second form) ,value))))]
|
||||
[(%if %tail-call %cons %car %cdr %call/cc %make-box %set-box! %unbox)
|
||||
(if (memq var (cdr form))
|
||||
(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)))
|
||||
(define (promote-to-box variable form)
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(flatten-binds
|
||||
`(%bind ,(subst variable variable vars)
|
||||
,@(if (memq variable vars)
|
||||
`((%set! ,variable (%make-box %undef)))
|
||||
'())
|
||||
,@(map recurse subforms))))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([new-value (recurse value)])
|
||||
(if (eq? var variable)
|
||||
(if (simple-value? new-value)
|
||||
`(%set-box! ,variable ,new-value)
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,tmp)
|
||||
,(simplify-set! `(set! ,tmp ,new-value))
|
||||
(%set-box! ,variable ,tmp))))
|
||||
(simplify-set! `(set! ,var ,new-value)))))
|
||||
#:primitive (lambda (recurse op . simple-values)
|
||||
(let ([new-args (map recurse simple-values)])
|
||||
;; if any new-arg is not simple, must bind to a temp first
|
||||
(let ([temps (map (lambda (x)
|
||||
(if (simple-value? x)
|
||||
(list x #f)
|
||||
(let ([tmp (gensym)])
|
||||
(list tmp `(%set! ,tmp ,x)))))
|
||||
new-args)])
|
||||
(if (ormap second temps)
|
||||
`(%bind ,(map first (filter second temps))
|
||||
,@(filter-map second temps)
|
||||
(,op ,@(map first temps)))
|
||||
`(,op ,@new-args)))))
|
||||
#:variable (lambda (recurse op var)
|
||||
(if (eq? var variable) `(%unbox ,variable) var))))
|
||||
|
||||
; form needs to be flattened (%bind ...)
|
||||
(define (is-shared-var? var form)
|
||||
|
|
@ -450,8 +484,8 @@
|
|||
(set-after-first-use?)))
|
||||
|
||||
(define (promote-shared-vars simple-lambda-form)
|
||||
(define bind (second simple-lambda-form))
|
||||
`(%lambda
|
||||
(define bind (fourth simple-lambda-form))
|
||||
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
|
||||
,(foldl (lambda (var frm)
|
||||
(if (is-shared-var? var frm)
|
||||
(promote-to-box var frm)
|
||||
|
|
@ -459,24 +493,29 @@
|
|||
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...)
|
||||
; @before
|
||||
; (%apply x y)
|
||||
; @after))
|
||||
; => (%bind (var... k)
|
||||
; @before
|
||||
; (%set k (lambda _ @after))
|
||||
; (%set! k (lambda _ @after))
|
||||
; (%tail-call x y k)))
|
||||
|
||||
; <= (%bind (var...)
|
||||
; @before
|
||||
; (%set v (%apply x y))
|
||||
; (%set! v (%apply x y))
|
||||
; @after))
|
||||
; => (%bind (var... k)
|
||||
; @before
|
||||
; (%set k (lambda (x)
|
||||
; (%set! v x)
|
||||
; @after))
|
||||
; (%set! k (lambda (x)
|
||||
; (%set! v x)
|
||||
; @after))
|
||||
; (%tail-call x y k)))
|
||||
|
||||
; <= (%bind (var...)
|
||||
|
|
@ -489,70 +528,69 @@
|
|||
; (%set! k-argv (%cons k %nil))
|
||||
; (%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
|
||||
`(%bind ,(second form)
|
||||
,@(foldr (lambda (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)]))
|
||||
'()
|
||||
(cddr form)))))
|
||||
`(%bind ,(second bind)
|
||||
,@(foldr cps-prepend '() (cddr bind)))))
|
||||
|
||||
; (fn-expr arg-expr...)
|
||||
; => (let ([fn-var fn-expr] arg-var... argv)
|
||||
|
|
@ -577,77 +615,53 @@
|
|||
(%apply ,fn-var ,argv))))
|
||||
|
||||
(define (subst-var old-var new-var form)
|
||||
(define (recurse form)
|
||||
(subst-var old-var new-var form))
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(if (memq old-var (second form))
|
||||
form
|
||||
`(%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))
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
`(%bind ,(subst old-var new-var vars) ,@(map recurse subforms)))
|
||||
#:set (lambda (recurse op var value)
|
||||
`(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
|
||||
#:variable (lambda (recurse op var)
|
||||
(if (eq? var old-var) new-var var))))
|
||||
|
||||
(define (flatten-binds form)
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(let* ([bound-vars (second form)]
|
||||
[subforms (append-map (lambda (new-form)
|
||||
(if (and (pair? new-form) (eq? (car new-form) '%bind))
|
||||
(begin
|
||||
(set! bound-vars (append bound-vars (second new-form)))
|
||||
(cddr new-form))
|
||||
(list new-form)))
|
||||
(map flatten-binds (cddr form)))])
|
||||
`(%bind ,bound-vars ,@subforms))]
|
||||
[(%if %tail-call %apply %set! %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox quote) form]
|
||||
[else (error "Unsimplified form:" form)])
|
||||
form))
|
||||
(define (make-bindings-unique bind)
|
||||
(foldr (lambda (var bind)
|
||||
(subst-var var (gensym) bind))
|
||||
bind
|
||||
(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))
|
||||
|
||||
(define (free-variables form [input? #t] [output? #t])
|
||||
(define (recurse form) (free-variables form input? output?))
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(remove* (second form)
|
||||
(remove-duplicates (append-map recurse (cddr form))))]
|
||||
[(%set!) (if output?
|
||||
(cons (second form) (recurse (third form)))
|
||||
(recurse (third form)))]
|
||||
[(quote) '()]
|
||||
[(%if %tail-call %apply %lambda %cons %car %cdr %call/cc %make-box %set-box! %unbox)
|
||||
(remove-duplicates (append-map recurse (cdr form)))]
|
||||
[else
|
||||
(error "Unsimplified form:" form)])
|
||||
(if (and input?
|
||||
(symbol? form)
|
||||
(not (memq form '(%nil %undef %self %argv %ctx %k))))
|
||||
(list form)
|
||||
'())))
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(remove-duplicates (remove* vars (append-map recurse subforms))))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
(recurse bind))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([value-free (recurse value)])
|
||||
(if output?
|
||||
(cons var value-free)
|
||||
value-free)))
|
||||
#:primitive (lambda (recurse op . simple-values)
|
||||
(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))))
|
||||
(list form)
|
||||
'()))))
|
||||
|
||||
(define (free-input-variables form)
|
||||
(free-variables form #t #f))
|
||||
|
|
@ -657,51 +671,99 @@
|
|||
|
||||
; Don't bind variables which aren't referenced.
|
||||
(define (reduce-variables form)
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(let ([ref-vars (remove-duplicates (append-map free-variables (cddr form)))])
|
||||
`(%bind ,(filter (lambda (x) (memq x ref-vars)) (second form))
|
||||
,@(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))
|
||||
(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))))))
|
||||
|
||||
; Don't set variables which won't be accessed later.
|
||||
(define (reduce-set! form)
|
||||
(if (pair? form)
|
||||
(case (car form)
|
||||
[(%bind)
|
||||
(let ([bound-vars (second form)])
|
||||
`(%bind ,bound-vars
|
||||
,@(foldr (lambda (subform after)
|
||||
(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) bound-vars)
|
||||
(memq (second subform) vars)
|
||||
(not (memq (second subform)
|
||||
(append-map free-input-variables after))))
|
||||
after
|
||||
(cons subform after)))
|
||||
'()
|
||||
(map reduce-set! (cddr form)))))]
|
||||
[(%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))
|
||||
`(%bind ,vars
|
||||
,@(foldr prepend-if-used '() (map recurse subforms))))))
|
||||
|
||||
(define (simplify-toplevel-lambda form)
|
||||
(promote-shared-vars
|
||||
(narrow-binds
|
||||
(simplify-lambda form))))
|
||||
(promote-free-vars
|
||||
(promote-shared-vars
|
||||
(narrow-binds
|
||||
(simplify-lambda form)))))
|
||||
|
||||
(define (optimize-simplified-lambda form)
|
||||
(reduce-variables
|
||||
(reduce-set!
|
||||
form)))
|
||||
|
||||
(pretty-print (optimize-simplified-lambda (simplify-toplevel-lambda `(lambda () ,(read)))))
|
||||
;(pretty-print (simplify-toplevel-lambda `(lambda () ,(read))))
|
||||
(define frame-vars
|
||||
(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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue