From da3b00031287625cf3913025b56fc6ea971040ee Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Mon, 25 Apr 2011 13:58:28 -0500 Subject: [PATCH] Reimplement map-variables to handle captured variables properly. --- libcompiler/mapper.scm | 141 ++++++++++++++++++++++++++--------------- 1 file changed, 90 insertions(+), 51 deletions(-) diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm index 2ca95c1..9edc985 100644 --- a/libcompiler/mapper.scm +++ b/libcompiler/mapper.scm @@ -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: