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:
parent
b3fd7bf6fc
commit
cbcea20701
|
|
@ -1,10 +1,15 @@
|
|||
#! /usr/bin/mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/pretty)
|
||||
|
||||
(require (file "libcompiler/reader.scm"))
|
||||
(require (file "libcompiler/compiler.scm"))
|
||||
(require (file "libcompiler/writer.scm"))
|
||||
|
||||
(optimize? #t)
|
||||
|
||||
;(pretty-print (reduce-function (read-module)))
|
||||
(write-rla-value (compile-function (read-module)))
|
||||
(write-char #\Newline)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,9 @@
|
|||
(require (file "mapper.scm"))
|
||||
|
||||
(provide reduce-function
|
||||
compile-function)
|
||||
compile-function
|
||||
optimize?
|
||||
box-free-variables?)
|
||||
|
||||
(define optimize? (make-parameter #t))
|
||||
(define box-free-variables? (make-parameter #f))
|
||||
|
|
@ -16,7 +18,7 @@
|
|||
(define (reduce-function lambda-form)
|
||||
((compose (if (optimize?) optimize-function values)
|
||||
(if (box-free-variables?) promote-free-variables values)
|
||||
simplify-function)
|
||||
simplify-lambda)
|
||||
lambda-form))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
|
|
@ -24,10 +24,12 @@
|
|||
(set! g-vars (append g-vars (list value)))
|
||||
g-var))))
|
||||
|
||||
(for ([free-var (in-list (filter frame/instance-variable? (free-variables bind)))]
|
||||
(let* ([free-vars (filter frame/instance-variable? (free-variables bind))]
|
||||
[var-map (for/list ([free-var (in-list free-vars)]
|
||||
[inst-var (in-list instance-variables)])
|
||||
(set! i-vars (append i-vars (list free-var)))
|
||||
(set! bind (subst-var free-var inst-var bind)))
|
||||
(list free-var inst-var))])
|
||||
(set! bind (subst-var* var-map bind)))
|
||||
|
||||
(for ([bound-var (in-list (second bind))]
|
||||
[frame-var (in-list frame-variables)])
|
||||
|
|
@ -44,3 +46,5 @@
|
|||
|
||||
`(,(if (null? i-vars) '%lambda '%template) ,g-vars ,i-vars
|
||||
,bind)))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require scheme/match)
|
||||
(require (file "utilities.scm"))
|
||||
|
||||
(provide reduce-variables
|
||||
|
|
@ -31,17 +32,13 @@
|
|||
(if (and (pair? subform)
|
||||
(eq? (first subform) '%set!)
|
||||
(or (memq (second subform) vars)
|
||||
; Top-level (free) variables are presumed to be
|
||||
; constant. The alternative was to assume them
|
||||
; to be boxes, which has its own complications.
|
||||
(error "Setting unbound var:" subform))
|
||||
(error "Setting unbound (constant) variable:" subform))
|
||||
(not (value-used? (second subform) after)))
|
||||
after
|
||||
(cons subform after)))
|
||||
`(%bind ,vars
|
||||
,@(foldr prepend-if-used '() (map recurse subforms))))
|
||||
(narrow-binds
|
||||
(map-form form #:bind bind-fn)))
|
||||
(map-form form #:bind bind-fn))
|
||||
|
||||
(define (propogate-value variable value invalidates? forms)
|
||||
(if (null? forms)
|
||||
|
|
@ -84,53 +81,45 @@
|
|||
; Known values are:
|
||||
; literals, always
|
||||
; var, until (%set! var ...)
|
||||
; (%unbox var), until (%set-box! var ...) or (%set! var)
|
||||
; (%car var), until (%set-car! var) or (%set! var)
|
||||
; (%cdr var), until (%set-cdr! var) or (%set! var)
|
||||
; (%unbox var), until (%set-box! ...) or (%set! var)
|
||||
; (%car var), until (%set-car! ...) or (%set! var)
|
||||
; (%cdr var), until (%set-cdr! ...) or (%set! var)
|
||||
(define (propogate-set! form)
|
||||
(define (bind-fn recurse op vars . subforms)
|
||||
(define (prepend subform after)
|
||||
(if (eq? (first subform) '%set!)
|
||||
(let ([var (second subform)]
|
||||
[value (third subform)])
|
||||
(cons
|
||||
subform
|
||||
(cond
|
||||
[(simple-value? value)
|
||||
(match subform
|
||||
[`(%set! ,var ,(? simple-value? value))
|
||||
(propogate-simple-value var value
|
||||
(lambda (form)
|
||||
(and (eq? (first form) '%set!)
|
||||
(eq? (second form) value)))
|
||||
after)]
|
||||
[(eq? (first value) '%unbox)
|
||||
(let ([box-var (second value)])
|
||||
[`(%set! ,var ,(and value `(%unbox ,box-var)))
|
||||
(propogate-value var value
|
||||
(lambda (form)
|
||||
(or (and (eq? (first form) '%set!)
|
||||
(eq? (second form) box-var))
|
||||
(and (eq? (first form) '%set-box!)
|
||||
(eq? (second form) box-var))))
|
||||
after))]
|
||||
[(eq? (first value) '%car)
|
||||
(let ([pair-var (second value)])
|
||||
(eq? (first form) '%set-box!)))
|
||||
after)]
|
||||
[`(%set! ,var ,(and value `(%car ,pair-var)))
|
||||
(propogate-value var value
|
||||
(lambda (form)
|
||||
(or (and (eq? (first form) '%set!)
|
||||
(eq? (second form) pair-var))
|
||||
(and (eq? (first form) '%set-car!)
|
||||
(eq? (second form) pair-var))))
|
||||
after))]
|
||||
[(eq? (first value) '%cdr)
|
||||
(let ([pair-var (second value)])
|
||||
(eq? (first form) '%set-car!)))
|
||||
after)]
|
||||
[`(%set! ,var ,(and value `(%cdr ,pair-var)))
|
||||
(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)))
|
||||
(eq? (first form) '%set-cdr!)))
|
||||
after)]
|
||||
[_ after])))
|
||||
`(%bind ,vars
|
||||
,@(foldr prepend '() (map recurse subforms))))
|
||||
(map-form form #:bind bind-fn))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require scheme/path)
|
||||
|
||||
(provide read-module)
|
||||
|
||||
|
|
@ -8,24 +9,35 @@
|
|||
`(lambda *argv*
|
||||
,@(let iter ([forms (read-forms port)]
|
||||
[bindings '()])
|
||||
(cond
|
||||
[(null? forms) (if (null? bindings)
|
||||
(match forms
|
||||
['()
|
||||
(if (null? bindings)
|
||||
'()
|
||||
`(letrec ,bindings))]
|
||||
[(simple-define-form? (first forms))
|
||||
(iter (cdr forms) (cons (cdr (first forms))
|
||||
`((letrec ,(reverse bindings))))]
|
||||
[`((define ,var ,expr) . ,rst)
|
||||
(iter rst (cons (list var expr) bindings))]
|
||||
[`((define (,var . ,arglist) . ,body) . ,rst)
|
||||
(iter rst (cons (list var `(lambda ,arglist ,@body)) bindings))]
|
||||
[`((define . ,_) . ,_)
|
||||
(error "Unrecognized define-form:" (first forms))]
|
||||
[`((begin . ,body) . ,rst)
|
||||
(iter (append body rst) bindings)]
|
||||
[`((load ,(? string? pathname)) . ,rst)
|
||||
(let ([complete-path (path->complete-path pathname)]
|
||||
[directory (path-only complete-path)])
|
||||
(iter (append (with-input-from-file complete-path
|
||||
(lambda ()
|
||||
(parameterize ([current-directory directory])
|
||||
(read-forms))))
|
||||
rst)
|
||||
bindings))]
|
||||
[(lambda-define-form? (first forms))
|
||||
(iter (cdr forms) (cons `(,(first (second (first forms)))
|
||||
(lambda ,(cdr (second (first forms)))
|
||||
,@(cddr (first forms))))
|
||||
bindings))]
|
||||
[(begin-form? (first forms))
|
||||
(iter (append (cdr (first forms)) (cdr forms)) bindings)]
|
||||
[(null? bindings)
|
||||
(cons (first forms) (iter (cdr forms) '()))]
|
||||
[else
|
||||
`((letrec ,bindings ,@(iter forms '())))]))))
|
||||
[`((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)])
|
||||
(reverse (let iter ([form (read port)]
|
||||
|
|
@ -34,20 +46,4 @@
|
|||
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:
|
||||
|
|
|
|||
|
|
@ -1,32 +1,16 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require scheme/match)
|
||||
(require (file "utilities.scm"))
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide simplify-function
|
||||
(provide simplify-lambda
|
||||
promote-free-variables)
|
||||
|
||||
(define (simplify-function lambda-form)
|
||||
((compose promote-shared-variables
|
||||
simplify-lambda)
|
||||
lambda-form))
|
||||
|
||||
(define (simplify-form form)
|
||||
(define (same-form recurse . form) form)
|
||||
(map-form form
|
||||
#:bind same-form
|
||||
#:lambda same-form
|
||||
#:set same-form
|
||||
#:primitive same-form
|
||||
#:simple (lambda (recurse kind form) form)
|
||||
#:literal (lambda (recurse kind form)
|
||||
(if (and (pair? form)
|
||||
(eq? (first form) 'quote)
|
||||
(eq? (second form) '()))
|
||||
'%nil
|
||||
form))
|
||||
#:other (lambda (recurse op . others)
|
||||
(define (simplify-complex-form recurse op . others)
|
||||
(case op
|
||||
[(let) (simplify-let form)]
|
||||
[(let*) (simplify-let* form)]
|
||||
|
|
@ -47,41 +31,84 @@
|
|||
`(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-funcall form)))]))))
|
||||
(simplify-apply (first form) (append (cdr form) '(%nil)))))]))
|
||||
(map-form form
|
||||
#:bind same-form
|
||||
#:lambda same-form
|
||||
#:set same-form
|
||||
#:value-list same-form
|
||||
#:primitive same-form
|
||||
#:simple (lambda (recurse kind form) form)
|
||||
#:literal (lambda (recurse kind form)
|
||||
(if (equal? form '(quote ())) '%nil form))
|
||||
#:other simplify-complex-form))
|
||||
|
||||
(define (simplify-set! form)
|
||||
(let ([variable (second form)]
|
||||
[value-form (simplify-form (third form))])
|
||||
(if (and (pair? value-form) (eq? (first value-form) '%bind))
|
||||
(if (memq variable (second value-form))
|
||||
(match value-form
|
||||
[`(%bind ,bound-vars . ,subforms)
|
||||
(if (memq variable bound-vars)
|
||||
(let ([tmp (gensym)])
|
||||
`(%bind (,tmp)
|
||||
; guaranteed not to cause unbounded recursion: tmp is unique
|
||||
,(simplify-set! `(set! ,tmp ,value-form))
|
||||
(%set! ,variable ,tmp)))
|
||||
`(%bind ,(second value-form)
|
||||
`(%bind ,bound-vars
|
||||
,@(foldr (lambda (subform after)
|
||||
(cond
|
||||
[(pair? after) (cons subform after)]
|
||||
[(and (pair? subform) (eq? (first subform) '%values))
|
||||
; Requires at least one value; ignores extras.
|
||||
(if (null? (cdr subform))
|
||||
(error "Attempted to set variable to void in:" form)
|
||||
`((%set! ,variable ,(second subform))))]
|
||||
[(value-form? subform)
|
||||
(list (simplify-set! `(set! ,variable ,subform)))]
|
||||
[else (error "Attempted to set variable to void in:" form)]))
|
||||
(if (pair? after)
|
||||
(cons subform after)
|
||||
(list (simplify-set! `(set! ,variable ,subform)))))
|
||||
'()
|
||||
(cddr value-form))))
|
||||
`(%set! ,variable ,value-form))))
|
||||
subforms)))]
|
||||
[`(%values ,first-val . ,other-vals)
|
||||
`(%set! ,variable ,first-val)]
|
||||
[`(%values)
|
||||
(error "Attempted to set variable to void in:" form)]
|
||||
[(? 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 (value->binding value-form)
|
||||
|
|
@ -207,218 +234,12 @@
|
|||
; (if (eq? argv-temp %nil)
|
||||
; (set! optional-1 default-expr-1)
|
||||
; (set! optional-1 (car argv-temp)))
|
||||
; ; TODO: Handle keyword arguments here...
|
||||
; (set! argv-temp (cdr argv-temp))
|
||||
; (...
|
||||
; (let ([rest argv-temp])
|
||||
; bodyexpr...)...)))...)))
|
||||
|
||||
(define (split-arglist arglist)
|
||||
(define (split-optional arglist)
|
||||
(if (pair? arglist)
|
||||
(let-values ([(opt rst) (split-optional (cdr arglist))])
|
||||
(values (cons (car arglist) opt) rst))
|
||||
(values '() arglist)))
|
||||
(cond
|
||||
[(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 flat-bind (flatten-binds nested-bind))
|
||||
(define argv (gensym))
|
||||
`(%bind (,@(second flat-bind) ,argv)
|
||||
,@(foldr (lambda (subform after)
|
||||
(cond
|
||||
[(pair? after)
|
||||
(cons subform after)]
|
||||
[(simple-value? subform)
|
||||
`((%set! ,argv (%cons ,subform %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(eq? (first subform) '%apply)
|
||||
`((%tail-call ,(second subform) ,(third subform) ,ctx ,k))]
|
||||
[(eq? (first subform) '%call/cc)
|
||||
`((%set! ,argv (%cons %k %nil))
|
||||
(%tail-call ,(second subform) ,argv ,ctx %k))]
|
||||
[(eq? (first subform) '%values)
|
||||
`((%set! ,argv %nil)
|
||||
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
|
||||
(reverse (cdr subform)))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(value-form? subform)
|
||||
`((%set! ,argv ,subform)
|
||||
(%set! ,argv (%cons ,argv %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(eq? (first subform) '%tail-call)
|
||||
`(,subform)]
|
||||
[else
|
||||
`(,subform
|
||||
(%tail-call ,k %nil #f #f))]))
|
||||
'()
|
||||
(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 flat-bind (flatten-binds nested-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))
|
||||
,ctx
|
||||
,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)
|
||||
,ctx
|
||||
,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
|
||||
,ctx
|
||||
,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
|
||||
,ctx
|
||||
,k))))]
|
||||
; keep all other forms with side-effects as-is
|
||||
[(statement-form? subform)
|
||||
(cons subform after)]
|
||||
; discard any form without side-effects
|
||||
[else after]))
|
||||
(flatten-binds
|
||||
`(%bind ,(second flat-bind)
|
||||
,@(foldr cps-prepend '() (cddr flat-bind)))))
|
||||
|
||||
(define (simplify-lambda form)
|
||||
(define arglist (car (cdr form)))
|
||||
(define bodyexprs (cdr (cdr form)))
|
||||
|
||||
(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)])
|
||||
(set! ,argv (cdr ,argv))
|
||||
,inner))
|
||||
(define (add-opt opt-list inner) `(let (,(car opt-list))
|
||||
(if (pair? ,argv)
|
||||
(begin
|
||||
(set! ,(first opt-list) (car ,argv))
|
||||
(set! ,argv (cdr ,argv)))
|
||||
(set! ,(first opt-list) ,(second opt-list)))
|
||||
,inner))
|
||||
(define rest+bodyexprs (if rest `(let ([,rest ,argv]) ,@bodyexprs)
|
||||
`(begin ,@bodyexprs)))
|
||||
(narrow-binds
|
||||
`(%lambda () ()
|
||||
,((compose (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...)
|
||||
; => (let ([fn-var fn-expr] arg-var... argv)
|
||||
; (set! fn-var fn-expr)
|
||||
; (set! arg-var arg-expr)...
|
||||
; (set! argv %nil)
|
||||
; (set! argv (cons arg-var argv))... [reversed]
|
||||
; (%apply fn-var argv))
|
||||
|
||||
(define (simplify-funcall form)
|
||||
(define fn-expr (car form))
|
||||
(define arg-exprs (cdr form))
|
||||
(define fn-var (gensym))
|
||||
(define arg-vars (map (lambda (x) (gensym)) arg-exprs))
|
||||
(define argv (gensym))
|
||||
(simplify-form
|
||||
`(let (,fn-var ,@arg-vars ,argv)
|
||||
(set! ,fn-var ,fn-expr)
|
||||
,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs)
|
||||
(%set! ,argv %nil)
|
||||
,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
|
||||
(%apply ,fn-var ,argv))))
|
||||
|
||||
(define (promote-to-box variable form)
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
|
|
@ -438,6 +259,8 @@
|
|||
,(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
|
||||
|
|
@ -455,39 +278,244 @@
|
|||
#: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?)
|
||||
(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 (subform set-after?)
|
||||
(if (or set-after? (form-sets? subform var captured-output?))
|
||||
(if (form-uses? subform var captured-input?)
|
||||
(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
|
||||
(cddr bind))
|
||||
forms)
|
||||
#f))
|
||||
(and (not (special-variable? var))
|
||||
(or captured-input?
|
||||
captured-output?)
|
||||
(set-after-first-use?)))
|
||||
(or captured-output?
|
||||
(and captured-input?
|
||||
(set-after-first-capture?))))
|
||||
|
||||
(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)
|
||||
(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))
|
||||
bind
|
||||
(second bind))))
|
||||
flat-bind
|
||||
(second flat-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))))
|
||||
(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)
|
||||
(match arglist
|
||||
[`(,(? symbol? reqs) ... ,(and opts (list (? symbol?) _)) ... . ,(? symbol? rst))
|
||||
(values reqs opts rst)]
|
||||
[`(,(? symbol? reqs) ... ,(and opts (list (? symbol?) _)) ...)
|
||||
(values reqs opts #f)]
|
||||
[_ (error "Invalid argument list:" arglist)]))
|
||||
|
||||
(define (add-return ctx k nested-bind)
|
||||
(define flat-bind (flatten-binds nested-bind))
|
||||
(define argv (gensym))
|
||||
`(%bind (,@(second flat-bind) ,argv)
|
||||
,@(foldr (lambda (subform after)
|
||||
(if (pair? after)
|
||||
(cons subform after)
|
||||
(match subform
|
||||
[(? simple-value?)
|
||||
`((%set! ,argv (%cons ,subform %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[`(%apply ,x ,y)
|
||||
`((%tail-call ,x ,y ,ctx ,k))]
|
||||
[`(%call/cc ,x)
|
||||
`((%set! ,argv (%cons %k %nil))
|
||||
(%tail-call ,x ,argv ,ctx %k))]
|
||||
[`(%values . ,simple-vals)
|
||||
`((%set! ,argv %nil)
|
||||
,@(map (lambda (sv) `(%set! ,argv (%cons ,sv ,argv)))
|
||||
(reverse simple-vals))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[(? value-form?)
|
||||
`(,(simplify-set! `(set! ,argv ,subform))
|
||||
(%set! ,argv (%cons ,argv %nil))
|
||||
(%tail-call ,k ,argv #f #f))]
|
||||
[`(%tail-call . ,_)
|
||||
`(,subform)]
|
||||
[_
|
||||
`(,subform
|
||||
(%tail-call ,k %nil #f #f))])))
|
||||
'()
|
||||
(cddr flat-bind))))
|
||||
|
||||
(define (transform-to-cps ctx nested-bind)
|
||||
(define flat-bind (flatten-binds nested-bind))
|
||||
(define (cps-prepend subform after)
|
||||
(match subform
|
||||
[`(%set! ,v (%value-list (%apply ,x ,y)))
|
||||
(let ([k (gensym)])
|
||||
`((%bind (,k)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda ,v
|
||||
,@after)))
|
||||
(%tail-call ,x ,y ,ctx ,k))))]
|
||||
[`(%set! ,v (%apply ,x ,y))
|
||||
(let ([k (gensym)])
|
||||
`((%bind (,k)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda (,v . ,(gensym))
|
||||
,@after)))
|
||||
(%tail-call ,x ,y ,ctx ,k))))]
|
||||
[(or `(%value-list (%apply ,x ,y))
|
||||
`(%apply ,x ,y))
|
||||
(let ([k (gensym)])
|
||||
`((%bind (,k)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda ,(gensym)
|
||||
,@after)))
|
||||
(%tail-call ,x ,y ,ctx ,k))))]
|
||||
[`(%set! ,v (%value-list (%call/cc ,x)))
|
||||
(let ([k (gensym)]
|
||||
[k-argv (gensym)])
|
||||
`((%bind (,k ,k-argv)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda ,v
|
||||
,@after)))
|
||||
(%set! ,k-argv (%cons ,k %nil))
|
||||
(%tail-call ,x ,k-argv ,ctx ,k))))]
|
||||
[`(%set! ,v (%call/cc ,x))
|
||||
(let ([k (gensym)]
|
||||
[k-argv (gensym)])
|
||||
`((%bind (,k ,k-argv)
|
||||
(%set! ,k ,(simplify-form
|
||||
`(lambda (,v . ,(gensym))
|
||||
,@after)))
|
||||
(%set! ,k-argv (%cons ,k %nil))
|
||||
(%tail-call ,x ,k-argv ,ctx ,k))))]
|
||||
[(or `(%value-list (%call/cc ,x))
|
||||
`(%call/cc ,x))
|
||||
(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 ,x ,k-argv ,ctx ,k))))]
|
||||
; keep all other forms with side-effects as-is
|
||||
[(? statement-form?) (cons subform after)]
|
||||
; discard any form without side-effects
|
||||
[_ after]))
|
||||
`(%bind ,(second flat-bind)
|
||||
,@(foldr cps-prepend '() (cddr flat-bind))))
|
||||
|
||||
(define (simplify-lambda form)
|
||||
(define arglist (cadr form))
|
||||
(define bodyexprs (cddr form))
|
||||
|
||||
(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)])
|
||||
(set! ,argv (cdr ,argv))
|
||||
,inner))
|
||||
|
||||
(define (add-opt opt-list inner)
|
||||
`(let (,(car opt-list))
|
||||
(if (pair? ,argv)
|
||||
(begin
|
||||
(set! ,(first opt-list) (car ,argv))
|
||||
(set! ,argv (cdr ,argv)))
|
||||
(set! ,(first opt-list) ,(second opt-list)))
|
||||
,inner))
|
||||
|
||||
(define rest+bodyexprs
|
||||
(if rest
|
||||
`(let ([,rest ,argv]) ,@bodyexprs)
|
||||
`(begin ,@bodyexprs)))
|
||||
|
||||
`(%lambda () ()
|
||||
,((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...)
|
||||
; => (let ([fn-var fn-expr] arg-var... argv)
|
||||
; (set! fn-var fn-expr)
|
||||
; (set! arg-var arg-expr)...
|
||||
; (set! argv %nil)
|
||||
; (set! argv (cons arg-var argv))... [reversed]
|
||||
; (%apply fn-var argv))
|
||||
|
||||
(define (simplify-apply fn-expr arg-exprs)
|
||||
(define fn-var (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
|
||||
`(let ([,fn-var ,fn-expr] ,@(filter second arguments))
|
||||
,@(map (lambda (x) `(%set! ,argv (%cons ,x ,argv)))
|
||||
(map first (reverse (drop-right arguments 1))))
|
||||
(%apply ,fn-var ,argv))))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/list)
|
||||
(require scheme/match)
|
||||
(require scheme/pretty)
|
||||
(require (file "primitives.scm"))
|
||||
|
||||
(provide trace
|
||||
subst
|
||||
subst*
|
||||
find
|
||||
curry-keywords
|
||||
variable-value?
|
||||
literal-value?
|
||||
simple-value?
|
||||
|
|
@ -15,6 +18,7 @@
|
|||
primitive-form?
|
||||
pure-form?
|
||||
bind-form?
|
||||
traverse-form
|
||||
map-form
|
||||
search-form
|
||||
form-sets?
|
||||
|
|
@ -22,8 +26,8 @@
|
|||
form-captures?
|
||||
form-captures-input?
|
||||
form-captures-output?
|
||||
narrow-binds
|
||||
subst-var
|
||||
subst-var*
|
||||
flatten-binds
|
||||
free-variables
|
||||
free-input-variables
|
||||
|
|
@ -37,10 +41,14 @@
|
|||
|
||||
(define (subst old new lst)
|
||||
(foldr (lambda (x rst)
|
||||
(cons (if (eq? x old)
|
||||
new
|
||||
x)
|
||||
rst))
|
||||
(cons (if (eq? x old) new x) rst))
|
||||
'()
|
||||
lst))
|
||||
|
||||
(define (subst* old->new lst)
|
||||
(foldr (lambda (x rst)
|
||||
(let ([item (assoc x old->new)])
|
||||
(cons (if item (second item) x) rst)))
|
||||
'()
|
||||
lst))
|
||||
|
||||
|
|
@ -51,6 +59,43 @@
|
|||
(when (eq? y x) (return i)))
|
||||
#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)
|
||||
(and (symbol? form)
|
||||
(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! ...).
|
||||
; If there are any side-effect they occur before the variable is updated.
|
||||
(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)
|
||||
(memq (first form) complex-values)
|
||||
(memq (first form) (map first value-primitives))))
|
||||
|
|
@ -91,43 +136,44 @@
|
|||
(define (bind-form? form)
|
||||
(and (pair? form) (eq? (first form) '%bind)))
|
||||
|
||||
(define (map-form form
|
||||
(define (traverse-form form
|
||||
#:bind [bind-fn (lambda (recurse op vars . subforms)
|
||||
`(,op ,vars ,@(map recurse subforms)))]
|
||||
(for ([subform (in-list subforms)])
|
||||
(recurse subform)))]
|
||||
#: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)))]
|
||||
|
||||
(recurse bind))]
|
||||
#:set [set-fn (lambda (recurse op var value-form)
|
||||
(recurse value-form))]
|
||||
#:value-list [value-list-fn (lambda (recurse op values-form)
|
||||
(recurse values-form))]
|
||||
#:primitive [primitive-fn (lambda (recurse op . simple-values)
|
||||
`(,op ,@(map recurse simple-values)))]
|
||||
(for ([val (in-list simple-values)])
|
||||
(recurse val)))]
|
||||
#:simple [simple-fn (lambda (recurse kind simple-value) (void))]
|
||||
#:other [other-fn (lambda (recurse . form)
|
||||
(error "Unsimplified form:" form))]
|
||||
#:values [values-fn primitive-fn]
|
||||
#: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))])
|
||||
#:apply [apply-fn call-fn]
|
||||
#:call/cc [call/cc-fn call-fn]
|
||||
#:tail-call [tail-call-fn call-fn])
|
||||
(define (recurse subform)
|
||||
(map-form subform
|
||||
; Can skip #:primitive, #:call, and #:simple, which only set defaults.
|
||||
(traverse-form subform
|
||||
#:bind bind-fn
|
||||
#:lambda lambda-fn
|
||||
#:set set-fn
|
||||
#:value-list value-list-fn
|
||||
#:primitive primitive-fn
|
||||
#:other other-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))
|
||||
#:apply apply-fn
|
||||
#:call/cc call/cc-fn
|
||||
#:tail-call tail-call-fn))
|
||||
|
||||
(cond
|
||||
[(variable-value? form) (variable-fn recurse 'variable form)]
|
||||
|
|
@ -137,6 +183,7 @@
|
|||
[(%bind) bind-fn]
|
||||
[(%lambda) lambda-fn]
|
||||
[(%set!) set-fn]
|
||||
[(%value-list) value-list-fn]
|
||||
[(%values) values-fn]
|
||||
[(%apply) apply-fn]
|
||||
[(%call/cc) call/cc-fn]
|
||||
|
|
@ -146,45 +193,34 @@
|
|||
other-fn)])])
|
||||
(apply handler recurse form))]))
|
||||
|
||||
; Like map-form, but intended for boolean results. (Just different defaults.)
|
||||
(define (search-form form
|
||||
#:merge-with [merge-fn ormap]
|
||||
#:base-value [base-value #f]
|
||||
#:bind [bind-fn (lambda (recurse op vars . subforms)
|
||||
(merge-fn recurse subforms))]
|
||||
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
|
||||
(recurse bind))]
|
||||
#:set [set-fn (lambda (recurse op var value)
|
||||
(recurse value))]
|
||||
(define map-form
|
||||
(curry-keywords traverse-form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
`(,op ,vars ,@(map recurse subforms)))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
`(,op ,g-vars ,i-vars ,(recurse bind)))
|
||||
#:set (lambda (recurse op var value-form)
|
||||
`(,op ,var ,(recurse value-form)))
|
||||
#:value-list (lambda (recurse op values-form)
|
||||
`(,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)
|
||||
(merge-fn recurse simple-values))]
|
||||
#:values [values-fn primitive-fn]
|
||||
#:call [call-fn primitive-fn]
|
||||
#:apply [apply-fn call-fn]
|
||||
#:call/cc [call/cc-fn call-fn]
|
||||
#:tail-call [tail-call-fn call-fn]
|
||||
|
||||
#:simple [simple-fn (lambda (recurse kind form) base-value)]
|
||||
#:variable [variable-fn simple-fn]
|
||||
#:literal [literal-fn simple-fn]
|
||||
|
||||
#:other [other-fn (lambda (recurse . form)
|
||||
(error "Unsimplified form:" form))])
|
||||
(map-form form
|
||||
#:bind bind-fn
|
||||
#:lambda lambda-fn
|
||||
#:set set-fn
|
||||
#:primitive primitive-fn
|
||||
#: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))
|
||||
; Like map-form, but intended for boolean results.
|
||||
(define search-form
|
||||
(curry-keywords traverse-form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
(ormap recurse subforms))
|
||||
#:lambda (lambda (recurse op g-vars i-vars bind)
|
||||
(recurse bind))
|
||||
#:set (lambda (recurse op var value)
|
||||
(recurse value))
|
||||
#:value-list (lambda (recurse op var values-form)
|
||||
(recurse values-form))
|
||||
#:primitive (lambda (recurse op . simple-values)
|
||||
(ormap recurse simple-values))
|
||||
#:simple (lambda (recurse kind form) #f)))
|
||||
|
||||
(define (form-sets? form variable [call-may-set? #t])
|
||||
(search-form form
|
||||
|
|
@ -192,17 +228,17 @@
|
|||
(and (not (memq variable vars))
|
||||
(ormap recurse subforms)))
|
||||
#:lambda (lambda _ #f)
|
||||
#:set (lambda (recurse op var complex-value)
|
||||
(eq? var variable))
|
||||
#:set (lambda (recurse op var value-form)
|
||||
(or (eq? var variable)
|
||||
(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
|
||||
#: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)))
|
||||
#:lambda (lambda (recurse . form) #f)
|
||||
#:call (lambda (recurse op . simple-values)
|
||||
(or call-may-use? (ormap recurse simple-values)))
|
||||
#:variable (lambda (recurse op var) (eq? var variable))))
|
||||
|
|
@ -224,7 +260,8 @@
|
|||
(define (value-used? variable forms)
|
||||
(cond
|
||||
[(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]
|
||||
[else (value-used? variable (cdr forms))]))
|
||||
|
||||
|
|
@ -237,51 +274,16 @@
|
|||
#:variable (lambda (recurse op var)
|
||||
(if (eq? var old-var) new-var var))))
|
||||
|
||||
(define (narrow-binds 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))))
|
||||
|
||||
(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 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 (subst-var* var-map form)
|
||||
(map-form form
|
||||
#:bind (lambda (recurse op vars . subforms)
|
||||
`(%bind ,(subst* var-map vars) ,@(map recurse subforms)))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([item (assoc var var-map)])
|
||||
`(,op ,(if item (second item) var) ,(recurse value))))
|
||||
#:variable (lambda (recurse op var)
|
||||
(let ([item (assoc var var-map)])
|
||||
(if item (second item) var)))))
|
||||
|
||||
(define (flatten-binds form)
|
||||
(define (make-bindings-unique bind rename-vars)
|
||||
|
|
@ -311,23 +313,22 @@
|
|||
#:lambda (lambda (recurse . form) form)))
|
||||
|
||||
(define (free-variables form [input? #t] [output? #t])
|
||||
(map-form form
|
||||
(define (append-map/unique fn . lsts)
|
||||
(remove-duplicates (apply append-map fn lsts)))
|
||||
(traverse-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))
|
||||
(remove* vars (append-map/unique recurse subforms)))
|
||||
#:set (lambda (recurse op var value)
|
||||
(let ([value-free (recurse value)])
|
||||
(if output?
|
||||
(if (and output? (not (memq var value-free)))
|
||||
(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?
|
||||
(variable-value? form)
|
||||
(not (memq form '(%nil %self %argv %ctx %k))))
|
||||
(list form)
|
||||
(append-map/unique recurse simple-values))
|
||||
#:simple (lambda (recurse kind form) '())
|
||||
#:variable (lambda (recurse kind var)
|
||||
(if (and input? (not (special-variable? var)))
|
||||
(list var)
|
||||
'()))))
|
||||
|
||||
(define (free-input-variables form)
|
||||
|
|
|
|||
|
|
@ -195,3 +195,5 @@
|
|||
(variable->code (third form))
|
||||
(variable->code (fourth form)))]
|
||||
[else (error "Unsupported form:" form)])))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
Loading…
Reference in New Issue