Reimplement map-variables to handle captured variables properly.
This commit is contained in:
parent
ded5b4851d
commit
da3b000312
|
|
@ -6,66 +6,105 @@
|
|||
|
||||
(provide map-variables)
|
||||
|
||||
(define (map-variables lambda/template-form)
|
||||
(define (special-constant? sym)
|
||||
(memq sym '(#%f #%nil #%undef)))
|
||||
|
||||
(define (lambda-value? form)
|
||||
(and (pair? form) (eq? (first form) '#%lambda)))
|
||||
|
||||
(define (lookup fst lst)
|
||||
(ormap (lambda (x)
|
||||
(and (eq? (first x) fst)
|
||||
(second x)))
|
||||
lst))
|
||||
|
||||
(define (from-list lst (end-fn (lambda () #f)))
|
||||
(lambda ()
|
||||
(if (pair? lst)
|
||||
(let ([next (first lst)])
|
||||
(set! lst (cdr lst))
|
||||
next)
|
||||
(end-fn))))
|
||||
|
||||
(define (map-variables lambda/template-form (capture-map '()))
|
||||
(let ([bind (fourth lambda/template-form)]
|
||||
[g-vars '()]
|
||||
[unused-g-vars global-variables]
|
||||
[i-vars '()])
|
||||
[next-g-var (from-list global-variables)]
|
||||
[next-i-var (from-list instance-variables)]
|
||||
[next-t-var (from-list transient-variables)]
|
||||
[gvar-map '()]
|
||||
[ivar-map '()]
|
||||
[var-map '()])
|
||||
|
||||
(define (add-g-var value)
|
||||
(cond
|
||||
[(special-constant? value) value]
|
||||
[(or (eq? value #f) (equal? value '(quote #f))) '#%f]
|
||||
[(equal? value '(quote ())) '#%nil]
|
||||
[else (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
|
||||
[(symbol? value) `(#%builtin ,(symbol->string value))]
|
||||
[else value])])
|
||||
(let/cc return
|
||||
(for ([g-var (in-list global-variables)]
|
||||
[val (in-list g-vars)])
|
||||
(when (eq? value val) (return g-var)))
|
||||
(let ([g-var (first unused-g-vars)])
|
||||
(set! unused-g-vars (cdr unused-g-vars))
|
||||
(set! g-vars (append g-vars (list value)))
|
||||
g-var)))]))
|
||||
[else
|
||||
(let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
|
||||
[(symbol? value) `(#%builtin ,(symbol->string value))]
|
||||
[else value])])
|
||||
(or (lookup value gvar-map)
|
||||
(let ([g-var (next-g-var)])
|
||||
(set! gvar-map (cons (list value g-var) gvar-map))
|
||||
g-var)))]))
|
||||
|
||||
(let* ([free-vars (filter transient/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)))
|
||||
(list free-var inst-var))])
|
||||
(define (sv* form) (subst-var* var-map form))
|
||||
(set! bind `(#%bind ,(subst* var-map (second bind))
|
||||
,@(map sv* (cddr bind)))))
|
||||
(define (add-i-var source)
|
||||
(or (and (special-constant? source) source)
|
||||
(lookup source ivar-map)
|
||||
(let ([i-var (next-i-var)])
|
||||
(set! ivar-map (cons (list source i-var) ivar-map))
|
||||
i-var)))
|
||||
|
||||
(let* ([var-map (map (lambda (v) (list v '#%undef)) (second bind))]
|
||||
[exprs (for/list ([expr (in-list (cddr bind))]
|
||||
[tvar (in-list transient-variables)])
|
||||
(if (and (pair? expr) (eq? (first expr) '#%set!))
|
||||
(let ([var (second expr)]
|
||||
[newexpr `(#%set! ,tvar ,(subst-var* var-map (third expr)))])
|
||||
(set! var-map (map (lambda (vm)
|
||||
(if (eq? (first vm) var)
|
||||
(list var tvar)
|
||||
vm))
|
||||
var-map))
|
||||
(when (simple-value? (third newexpr))
|
||||
(set! newexpr `(#%set! ,tvar (#%if #%f #%undef ,(third newexpr)))))
|
||||
newexpr)
|
||||
`(#%set! ,tvar ,(subst-var* var-map expr))))])
|
||||
(set! bind `(#%bind ,(for/list ([s (in-list (cddr bind))]
|
||||
[v (in-list transient-variables)])
|
||||
v)
|
||||
,@exprs)))
|
||||
(let ([exprs '()])
|
||||
(define (add-var var mvar)
|
||||
(when var
|
||||
(set! var-map
|
||||
(cons (list var mvar)
|
||||
(filter (lambda (x) (not (eq? (first x) var)))
|
||||
var-map)))))
|
||||
|
||||
(set! bind (map-form bind
|
||||
#:lambda (lambda (recurse op inner-g-vars i-vars bind)
|
||||
`(#%make-lambda ,((compose add-g-var map-variables)
|
||||
`(#%template ,inner-g-vars ,i-vars ,bind))))
|
||||
#:variable (lambda (recurse kind form)
|
||||
(if (machine-variable? form) form (add-g-var form)))
|
||||
#:literal (lambda (recurse kind form)
|
||||
(if (eq? form '%nil) form (add-g-var form)))))
|
||||
(define (add-expr var val)
|
||||
(let ([tvar (next-t-var)])
|
||||
(set! exprs (cons `(#%set! ,tvar ,val) exprs))
|
||||
(add-var var tvar)))
|
||||
|
||||
`(,(if (null? i-vars) '#%lambda '#%template) ,g-vars ,i-vars
|
||||
(for ([bound-var (in-list (second bind))])
|
||||
(add-var bound-var '#%undef))
|
||||
|
||||
(for ([free-var (in-list (free-variables bind))])
|
||||
(let ([capt (lookup free-var capture-map)])
|
||||
(when capt (add-var free-var (add-i-var capt)))))
|
||||
|
||||
(for ([expr (in-list (cddr bind))])
|
||||
(let* ([setexpr? (and (pair? expr) (eq? (first expr) '#%set!))]
|
||||
[var (if setexpr? (second expr) #f)]
|
||||
[val (if setexpr? (third expr) expr)])
|
||||
(cond [(lambda-value? val)
|
||||
(let ([newval (map-variables val var-map)])
|
||||
(if (eq? (first newval) '#%lambda)
|
||||
(add-var var (add-g-var newval))
|
||||
(add-expr var `(#%make-lambda ,(add-g-var newval)))))]
|
||||
[(literal-value? val)
|
||||
(add-var var (add-g-var val))]
|
||||
[(not (symbol? val))
|
||||
(add-expr var (map-form val
|
||||
#:variable (lambda (recurse kind form)
|
||||
(or (and (machine-variable? form) form)
|
||||
(lookup form var-map)
|
||||
(add-g-var form)))
|
||||
#:literal (lambda (recurse kind form)
|
||||
(add-g-var form))))]
|
||||
[else
|
||||
(add-var var (or (and (machine-variable? val) val)
|
||||
(lookup val var-map)
|
||||
(add-g-var val)))])))
|
||||
|
||||
(set! bind `(#%bind () ,@(reverse exprs))))
|
||||
|
||||
`(,(if (null? ivar-map) '#%lambda '#%template)
|
||||
,(map first (reverse gvar-map))
|
||||
,(map first (reverse ivar-map))
|
||||
,bind)))
|
||||
|
||||
; vim:set sw=2 expandtab:
|
||||
|
|
|
|||
Loading…
Reference in New Issue