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

Lots of misc. cleanup, and a few bug fixes. 

* Remap all instance variables in one pass, to avoid an insidious bug [1].
* Fix another bug by merging promote-shared-variables and narrow-binds [2].
* Don't assume different variable means different value in propogate-set!.
* Add support for (apply), (value-list) and (call-with-values) forms.
* Add support for including files (as if directly substituted) in reader.
* Use scheme/match library to simplify form pattern-matching.
* Refactor (map-form) and (search-form) using a more basic (traverse-form),
  which just recurses over the form and returns void by default, and a
  new utility function (curry-keywords) to provide default keyword arguments.

[1] Was renaming e.g. %f0 to %i0, then %i0 to %i1, which eliminates the
distinction between %f0 and %i0. Solution is to construct a map from old
names to new names, then traverse the form and change every old variable
to its new equivalent in the map exactly once.

[2] Some variables were not being promoted to boxes, as promotions only occur
at the top-level, when constructing each lambda, and narrow-binds could push
the unpromoted variables down into a subordinate lambda form first. Solution
was to promote variables immediately after narrowing bindings, including the
recursive calls which exist after pushing variables into nested scopes.
This commit is contained in:
Jesse D. McDonald 2010-05-02 04:13:38 -05:00
parent b3fd7bf6fc
commit cbcea20701
8 changed files with 628 additions and 601 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
compiler.scm
View File

@ -1,10 +1,15 @@
#! /usr/bin/mzscheme #! /usr/bin/mzscheme
#lang scheme/base #lang scheme/base
(require scheme/pretty)
(require (file "libcompiler/reader.scm")) (require (file "libcompiler/reader.scm"))
(require (file "libcompiler/compiler.scm")) (require (file "libcompiler/compiler.scm"))
(require (file "libcompiler/writer.scm")) (require (file "libcompiler/writer.scm"))
(optimize? #t)
;(pretty-print (reduce-function (read-module)))
(write-rla-value (compile-function (read-module))) (write-rla-value (compile-function (read-module)))
(write-char #\Newline) (write-char #\Newline)

6
libcompiler/compiler.scm
View File

@ -5,7 +5,9 @@
(require (file "mapper.scm")) (require (file "mapper.scm"))
(provide reduce-function (provide reduce-function
compile-function) compile-function
optimize?
box-free-variables?)
(define optimize? (make-parameter #t)) (define optimize? (make-parameter #t))
(define box-free-variables? (make-parameter #f)) (define box-free-variables? (make-parameter #f))
@ -16,7 +18,7 @@
(define (reduce-function lambda-form) (define (reduce-function lambda-form)
((compose (if (optimize?) optimize-function values) ((compose (if (optimize?) optimize-function values)
(if (box-free-variables?) promote-free-variables values) (if (box-free-variables?) promote-free-variables values)
simplify-function) simplify-lambda)
lambda-form)) lambda-form))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

12
libcompiler/mapper.scm
View File

@ -24,10 +24,12 @@
(set! g-vars (append g-vars (list value))) (set! g-vars (append g-vars (list value)))
g-var)))) g-var))))
(for ([free-var (in-list (filter frame/instance-variable? (free-variables bind)))] (let* ([free-vars (filter frame/instance-variable? (free-variables bind))]
[inst-var (in-list instance-variables)]) [var-map (for/list ([free-var (in-list free-vars)]
(set! i-vars (append i-vars (list free-var))) [inst-var (in-list instance-variables)])
(set! bind (subst-var free-var inst-var bind))) (set! i-vars (append i-vars (list free-var)))
(list free-var inst-var))])
(set! bind (subst-var* var-map bind)))
(for ([bound-var (in-list (second bind))] (for ([bound-var (in-list (second bind))]
[frame-var (in-list frame-variables)]) [frame-var (in-list frame-variables)])
@ -44,3 +46,5 @@
`(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars `(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars
,bind))) ,bind)))
; vim:set sw=2 expandtab:

89
libcompiler/optimizer.scm
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/list) (require scheme/list)
(require scheme/match)
(require (file "utilities.scm")) (require (file "utilities.scm"))
(provide reduce-variables (provide reduce-variables
@ -31,17 +32,13 @@
(if (and (pair? subform) (if (and (pair? subform)
(eq? (first subform) '%set!) (eq? (first subform) '%set!)
(or (memq (second subform) vars) (or (memq (second subform) vars)
; Top-level (free) variables are presumed to be (error "Setting unbound (constant) variable:" subform))
; constant. The alternative was to assume them
; to be boxes, which has its own complications.
(error "Setting unbound var:" subform))
(not (value-used? (second subform) after))) (not (value-used? (second subform) 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))
(map-form form #:bind bind-fn)))
(define (propogate-value variable value invalidates? forms) (define (propogate-value variable value invalidates? forms)
(if (null? forms) (if (null? forms)
@ -84,53 +81,45 @@
; Known values are: ; Known values are:
; literals, always ; literals, always
; var, until (%set! var ...) ; var, until (%set! var ...)
; (%unbox var), until (%set-box! var ...) or (%set! var) ; (%unbox var), until (%set-box! ...) or (%set! var)
; (%car var), until (%set-car! var) or (%set! var) ; (%car var), until (%set-car! ...) or (%set! var)
; (%cdr var), until (%set-cdr! var) or (%set! var) ; (%cdr var), until (%set-cdr! ...) or (%set! var)
(define (propogate-set! form) (define (propogate-set! form)
(define (bind-fn recurse op vars . subforms) (define (bind-fn recurse op vars . subforms)
(define (prepend subform after) (define (prepend subform after)
(if (eq? (first subform) '%set!) (cons
(let ([var (second subform)] subform
[value (third subform)]) (match subform
(cons [`(%set! ,var ,(? simple-value? value))
subform (propogate-simple-value var value
(cond (lambda (form)
[(simple-value? value) (and (eq? (first form) '%set!)
(propogate-simple-value var value (eq? (second form) value)))
(lambda (form) after)]
(and (eq? (first form) '%set!) [`(%set! ,var ,(and value `(%unbox ,box-var)))
(eq? (second form) value))) (propogate-value var value
after)] (lambda (form)
[(eq? (first value) '%unbox) (or (and (eq? (first form) '%set!)
(let ([box-var (second value)]) (eq? (second form) box-var))
(propogate-value var value (eq? (first form) '%set-box!)))
(lambda (form) after)]
(or (and (eq? (first form) '%set!) [`(%set! ,var ,(and value `(%car ,pair-var)))
(eq? (second form) box-var)) (propogate-value var value
(and (eq? (first form) '%set-box!) (lambda (form)
(eq? (second form) box-var)))) (or (and (eq? (first form) '%set!)
after))] (eq? (second form) pair-var))
[(eq? (first value) '%car) (eq? (first form) '%set-car!)))
(let ([pair-var (second value)]) after)]
(propogate-value var value [`(%set! ,var ,(and value `(%cdr ,pair-var)))
(lambda (form) (propogate-value var value
(or (and (eq? (first form) '%set!) (lambda (form)
(eq? (second form) pair-var)) (or (and (eq? (first form) '%set!)
(and (eq? (first form) '%set-car!) (eq? (second form) pair-var))
(eq? (second form) pair-var)))) (eq? (first form) '%set-cdr!)))
after))] after)]
[(eq? (first value) '%cdr) [_ after])))
(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 `(%bind ,vars
,@(foldr prepend '() (map recurse subforms)))) ,@(foldr prepend '() (map recurse subforms))))
(map-form form #:bind bind-fn)) (map-form form #:bind bind-fn))
; vim:set sw=2 expandtab:

64
libcompiler/reader.scm
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/list) (require scheme/list)
(require scheme/path)
(provide read-module) (provide read-module)
@ -8,24 +9,35 @@
`(lambda *argv* `(lambda *argv*
,@(let iter ([forms (read-forms port)] ,@(let iter ([forms (read-forms port)]
[bindings '()]) [bindings '()])
(cond (match forms
[(null? forms) (if (null? bindings) ['()
'() (if (null? bindings)
`(letrec ,bindings))] '()
[(simple-define-form? (first forms)) `((letrec ,(reverse bindings))))]
(iter (cdr forms) (cons (cdr (first forms)) [`((define ,var ,expr) . ,rst)
bindings))] (iter rst (cons (list var expr) bindings))]
[(lambda-define-form? (first forms)) [`((define (,var . ,arglist) . ,body) . ,rst)
(iter (cdr forms) (cons `(,(first (second (first forms))) (iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
(lambda ,(cdr (second (first forms))) [`((define . ,_) . ,_)
,@(cddr (first forms)))) (error "Unrecognized define-form:" (first forms))]
bindings))] [`((begin . ,body) . ,rst)
[(begin-form? (first forms)) (iter (append body rst) bindings)]
(iter (append (cdr (first forms)) (cdr forms)) bindings)] [`((load ,(? string? pathname)) . ,rst)
[(null? bindings) (let ([complete-path (path->complete-path pathname)]
(cons (first forms) (iter (cdr forms) '()))] [directory (path-only complete-path)])
[else (iter (append (with-input-from-file complete-path
`((letrec ,bindings ,@(iter forms '())))])))) (lambda ()
(parameterize ([current-directory directory])
(read-forms))))
rst)
bindings))]
[`((load . ,_) . ,rst)
(error "Unrecognized load-form:" (first forms))]
[(,form . ,rst)
(if (null? bindings)
(cons form (iter rst '()))
`((letrec ,(reverse bindings)
,@(cons form (iter rst '())))))]))))
(define (read-forms [port (current-input-port)]) (define (read-forms [port (current-input-port)])
(reverse (let iter ([form (read port)] (reverse (let iter ([form (read port)]
@ -34,20 +46,4 @@
forms forms
(iter (read port) (cons form forms)))))) (iter (read port) (cons form forms))))))
(define (simple-define-form? form)
(and (pair? form)
(eq? (first form) 'define)
(symbol? (second form))
(null? (cdddr form))))
(define (lambda-define-form? form)
(and (pair? form)
(eq? (first form) 'define)
(pair? (second form))
(symbol? (first (second form)))))
(define (begin-form? form)
(and (pair? form)
(eq? (first form) 'begin)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

656
libcompiler/simplifier.scm
View File

@ -1,87 +1,114 @@
#lang scheme/base #lang scheme/base
(require scheme/list) (require scheme/list)
(require scheme/match)
(require (file "utilities.scm")) (require (file "utilities.scm"))
(require (file "primitives.scm")) (require (file "primitives.scm"))
(provide simplify-function (provide simplify-lambda
promote-free-variables) promote-free-variables)
(define (simplify-function lambda-form)
((compose promote-shared-variables
simplify-lambda)
lambda-form))
(define (simplify-form form) (define (simplify-form form)
(define (same-form recurse . form) form) (define (same-form recurse . form) form)
(define (simplify-complex-form 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))))]
[(fix>) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix< ,b ,a))))]
[(fix<=) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix>= ,b ,a))))]
[(value-list) (simplify-value-list form)]
[(values) (simplify-primitive '%values (cdr form))]
[(apply) (simplify-apply (second form) (cddr form))]
[(call/cc) (simplify-primitive '%call/cc (cdr form))]
[(call-with-values)
(simplify-form
`(apply ,(third form)
(value-list (,(second form)))))]
[else
(let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
all-primitives)])
(if primitive
(simplify-primitive (first (first primitive))
(cdr form))
(simplify-apply (first form) (append (cdr form) '(%nil)))))]))
(map-form form (map-form form
#:bind same-form #:bind same-form
#:lambda same-form #:lambda same-form
#:set same-form #:set same-form
#:primitive same-form #:value-list same-form
#:simple (lambda (recurse kind form) form) #:primitive same-form
#:literal (lambda (recurse kind form) #:simple (lambda (recurse kind form) form)
(if (and (pair? form) #:literal (lambda (recurse kind form)
(eq? (first form) 'quote) (if (equal? form '(quote ())) '%nil form))
(eq? (second form) '())) #:other simplify-complex-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))))]
[(fix>) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix< ,b ,a))))]
[(fix<=) (simplify-form
(let ([a (gensym)] [b (gensym)])
`(let ([,a ,(second form)]
[,b ,(third form)])
(fix>= ,b ,a))))]
[(values) (simplify-primitive '%values (cdr form))]
[(call/cc) (simplify-primitive '%call/cc (cdr form))]
[else
(let ([primitive (memf (lambda (x) (eq? (third x) (first form)))
all-primitives)])
(if primitive
(simplify-primitive (first (first primitive))
(cdr form))
(simplify-funcall form)))]))))
(define (simplify-set! form) (define (simplify-set! form)
(let ([variable (second form)] (let ([variable (second form)]
[value-form (simplify-form (third form))]) [value-form (simplify-form (third form))])
(if (and (pair? value-form) (eq? (first value-form) '%bind)) (match value-form
(if (memq variable (second value-form)) [`(%bind ,bound-vars . ,subforms)
(let ([tmp (gensym)]) (if (memq variable bound-vars)
`(%bind (,tmp) (let ([tmp (gensym)])
; guaranteed not to cause unbounded recursion: tmp is unique `(%bind (,tmp)
,(simplify-set! `(set! ,tmp ,value-form)) ; guaranteed not to cause unbounded recursion: tmp is unique
(%set! ,variable ,tmp))) ,(simplify-set! `(set! ,tmp ,value-form))
`(%bind ,(second value-form) (%set! ,variable ,tmp)))
,@(foldr (lambda (subform after) `(%bind ,bound-vars
(cond ,@(foldr (lambda (subform after)
[(pair? after) (cons subform after)] (if (pair? after)
[(and (pair? subform) (eq? (first subform) '%values)) (cons subform after)
; Requires at least one value; ignores extras. (list (simplify-set! `(set! ,variable ,subform)))))
(if (null? (cdr subform)) '()
(error "Attempted to set variable to void in:" form) subforms)))]
`((%set! ,variable ,(second subform))))] [`(%values ,first-val . ,other-vals)
[(value-form? subform) `(%set! ,variable ,first-val)]
(list (simplify-set! `(set! ,variable ,subform)))] [`(%values)
[else (error "Attempted to set variable to void in:" form)])) (error "Attempted to set variable to void in:" form)]
'() [(? value-form?)
(cddr value-form)))) `(%set! ,variable ,value-form)]
`(%set! ,variable ,value-form)))) [else
(error "Attempted to set variable to void in:" form)])))
(define (simplify-value-list form)
(let ([values-form (simplify-form (second form))])
(match values-form
[`(%bind ,bound-vars . ,subforms)
`(%bind ,bound-vars
,@(foldr (lambda (subform after)
(if (pair? after)
(cons subform after)
(list (simplify-value-list `(value-list ,subform)))))
'()
subforms))]
[`(%values . ,simple-vals)
; (%value-list (%values ...)) => (list ...)
(let ([tmp (gensym)])
`(%bind (,tmp)
(%set! ,tmp %nil)
,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp))))
(reverse simple-vals))
,tmp))]
[(or `(%apply _ _)
`(%call/cc _))
`(%value-list ,values-form)]
[(? value-form?)
(simplify-value-list `(value-list (values ,values-form)))]
[_ '%nil])))
(define (simplify-primitive simple-op value-forms) (define (simplify-primitive simple-op value-forms)
(define (value->binding value-form) (define (value->binding value-form)
@ -207,195 +234,263 @@
; (if (eq? argv-temp %nil) ; (if (eq? argv-temp %nil)
; (set! optional-1 default-expr-1) ; (set! optional-1 default-expr-1)
; (set! optional-1 (car argv-temp))) ; (set! optional-1 (car argv-temp)))
; ; TODO: Handle keyword arguments here...
; (set! argv-temp (cdr argv-temp)) ; (set! argv-temp (cdr argv-temp))
; (... ; (...
; (let ([rest argv-temp]) ; (let ([rest argv-temp])
; bodyexpr...)...)))...))) ; bodyexpr...)...)))...)))
(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)))))
#:value-list (lambda (recurse op values-form)
`(,op ,(recurse values-form)))
#: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))))
(define (is-shared-var? var forms)
(define captured-input? (ormap (lambda (f) (form-captures-input? f var)) forms))
(define captured-output? (ormap (lambda (f) (form-captures-output? f var)) forms))
(define (set-after-first-capture?)
(let/cc return
(foldr (lambda (form set-after?)
(if (or set-after? (form-sets? form var captured-output?))
(if (form-captures-input? form var)
(return #t)
#t)
#f))
#f
forms)
#f))
(or captured-output?
(and captured-input?
(set-after-first-capture?))))
(define (promote-shared-variables nested-bind)
(define flat-bind (flatten-binds nested-bind))
(foldl (lambda (var frm)
(if (is-shared-var? var (cddr frm))
(promote-to-box var frm)
frm))
flat-bind
(second flat-bind)))
(define (promote-free-variables form)
(foldl promote-to-box form (free-variables form)))
(define (narrow-binds+promote nested-bind)
(define flat-bind (flatten-binds nested-bind))
(define (at-top-level? var)
(or (ormap (lambda (x) (form-sets? x var #f)) (cddr flat-bind))
(ormap (lambda (x) (form-uses? x var #f)) (cddr flat-bind))))
(define (captured-twice? var)
(let/cc return
(foldl (lambda (subform once?)
(if (form-captures? subform var)
(if once? (return #t) #t)
once?))
(at-top-level? var)
(cddr flat-bind))
#f))
(define extra-bindings
(filter-not captured-twice?
(filter-not at-top-level?
(second flat-bind))))
(promote-shared-variables
`(%bind ,(remove* extra-bindings (second flat-bind))
,@(map (lambda (subform)
(match subform
[`(%set! ,var (%lambda ,g-vars ,i-vars ,bind))
`(%set! ,var (%lambda ,g-vars ,i-vars
,(narrow-binds+promote
(foldl (lambda (var temp-bind)
(if (memq var (free-variables temp-bind))
`(%bind (,@(second temp-bind) ,var)
,@(cddr temp-bind))
temp-bind))
bind
extra-bindings))))]
[_ subform]))
(cddr flat-bind)))))
(define (split-arglist arglist) (define (split-arglist arglist)
(define (split-optional arglist) (match arglist
(if (pair? arglist) [`(,(? symbol? reqs) ... ,(and opts (list (? symbol?) _)) ... . ,(? symbol? rst))
(let-values ([(opt rst) (split-optional (cdr arglist))]) (values reqs opts rst)]
(values (cons (car arglist) opt) rst)) [`(,(? symbol? reqs) ... ,(and opts (list (? symbol?) _)) ...)
(values '() arglist))) (values reqs opts #f)]
(cond [_ (error "Invalid argument list:" arglist)]))
[(null? arglist) (values '() '() #f)]
[(not (pair? arglist)) (values '() '() arglist)]
[(pair? (car arglist)) (let-values ([(opt rst) (split-optional arglist)])
(values '() opt rst))]
[else (let-values ([(req opt rst) (split-arglist (cdr arglist))])
(values (cons (car arglist) req) opt rst))]))
(define (add-return ctx k nested-bind) (define (add-return ctx k nested-bind)
(define flat-bind (flatten-binds nested-bind)) (define flat-bind (flatten-binds nested-bind))
(define argv (gensym)) (define argv (gensym))
`(%bind (,@(second flat-bind) ,argv) `(%bind (,@(second flat-bind) ,argv)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(cond (if (pair? after)
[(pair? after) (cons subform after)
(cons subform after)] (match subform
[(simple-value? subform) [(? simple-value?)
`((%set! ,argv (%cons ,subform %nil)) `((%set! ,argv (%cons ,subform %nil))
(%tail-call ,k ,argv #f #f))] (%tail-call ,k ,argv #f #f))]
[(eq? (first subform) '%apply) [`(%apply ,x ,y)
`((%tail-call ,(second subform) ,(third subform) ,ctx ,k))] `((%tail-call ,x ,y ,ctx ,k))]
[(eq? (first subform) '%call/cc) [`(%call/cc ,x)
`((%set! ,argv (%cons %k %nil)) `((%set! ,argv (%cons %k %nil))
(%tail-call ,(second subform) ,argv ,ctx %k))] (%tail-call ,x ,argv ,ctx %k))]
[(eq? (first subform) '%values) [`(%values . ,simple-vals)
`((%set! ,argv %nil) `((%set! ,argv %nil)
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv))) ,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
(reverse (cdr subform))) (reverse simple-vals))
(%tail-call ,k ,argv #f #f))] (%tail-call ,k ,argv #f #f))]
[(value-form? subform) [(? value-form?)
`((%set! ,argv ,subform) `(,(simplify-set! `(set! ,argv ,subform))
(%set! ,argv (%cons ,argv %nil)) (%set! ,argv (%cons ,argv %nil))
(%tail-call ,k ,argv #f #f))] (%tail-call ,k ,argv #f #f))]
[(eq? (first subform) '%tail-call) [`(%tail-call . ,_)
`(,subform)] `(,subform)]
[else [_
`(,subform `(,subform
(%tail-call ,k %nil #f #f))])) (%tail-call ,k %nil #f #f))])))
'() '()
(cddr flat-bind)))) (cddr flat-bind))))
; <= (%bind (var...)
; @before
; (%apply x y)
; @after))
; => (%bind (var... k)
; @before
; (%set! k (lambda _ @after))
; (%tail-call x y ctx k)))
; <= (%bind (var...)
; @before
; (%set! v (%apply x y))
; @after))
; => (%bind (var... k)
; @before
; (%set! k (lambda (x)
; (%set! v x)
; @after))
; (%tail-call x y ctx k)))
; <= (%bind (var...)
; @before
; (call/cc l)
; @after)
; => (%bind (var... k k2)
; @before
; (%set! k (lambda _ @after))
; (%set! k-argv (%cons k %nil))
; (%tail-call l k-argv ctx k))
(define (transform-to-cps ctx nested-bind) (define (transform-to-cps ctx nested-bind)
(define flat-bind (flatten-binds nested-bind)) (define flat-bind (flatten-binds nested-bind))
(define (cps-prepend subform after) (define (cps-prepend subform after)
(cond (match subform
; (%set! v (%apply x y)) [`(%set! ,v (%value-list (%apply ,x ,y)))
[(and (pair? subform) (let ([k (gensym)])
(eq? (first subform) '%set!) `((%bind (,k)
(pair? (third subform)) (%set! ,k ,(simplify-form
(eq? (first (third subform)) '%apply)) `(lambda ,v
(let ([k (gensym)] ,@after)))
[x (gensym)]) (%tail-call ,x ,y ,ctx ,k))))]
`((%bind (,k ,x) [`(%set! ,v (%apply ,x ,y))
(%set! ,k ,(simplify-form (let ([k (gensym)])
`(lambda (,x . ,(gensym)) `((%bind (,k)
(%set! ,(second subform) ,x) (%set! ,k ,(simplify-form
,@after))) `(lambda (,v . ,(gensym))
(%tail-call ,(second (third subform)) ,@after)))
,(third (third subform)) (%tail-call ,x ,y ,ctx ,k))))]
,ctx [(or `(%value-list (%apply ,x ,y))
,k))))] `(%apply ,x ,y))
; (%apply x y) (let ([k (gensym)])
[(and (pair? subform) `((%bind (,k)
(eq? (first subform) '%apply)) (%set! ,k ,(simplify-form
(let ([k (gensym)]) `(lambda ,(gensym)
`((%bind (,k) ,@after)))
(%set! ,k ,(simplify-form (%tail-call ,x ,y ,ctx ,k))))]
`(lambda ,(gensym) [`(%set! ,v (%value-list (%call/cc ,x)))
,@after))) (let ([k (gensym)]
(%tail-call ,(second subform) [k-argv (gensym)])
,(third subform) `((%bind (,k ,k-argv)
,ctx (%set! ,k ,(simplify-form
,k))))] `(lambda ,v
; (%set! v (%call/cc x)) ,@after)))
[(and (pair? subform) (%set! ,k-argv (%cons ,k %nil))
(eq? (first subform) '%set!) (%tail-call ,x ,k-argv ,ctx ,k))))]
(pair? (third subform)) [`(%set! ,v (%call/cc ,x))
(eq? (first (third subform)) '%call/cc)) (let ([k (gensym)]
(let ([k (gensym)] [k-argv (gensym)])
[k-argv (gensym)] `((%bind (,k ,k-argv)
[x (gensym)]) (%set! ,k ,(simplify-form
`((%bind (,k ,k-argv) `(lambda (,v . ,(gensym))
(%set! ,k ,(simplify-form ,@after)))
`(lambda (,x . ,(gensym)) (%set! ,k-argv (%cons ,k %nil))
(%set! ,(second subform) ,x) (%tail-call ,x ,k-argv ,ctx ,k))))]
,@after))) [(or `(%value-list (%call/cc ,x))
(%set! ,k-argv (%cons ,k %nil)) `(%call/cc ,x))
(%tail-call ,(second (third subform)) (let ([k (gensym)]
,k-argv [k-argv (gensym)])
,ctx `((%bind (,k ,k-argv)
,k))))] (%set! ,k ,(simplify-form
; (%call/cc x) `(lambda ,(gensym)
[(and (pair? subform) ,@after)))
(eq? (first subform) '%call/cc)) (%set! ,k-argv (%cons ,k %nil))
(let ([k (gensym)] (%tail-call ,x ,k-argv ,ctx ,k))))]
[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
,ctx
,k))))]
; keep all other forms with side-effects as-is ; keep all other forms with side-effects as-is
[(statement-form? subform) [(? statement-form?) (cons subform after)]
(cons subform after)]
; discard any form without side-effects ; discard any form without side-effects
[else after])) [_ after]))
(flatten-binds `(%bind ,(second flat-bind)
`(%bind ,(second flat-bind) ,@(foldr cps-prepend '() (cddr flat-bind))))
,@(foldr cps-prepend '() (cddr flat-bind)))))
(define (simplify-lambda form) (define (simplify-lambda form)
(define arglist (car (cdr form))) (define arglist (cadr form))
(define bodyexprs (cdr (cdr form))) (define bodyexprs (cddr form))
(define-values (requireds optionals rest) (split-arglist arglist)) (define-values (requireds optionals rest) (split-arglist arglist))
(define argv (gensym))
(define ctx (gensym))
(define k (gensym))
(define (add-req req inner) `(let ([,req (car ,argv)]) (define argv (gensym))
(set! ,argv (cdr ,argv)) (define ctx (gensym))
,inner)) (define k (gensym))
(define (add-opt opt-list inner) `(let (,(car opt-list))
(if (pair? ,argv) (define (add-req req inner)
(begin `(let ([,req (car ,argv)])
(set! ,(first opt-list) (car ,argv)) (set! ,argv (cdr ,argv))
(set! ,argv (cdr ,argv))) ,inner))
(set! ,(first opt-list) ,(second opt-list)))
,inner)) (define (add-opt opt-list inner)
(define rest+bodyexprs (if rest `(let ([,rest ,argv]) ,@bodyexprs) `(let (,(car opt-list))
`(begin ,@bodyexprs))) (if (pair? ,argv)
(narrow-binds (begin
`(%lambda () () (set! ,(first opt-list) (car ,argv))
,((compose (lambda (bind) (transform-to-cps ctx bind)) (set! ,argv (cdr ,argv)))
(lambda (bind) (add-return ctx k bind))) (set! ,(first opt-list) ,(second opt-list)))
(simplify-form ,inner))
`(let ([,argv %argv]
[,ctx %ctx] (define rest+bodyexprs
[,k %k]) (if rest
,(foldr add-req `(let ([,rest ,argv]) ,@bodyexprs)
(foldr add-opt `(begin ,@bodyexprs)))
rest+bodyexprs
optionals) `(%lambda () ()
requireds))))))) ,((compose narrow-binds+promote
(lambda (bind) (transform-to-cps ctx bind))
(lambda (bind) (add-return ctx k bind))
simplify-form)
`(let ([,argv %argv]
[,ctx %ctx]
[,k %k])
,(foldr add-req
(foldr add-opt
rest+bodyexprs
optionals)
requireds)))))
; (fn-expr arg-expr...) ; (fn-expr arg-expr...)
; => (let ([fn-var fn-expr] arg-var... argv) ; => (let ([fn-var fn-expr] arg-var... argv)
@ -405,89 +500,22 @@
; (set! argv (cons arg-var argv))... [reversed] ; (set! argv (cons arg-var argv))... [reversed]
; (%apply fn-var argv)) ; (%apply fn-var argv))
(define (simplify-funcall form) (define (simplify-apply fn-expr arg-exprs)
(define fn-expr (car form))
(define arg-exprs (cdr form))
(define fn-var (gensym)) (define fn-var (gensym))
(define arg-vars (map (lambda (x) (gensym)) arg-exprs))
(define argv (gensym)) (define argv (gensym))
(define arguments
(foldr (lambda (expr args)
(if (null? args)
(cons (list argv expr) args)
(if (literal-value? expr)
(cons (list expr #f) args)
(cons (list (gensym) expr) args))))
'()
arg-exprs))
(simplify-form (simplify-form
`(let (,fn-var ,@arg-vars ,argv) `(let ([,fn-var ,fn-expr] ,@(filter second arguments))
(set! ,fn-var ,fn-expr) ,@(map (lambda (x) `(%set! ,argv (%cons ,x ,argv)))
,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs) (map first (reverse (drop-right arguments 1))))
(%set! ,argv %nil)
,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
(%apply ,fn-var ,argv)))) (%apply ,fn-var ,argv))))
(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 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?)
(if (or set-after? (form-sets? subform var captured-output?))
(if (form-uses? subform var captured-input?)
(return #t)
#t)
#f))
#f
(cddr bind))
#f))
(and (not (special-variable? var))
(or captured-input?
captured-output?)
(set-after-first-use?)))
(define (promote-shared-variables simple-lambda-form)
(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)
frm))
bind
(second bind))))
(define (promote-free-variables 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))))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

395
libcompiler/utilities.scm
View File

@ -1,12 +1,15 @@
#lang scheme/base #lang scheme/base
(require scheme/list) (require scheme/list)
(require scheme/match)
(require scheme/pretty) (require scheme/pretty)
(require (file "primitives.scm")) (require (file "primitives.scm"))
(provide trace (provide trace
subst subst
subst*
find find
curry-keywords
variable-value? variable-value?
literal-value? literal-value?
simple-value? simple-value?
@ -15,6 +18,7 @@
primitive-form? primitive-form?
pure-form? pure-form?
bind-form? bind-form?
traverse-form
map-form map-form
search-form search-form
form-sets? form-sets?
@ -22,8 +26,8 @@
form-captures? form-captures?
form-captures-input? form-captures-input?
form-captures-output? form-captures-output?
narrow-binds
subst-var subst-var
subst-var*
flatten-binds flatten-binds
free-variables free-variables
free-input-variables free-input-variables
@ -37,10 +41,14 @@
(define (subst old new lst) (define (subst old new lst)
(foldr (lambda (x rst) (foldr (lambda (x rst)
(cons (if (eq? x old) (cons (if (eq? x old) new x) rst))
new '()
x) lst))
rst))
(define (subst* old->new lst)
(foldr (lambda (x rst)
(let ([item (assoc x old->new)])
(cons (if item (second item) x) rst)))
'() '()
lst)) lst))
@ -51,6 +59,43 @@
(when (eq? y x) (return i))) (when (eq? y x) (return i)))
#f)) #f))
;; Combines two sorted keyword-value list pairs into a single
;; sorted list-pair, taking the values from the second list
;; where the same keyword exists in both lists.
(define (merge-keywords keywords-1 kw-values-1 keywords-2 kw-values-2)
(let iter ([kw '()] [kv '()]
[kw-1 keywords-1] [kv-1 kw-values-1]
[kw-2 keywords-2] [kv-2 kw-values-2])
(cond
[(null? kw-2) (values (append (reverse kw) kw-1) (append (reverse kv) kv-1))]
[(null? kw-1) (values (append (reverse kw) kw-2) (append (reverse kv) kv-2))]
[(eq? (car kw-1) (car kw-2))
(iter (cons (car kw-2) kw) (cons (car kv-2) kv)
(cdr kw-1) (cdr kv-1)
(cdr kw-2) (cdr kv-2))]
[(keyword<? (car kw-1) (car kw-2))
(iter (cons (car kw-1) kw) (cons (car kv-1) kv)
(cdr kw-1) (cdr kv-1)
kw-2 kv-2)]
[else
(iter (cons (car kw-2) kw) (cons (car kv-2) kv)
kw-1 kv-1
(cdr kw-2) (cdr kv-2))])))
;; Like (curry ...) from scheme/function, but with much better support for
;; keyword arguments. Keyword arguments supplied to curry-keywords act as
;; defaults, which may be overridden by keywords passed to the resulting
;; function. It can also curry non-keyword arguments, naturally.
(define curry-keywords
(make-keyword-procedure
(lambda (curried-keywords curried-kw-values fn . curried-non-keywords)
(make-keyword-procedure
(lambda (keywords kw-values . non-keywords)
(let-values ([(all-keywords all-kw-values)
(merge-keywords curried-keywords curried-kw-values keywords kw-values)])
(keyword-apply fn all-keywords all-kw-values
(append curried-non-keywords non-keywords))))))))
(define (variable-value? form) (define (variable-value? form)
(and (symbol? form) (and (symbol? form)
(not (eq? form '%undef)))) (not (eq? form '%undef))))
@ -68,7 +113,7 @@
; A value-form is any simple form which can appear on the right-hand side of a (set! ...). ; 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. ; If there are any side-effect they occur before the variable is updated.
(define (value-form? form) (define (value-form? form)
(define complex-values '(%bind %apply %call/cc %values)) (define complex-values '(%bind %lambda %apply %call/cc %values %value-list))
(or (simple-value? form) (or (simple-value? form)
(memq (first form) complex-values) (memq (first form) complex-values)
(memq (first form) (map first value-primitives)))) (memq (first form) (map first value-primitives))))
@ -91,129 +136,120 @@
(define (bind-form? form) (define (bind-form? form)
(and (pair? form) (eq? (first form) '%bind))) (and (pair? form) (eq? (first form) '%bind)))
(define (map-form form (define (traverse-form form
#:bind [bind-fn (lambda (recurse op vars . subforms) #:bind [bind-fn (lambda (recurse op vars . subforms)
`(,op ,vars ,@(map recurse subforms)))] (for ([subform (in-list subforms)])
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) (recurse subform)))]
`(,op ,g-vars ,i-vars ,(recurse bind)))] #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
#:set [set-fn (lambda (recurse op var value) (recurse bind))]
`(,op ,var ,(recurse value)))] #:set [set-fn (lambda (recurse op var value-form)
(recurse value-form))]
#:primitive [primitive-fn (lambda (recurse op . simple-values) #:value-list [value-list-fn (lambda (recurse op values-form)
`(,op ,@(map recurse simple-values)))] (recurse values-form))]
#:values [values-fn primitive-fn] #:primitive [primitive-fn (lambda (recurse op . simple-values)
#:call [call-fn primitive-fn] (for ([val (in-list simple-values)])
#:apply [apply-fn call-fn] (recurse val)))]
#:call/cc [call/cc-fn call-fn] #:simple [simple-fn (lambda (recurse kind simple-value) (void))]
#:tail-call [tail-call-fn call-fn] #:other [other-fn (lambda (recurse . form)
(error "Unsimplified form:" form))]
#:simple [simple-fn (lambda (recurse kind form) form)] #:values [values-fn primitive-fn]
#:variable [variable-fn simple-fn] #:call [call-fn primitive-fn]
#:literal [literal-fn simple-fn] #:variable [variable-fn simple-fn]
#:literal [literal-fn simple-fn]
#:other [other-fn (lambda (recurse . form) #:apply [apply-fn call-fn]
(error "Unsimplified form:" form))]) #:call/cc [call/cc-fn call-fn]
#:tail-call [tail-call-fn call-fn])
(define (recurse subform) (define (recurse subform)
(map-form subform ; Can skip #:primitive, #:call, and #:simple, which only set defaults.
#:bind bind-fn (traverse-form subform
#:lambda lambda-fn #:bind bind-fn
#:set set-fn #:lambda lambda-fn
#:primitive primitive-fn #:set set-fn
#:values values-fn #:value-list value-list-fn
#:call call-fn #:primitive primitive-fn
#:apply apply-fn #:other other-fn
#:call/cc call/cc-fn #:values values-fn
#:tail-call tail-call-fn #:variable variable-fn
#:simple simple-fn #:literal literal-fn
#:variable variable-fn #:apply apply-fn
#:literal literal-fn #:call/cc call/cc-fn
#:other other-fn)) #:tail-call tail-call-fn))
(cond (cond
[(variable-value? form) (variable-fn recurse 'variable form)] [(variable-value? form) (variable-fn recurse 'variable form)]
[(literal-value? form) (literal-fn recurse 'literal form)] [(literal-value? form) (literal-fn recurse 'literal form)]
[else [else
(let ([handler (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]
[(%values) values-fn] [(%value-list) value-list-fn]
[(%apply) apply-fn] [(%values) values-fn]
[(%call/cc) call/cc-fn] [(%apply) apply-fn]
[(%tail-call) tail-call-fn] [(%call/cc) call/cc-fn]
[else (if (primitive-form? form) [(%tail-call) tail-call-fn]
primitive-fn [else (if (primitive-form? form)
other-fn)])]) primitive-fn
other-fn)])])
(apply handler recurse form))])) (apply handler recurse form))]))
; Like map-form, but intended for boolean results. (Just different defaults.) (define map-form
(define (search-form form (curry-keywords traverse-form
#:merge-with [merge-fn ormap] #:bind (lambda (recurse op vars . subforms)
#:base-value [base-value #f] `(,op ,vars ,@(map recurse subforms)))
#:bind [bind-fn (lambda (recurse op vars . subforms) #:lambda (lambda (recurse op g-vars i-vars bind)
(merge-fn recurse subforms))] `(,op ,g-vars ,i-vars ,(recurse bind)))
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) #:set (lambda (recurse op var value-form)
(recurse bind))] `(,op ,var ,(recurse value-form)))
#:set [set-fn (lambda (recurse op var value) #:value-list (lambda (recurse op values-form)
(recurse value))] `(,op ,(recurse values-form)))
#:primitive (lambda (recurse op . simple-values)
`(,op ,@(map recurse simple-values)))
#:simple (lambda (recurse kind form) form)))
#:primitive [primitive-fn (lambda (recurse op . simple-values) ; Like map-form, but intended for boolean results.
(merge-fn recurse simple-values))] (define search-form
#:values [values-fn primitive-fn] (curry-keywords traverse-form
#:call [call-fn primitive-fn] #:bind (lambda (recurse op vars . subforms)
#:apply [apply-fn call-fn] (ormap recurse subforms))
#:call/cc [call/cc-fn call-fn] #:lambda (lambda (recurse op g-vars i-vars bind)
#:tail-call [tail-call-fn call-fn] (recurse bind))
#:set (lambda (recurse op var value)
#:simple [simple-fn (lambda (recurse kind form) base-value)] (recurse value))
#:variable [variable-fn simple-fn] #:value-list (lambda (recurse op var values-form)
#:literal [literal-fn simple-fn] (recurse values-form))
#:primitive (lambda (recurse op . simple-values)
#:other [other-fn (lambda (recurse . form) (ormap recurse simple-values))
(error "Unsimplified form:" form))]) #:simple (lambda (recurse kind form) #f)))
(map-form form
#:bind bind-fn
#:lambda lambda-fn
#:set set-fn
#:primitive primitive-fn
#:values values-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 (form-sets? form variable [call-may-set? #t]) (define (form-sets? form variable [call-may-set? #t])
(search-form form (search-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) #:set (lambda (recurse op var value-form)
(eq? var variable)) (or (eq? var variable)
#:call (lambda _ call-may-set?))) (recurse value-form)))
#:call (lambda _ call-may-set?)))
(define (form-uses? form variable [call-may-use? #t] [descend? #t]) (define (form-uses? form variable [call-may-use? #t])
(search-form form (search-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 . form) #f)
(and descend? (recurse bind))) #: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))))
#: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])
(search-form form (search-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))))
(define (form-captures-input? form var) (define (form-captures-input? form var)
(form-captures? form var #t #f)) (form-captures? form var #t #f))
@ -224,64 +260,30 @@
(define (value-used? variable forms) (define (value-used? variable forms)
(cond (cond
[(null? forms) #f] [(null? forms) #f]
[(form-uses? (first forms) variable #f #t) #t] [(form-captures-input? (first forms) variable) #t]
[(form-uses? (first forms) variable #f) #t]
[(form-sets? (first forms) variable #f) #f] [(form-sets? (first forms) variable #f) #f]
[else (value-used? variable (cdr forms))])) [else (value-used? variable (cdr forms))]))
(define (subst-var old-var new-var form) (define (subst-var old-var new-var form)
(map-form form (map-form form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
`(%bind ,(subst old-var new-var vars) ,@(map recurse subforms))) `(%bind ,(subst old-var new-var vars) ,@(map recurse subforms)))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
`(,op ,(if (eq? var old-var) new-var var) ,(recurse value))) `(,op ,(if (eq? var old-var) new-var var) ,(recurse value)))
#:variable (lambda (recurse op var) #:variable (lambda (recurse op var)
(if (eq? var old-var) new-var var)))) (if (eq? var old-var) new-var var))))
(define (narrow-binds simple-lambda-form) (define (subst-var* var-map form)
(define bind (fourth simple-lambda-form)) (map-form form
#:bind (lambda (recurse op vars . subforms)
(define (at-top-level? var) `(%bind ,(subst* var-map vars) ,@(map recurse subforms)))
(or (ormap (lambda (x) (form-sets? x var #f)) (cddr bind)) #:set (lambda (recurse op var value)
(ormap (lambda (x) (form-uses? x var #f #f)) (cddr bind)))) (let ([item (assoc var var-map)])
`(,op ,(if item (second item) var) ,(recurse value))))
(define (captured-twice? var) #:variable (lambda (recurse op var)
(let/cc return (let ([item (assoc var var-map)])
(foldl (lambda (subform once?) (if item (second item) var)))))
(if (form-captures? subform var)
(if once? (return #t) #t)
once?))
(at-top-level? var)
(cddr bind))
#f))
(define extra-binds
(filter-not captured-twice?
(filter-not at-top-level?
(second bind))))
`(%lambda ,(second simple-lambda-form) ,(third simple-lambda-form)
(%bind ,(remove* extra-binds (second bind))
,@(map (lambda (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)])
`(%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 (flatten-binds form) (define (flatten-binds form)
(define (make-bindings-unique bind rename-vars) (define (make-bindings-unique bind rename-vars)
@ -293,42 +295,41 @@
(foldr make-binding-unique bind (filter needs-rename? (second bind)))) (foldr make-binding-unique bind (filter needs-rename? (second bind))))
(map-form form (map-form form
#:bind (lambda (recurse op bound-vars . original-subforms) #:bind (lambda (recurse op bound-vars . original-subforms)
(define rename-vars (define rename-vars
(remove-duplicates (remove-duplicates
(append (free-variables `(,op ,bound-vars ,@original-subforms)) (append (free-variables `(,op ,bound-vars ,@original-subforms))
bound-vars))) bound-vars)))
(define (form->list subform) (define (form->list subform)
(if (bind-form? subform) (if (bind-form? subform)
(let ([unique-form (make-bindings-unique (let ([unique-form (make-bindings-unique
(recurse subform) (recurse subform)
rename-vars)]) rename-vars)])
(set! bound-vars (append (second unique-form) bound-vars)) (set! bound-vars (append (second unique-form) bound-vars))
(cddr unique-form)) (cddr unique-form))
(list subform))) (list subform)))
(let ([subforms (append-map form->list original-subforms)]) (let ([subforms (append-map form->list original-subforms)])
`(%bind ,bound-vars ,@subforms))) `(%bind ,bound-vars ,@subforms)))
#:lambda (lambda (recurse . form) form))) #:lambda (lambda (recurse . form) form)))
(define (free-variables form [input? #t] [output? #t]) (define (free-variables form [input? #t] [output? #t])
(map-form form (define (append-map/unique fn . lsts)
#:bind (lambda (recurse op vars . subforms) (remove-duplicates (apply append-map fn lsts)))
(remove-duplicates (remove* vars (append-map recurse subforms)))) (traverse-form form
#:lambda (lambda (recurse op g-vars i-vars bind) #:bind (lambda (recurse op vars . subforms)
(recurse bind)) (remove* vars (append-map/unique recurse subforms)))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
(let ([value-free (recurse value)]) (let ([value-free (recurse value)])
(if output? (if (and output? (not (memq var value-free)))
(cons var value-free) (cons var value-free)
value-free))) value-free)))
#:primitive (lambda (recurse op . simple-values) #:primitive (lambda (recurse op . simple-values)
(remove-duplicates (append-map recurse simple-values))) (append-map/unique recurse simple-values))
#:simple (lambda (recurse kind form) #:simple (lambda (recurse kind form) '())
(if (and input? #:variable (lambda (recurse kind var)
(variable-value? form) (if (and input? (not (special-variable? var)))
(not (memq form '(%nil %self %argv %ctx %k)))) (list var)
(list form) '()))))
'()))))
(define (free-input-variables form) (define (free-input-variables form)
(free-variables form #t #f)) (free-variables form #t #f))

2
libcompiler/writer.scm
View File

@ -195,3 +195,5 @@
(variable->code (third form)) (variable->code (third form))
(variable->code (fourth form)))] (variable->code (fourth form)))]
[else (error "Unsupported form:" form)]))) [else (error "Unsupported form:" form)])))
; vim:set sw=2 expandtab: