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

Reimplement map-variables to handle captured variables properly.

This commit is contained in:
Jesse D. McDonald 2011-04-25 13:58:28 -05:00
parent ded5b4851d
commit da3b000312
1 changed files with 90 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
libcompiler/mapper.scm
View File

@ -6,66 +6,105 @@
(provide map-variables) (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)] (let ([bind (fourth lambda/template-form)]
[g-vars '()] [next-g-var (from-list global-variables)]
[unused-g-vars global-variables] [next-i-var (from-list instance-variables)]
[i-vars '()]) [next-t-var (from-list transient-variables)]
[gvar-map '()]
[ivar-map '()]
[var-map '()])
(define (add-g-var value) (define (add-g-var value)
(cond (cond
[(special-constant? value) value]
[(or (eq? value #f) (equal? value '(quote #f))) '#%f] [(or (eq? value #f) (equal? value '(quote #f))) '#%f]
[(equal? value '(quote ())) '#%nil] [(equal? value '(quote ())) '#%nil]
[else (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] [else
(let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
[(symbol? value) `(#%builtin ,(symbol->string value))] [(symbol? value) `(#%builtin ,(symbol->string value))]
[else value])]) [else value])])
(let/cc return (or (lookup value gvar-map)
(for ([g-var (in-list global-variables)] (let ([g-var (next-g-var)])
[val (in-list g-vars)]) (set! gvar-map (cons (list value g-var) gvar-map))
(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)))])) g-var)))]))
(let* ([free-vars (filter transient/instance-variable? (free-variables bind))] (define (add-i-var source)
[var-map (for/list ([free-var (in-list free-vars)] (or (and (special-constant? source) source)
[inst-var (in-list instance-variables)]) (lookup source ivar-map)
(set! i-vars (append i-vars (list free-var))) (let ([i-var (next-i-var)])
(list free-var inst-var))]) (set! ivar-map (cons (list source i-var) ivar-map))
(define (sv* form) (subst-var* var-map form)) i-var)))
(set! bind `(#%bind ,(subst* var-map (second bind))
,@(map sv* (cddr bind)))))
(let* ([var-map (map (lambda (v) (list v '#%undef)) (second bind))] (let ([exprs '()])
[exprs (for/list ([expr (in-list (cddr bind))] (define (add-var var mvar)
[tvar (in-list transient-variables)]) (when var
(if (and (pair? expr) (eq? (first expr) '#%set!)) (set! var-map
(let ([var (second expr)] (cons (list var mvar)
[newexpr `(#%set! ,tvar ,(subst-var* var-map (third expr)))]) (filter (lambda (x) (not (eq? (first x) var)))
(set! var-map (map (lambda (vm) var-map)))))
(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)))
(set! bind (map-form bind (define (add-expr var val)
#:lambda (lambda (recurse op inner-g-vars i-vars bind) (let ([tvar (next-t-var)])
`(#%make-lambda ,((compose add-g-var map-variables) (set! exprs (cons `(#%set! ,tvar ,val) exprs))
`(#%template ,inner-g-vars ,i-vars ,bind)))) (add-var var tvar)))
(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) #:variable (lambda (recurse kind form)
(if (machine-variable? form) form (add-g-var form))) (or (and (machine-variable? form) form)
(lookup form var-map)
(add-g-var form)))
#:literal (lambda (recurse kind form) #:literal (lambda (recurse kind form)
(if (eq? form '%nil) form (add-g-var form))))) (add-g-var form))))]
[else
(add-var var (or (and (machine-variable? val) val)
(lookup val var-map)
(add-g-var val)))])))
`(,(if (null? i-vars) '#%lambda '#%template) ,g-vars ,i-vars (set! bind `(#%bind () ,@(reverse exprs))))
`(,(if (null? ivar-map) '#%lambda '#%template)
,(map first (reverse gvar-map))
,(map first (reverse ivar-map))
,bind))) ,bind)))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab: