diff options
author | Andy Wingo <wingo@pobox.com> | 2010-05-02 11:22:23 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-05-02 11:22:23 +0200 |
commit | 93f63467e6e9d2f0203fd1c54a98539f5fefeba0 (patch) | |
tree | 759c50cfebaf6a64f48167e2ad7bd7f11e730c44 | |
parent | 915aca30baccaf646752d84f11d4e461ca24391a (diff) | |
download | guile-93f63467e6e9d2f0203fd1c54a98539f5fefeba0.tar.gz |
rename `vars' field in tree-il binding constructs to `gensyms'
* module/language/tree-il.scm (<tree-il>): Rename `vars' fields of
<let>, <letrec>, <fix>, and <lambda-case> to `gensyms'. For clarity,
and to match <lexical-ref>.
* module/language/tree-il.scm:
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm: Update all callers.
-rw-r--r-- | module/language/tree-il.scm | 74 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 150 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 92 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 80 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 36 |
5 files changed, 216 insertions, 216 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 8daf49a19..bec3bec92 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -39,11 +39,11 @@ <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body <lambda-case> lambda-case? make-lambda-case lambda-case-src lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw - lambda-case-inits lambda-case-vars + lambda-case-inits lambda-case-gensyms lambda-case-body lambda-case-alternate - <let> let? make-let let-src let-names let-vars let-vals let-body - <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body - <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body + <let> let? make-let let-src let-names let-gensyms let-vals let-body + <letrec> letrec? make-letrec letrec-src letrec-names letrec-gensyms letrec-vals letrec-body + <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body @@ -76,10 +76,10 @@ (<application> proc args) (<sequence> exps) (<lambda> meta body) - (<lambda-case> req opt rest kw inits vars body alternate) - (<let> names vars vals body) - (<letrec> names vars vals body) - (<fix> names vars vals body) + (<lambda-case> req opt rest kw inits gensyms body alternate) + (<let> names gensyms vals body) + (<letrec> names gensyms vals body) + (<fix> names gensyms vals body) (<let-values> exp body) (<dynwind> winder body unwinder) (<dynlet> fluids vals body) @@ -147,15 +147,15 @@ ((lambda ,meta ,body) (make-lambda loc meta (retrans body))) - ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate) + ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate) (make-lambda-case loc req opt rest kw - (map retrans inits) vars + (map retrans inits) gensyms (retrans body) (and=> alternate retrans))) - ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body)) + ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body)) (make-lambda-case loc req opt rest kw - (map retrans inits) vars + (map retrans inits) gensyms (retrans body) #f)) @@ -165,14 +165,14 @@ ((begin . ,exps) (make-sequence loc (map retrans exps))) - ((let ,names ,vars ,vals ,body) - (make-let loc names vars (map retrans vals) (retrans body))) + ((let ,names ,gensyms ,vals ,body) + (make-let loc names gensyms (map retrans vals) (retrans body))) - ((letrec ,names ,vars ,vals ,body) - (make-letrec loc names vars (map retrans vals) (retrans body))) + ((letrec ,names ,gensyms ,vals ,body) + (make-letrec loc names gensyms (map retrans vals) (retrans body))) - ((fix ,names ,vars ,vals ,body) - (make-fix loc names vars (map retrans vals) (retrans body))) + ((fix ,names ,gensyms ,vals ,body) + (make-fix loc names gensyms (map retrans vals) (retrans body))) ((let-values ,exp ,body) (make-let-values loc (retrans exp) (retrans body))) @@ -236,8 +236,8 @@ ((<lambda> meta body) `(lambda ,meta ,(unparse-tree-il body))) - ((<lambda-case> req opt rest kw inits vars body alternate) - `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars) + ((<lambda-case> req opt rest kw inits gensyms body alternate) + `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) ,(unparse-tree-il body)) . ,(if alternate (list (unparse-tree-il alternate)) '()))) @@ -247,14 +247,14 @@ ((<sequence> exps) `(begin ,@(map unparse-tree-il exps))) - ((<let> names vars vals body) - `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<let> names gensyms vals body) + `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) - ((<letrec> names vars vals body) - `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<letrec> names gensyms vals body) + `(letrec ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) - ((<fix> names vars vals body) - `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<fix> names gensyms vals body) + `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) ((<let-values> exp body) `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) @@ -324,9 +324,9 @@ `(lambda ,@(car (tree-il->scheme body))) `(case-lambda ,@(tree-il->scheme body)))) - ((<lambda-case> req opt rest kw inits vars body alternate) + ((<lambda-case> req opt rest kw inits gensyms body alternate) ;; FIXME! use parse-lambda-case? - `((,(if rest (apply cons* vars) vars) + `((,(if rest (apply cons* gensyms) gensyms) ,(tree-il->scheme body)) ,@(if alternate (tree-il->scheme alternate) '()))) @@ -338,15 +338,15 @@ ((<sequence> exps) `(begin ,@(map tree-il->scheme exps))) - ((<let> vars vals body) - `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + ((<let> gensyms vals body) + `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - ((<letrec> vars vals body) - `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + ((<letrec> gensyms vals body) + `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) - ((<fix> vars vals body) + ((<fix> gensyms vals body) ;; not a typo, we really do translate back to letrec - `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) + `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) ((<let-values> exp body) `(call-with-values (lambda () ,(tree-il->scheme exp)) @@ -564,15 +564,15 @@ This is an implementation of `foldts' as described by Andy Wingo in ((<sequence> exps) (set! (sequence-exps x) (map lp exps))) - ((<let> vars vals body) + ((<let> gensyms vals body) (set! (let-vals x) (map lp vals)) (set! (let-body x) (lp body))) - ((<letrec> vars vals body) + ((<letrec> gensyms vals body) (set! (letrec-vals x) (map lp vals)) (set! (letrec-body x) (lp body))) - ((<fix> vars vals body) + ((<fix> gensyms vals body) (set! (fix-vals x) (map lp vals)) (set! (fix-body x) (lp body))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index bc56a7d77..0bf6b9c75 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -235,39 +235,39 @@ (hashq-set! free-vars x free) free)) - ((<lambda-case> opt kw inits vars body alternate) + ((<lambda-case> opt kw inits gensyms body alternate) (hashq-set! bound-vars proc - (append (reverse vars) (hashq-ref bound-vars proc))) + (append (reverse gensyms) (hashq-ref bound-vars proc))) (lset-union eq? (lset-difference eq? (lset-union eq? (apply lset-union eq? (map step inits)) (step-tail body)) - vars) + gensyms) (if alternate (step-tail alternate) '()))) - ((<let> vars vals body) + ((<let> gensyms vals body) (hashq-set! bound-vars proc - (append (reverse vars) (hashq-ref bound-vars proc))) + (append (reverse gensyms) (hashq-ref bound-vars proc))) (lset-difference eq? (apply lset-union eq? (step-tail body) (map step vals)) - vars)) + gensyms)) - ((<letrec> vars vals body) + ((<letrec> gensyms vals body) (hashq-set! bound-vars proc - (append (reverse vars) (hashq-ref bound-vars proc))) - (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) + (append (reverse gensyms) (hashq-ref bound-vars proc))) + (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms) (lset-difference eq? (apply lset-union eq? (step-tail body) (map step vals)) - vars)) + gensyms)) - ((<fix> vars vals body) + ((<fix> gensyms vals body) ;; Try to allocate these procedures as labels. (for-each (lambda (sym val) (hashq-set! labels sym val)) - vars vals) + gensyms vals) (hashq-set! bound-vars proc - (append (reverse vars) (hashq-ref bound-vars proc))) + (append (reverse gensyms) (hashq-ref bound-vars proc))) ;; Step into subexpressions. (let* ((var-refs (map @@ -282,13 +282,13 @@ ;; just like the closure case, except here we use ;; recur/labels instead of recur (hashq-set! bound-vars x '()) - (let ((free (recur/labels body x vars))) + (let ((free (recur/labels body x gensyms))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) free)))) vals)) - (vars-with-refs (map cons vars var-refs)) - (body-refs (recur/labels body proc vars))) + (vars-with-refs (map cons gensyms var-refs)) + (body-refs (recur/labels body proc gensyms))) (define (delabel-dependents! sym) (let ((refs (assq-ref vars-with-refs sym))) (if refs @@ -314,7 +314,7 @@ (for-each (lambda (sym) (if (not (hashq-ref labels sym)) (delabel-dependents! sym))) - vars) + gensyms) ;; Now lift bound variables with label-allocated lambdas to the ;; parent procedure. (for-each @@ -328,10 +328,10 @@ (hashq-ref bound-vars proc))) (hashq-remove! bound-vars val) (hashq-remove! free-vars val)))) - vars vals) + gensyms vals) (lset-difference eq? (apply lset-union eq? body-refs var-refs) - vars))) + gensyms))) ((<let-values> exp body) (lset-union eq? (step exp) (step body))) @@ -407,10 +407,10 @@ (hashq-set! allocation x (cons labels free-addresses))) n) - ((<lambda-case> opt kw inits vars body alternate) + ((<lambda-case> opt kw inits gensyms body alternate) (max - (let lp ((vars vars) (n n)) - (if (null? vars) + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) (let ((nlocs (apply max (allocate! body proc n) @@ -421,72 +421,72 @@ (hashq-set! allocation x (cons (gensym ":LCASE") nlocs)) nlocs) (begin - (hashq-set! allocation (car vars) + (hashq-set! allocation (car gensyms) (make-hashq - proc `(#t ,(hashq-ref assigned (car vars)) . ,n))) - (lp (cdr vars) (1+ n))))) + proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n))) + (lp (cdr gensyms) (1+ n))))) (if alternate (allocate! alternate proc n) n))) - ((<let> vars vals body) + ((<let> gensyms vals body) (let ((nmax (apply max (map recur vals)))) (cond ;; the `or' hack ((and (conditional? body) - (= (length vars) 1) - (let ((v (car vars))) + (= (length gensyms) 1) + (let ((v (car gensyms))) (and (not (hashq-ref assigned v)) (= (hashq-ref refcounts v 0) 2) (lexical-ref? (conditional-test body)) (eq? (lexical-ref-gensym (conditional-test body)) v) (lexical-ref? (conditional-consequent body)) (eq? (lexical-ref-gensym (conditional-consequent body)) v)))) - (hashq-set! allocation (car vars) + (hashq-set! allocation (car gensyms) (make-hashq proc `(#t #f . ,n))) ;; the 1+ for this var (max nmax (1+ n) (allocate! (conditional-alternate body) proc n))) (else - (let lp ((vars vars) (n n)) - (if (null? vars) + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) (max nmax (allocate! body proc n)) - (let ((v (car vars))) + (let ((v (car gensyms))) (hashq-set! allocation v (make-hashq proc `(#t ,(hashq-ref assigned v) . ,n))) - (lp (cdr vars) (1+ n))))))))) + (lp (cdr gensyms) (1+ n))))))))) - ((<letrec> vars vals body) - (let lp ((vars vars) (n n)) - (if (null? vars) + ((<letrec> gensyms vals body) + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) (let ((nmax (apply max (map (lambda (x) (allocate! x proc n)) vals)))) (max nmax (allocate! body proc n))) - (let ((v (car vars))) + (let ((v (car gensyms))) (hashq-set! allocation v (make-hashq proc `(#t ,(hashq-ref assigned v) . ,n))) - (lp (cdr vars) (1+ n)))))) + (lp (cdr gensyms) (1+ n)))))) - ((<fix> vars vals body) - (let lp ((in vars) (n n)) + ((<fix> gensyms vals body) + (let lp ((in gensyms) (n n)) (if (null? in) - (let lp ((vars vars) (vals vals) (nmax n)) + (let lp ((gensyms gensyms) (vals vals) (nmax n)) (cond - ((null? vars) + ((null? gensyms) (max nmax (allocate! body proc n))) - ((hashq-ref labels (car vars)) + ((hashq-ref labels (car gensyms)) ;; allocate lambda body inline to proc - (lp (cdr vars) + (lp (cdr gensyms) (cdr vals) (record-case (car vals) ((<lambda> body) (max nmax (allocate! body proc n)))))) (else ;; allocate closure - (lp (cdr vars) + (lp (cdr gensyms) (cdr vals) (max nmax (allocate! (car vals) proc n)))))) @@ -519,8 +519,8 @@ ((<prompt> tag body handler) (let ((cont-var (and (lambda-case? handler) - (pair? (lambda-case-vars handler)) - (car (lambda-case-vars handler))))) + (pair? (lambda-case-gensyms handler)) + (car (lambda-case-gensyms handler))))) (hashq-set! allocation x (and cont-var (zero? (hashq-ref refcounts cont-var 0)))) (max (recur tag) (recur body) (recur handler)))) @@ -629,18 +629,18 @@ accurate information is missing from a given `tree-il' element." (record-case x ((<lexical-set> gensym) (make-binding-info vars (vhash-consq gensym #t refs))) - ((<lambda-case> req opt inits rest kw vars) + ((<lambda-case> req opt inits rest kw gensyms) (let ((names `(,@req ,@(or opt '()) ,@(if rest (list rest) '()) ,@(if kw (map cadr (cdr kw)) '())))) - (make-binding-info (extend vars names) refs))) - ((<let> vars names) - (make-binding-info (extend vars names) refs)) - ((<letrec> vars names) - (make-binding-info (extend vars names) refs)) - ((<fix> vars names) - (make-binding-info (extend vars names) refs)) + (make-binding-info (extend gensyms names) refs))) + ((<let> gensyms names) + (make-binding-info (extend gensyms names) refs)) + ((<letrec> gensyms names) + (make-binding-info (extend gensyms names) refs)) + ((<fix> gensyms names) + (make-binding-info (extend gensyms names) refs)) (else info)))) (lambda (x info env locs) @@ -670,14 +670,14 @@ accurate information is missing from a given `tree-il' element." ;; It doesn't hurt as these are unique names, it just ;; makes REFS unnecessarily fat. (record-case x - ((<lambda-case> vars) - (make-binding-info (shrink vars refs) refs)) - ((<let> vars) - (make-binding-info (shrink vars refs) refs)) - ((<letrec> vars) - (make-binding-info (shrink vars refs) refs)) - ((<fix> vars) - (make-binding-info (shrink vars refs) refs)) + ((<lambda-case> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<let> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<letrec> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<fix> gensyms) + (make-binding-info (shrink gensyms refs) refs)) (else info)))) (lambda (result env) #t) @@ -1106,12 +1106,12 @@ accurate information is missing from a given `tree-il' element." exp) toplevel-lambdas)))) (else info))) - ((<let> vars vals) - (fold extend info vars vals)) - ((<letrec> vars vals) - (fold extend info vars vals)) - ((<fix> vars vals) - (fold extend info vars vals)) + ((<let> gensyms vals) + (fold extend info gensyms vals)) + ((<letrec> gensyms vals) + (fold extend info gensyms vals)) + ((<fix> gensyms vals) + (fold extend info gensyms vals)) ((<application> proc args src) (record-case proc @@ -1158,12 +1158,12 @@ accurate information is missing from a given `tree-il' element." (lexical-lambdas (lexical-lambdas info)) (toplevel-lambdas (toplevel-lambdas info))) (record-case x - ((<let> vars vals) - (fold shrink info vars vals)) - ((<letrec> vars vals) - (fold shrink info vars vals)) - ((<fix> vars vals) - (fold shrink info vars vals)) + ((<let> gensyms vals) + (fold shrink info gensyms vals)) + ((<letrec> gensyms vals) + (fold shrink info gensyms vals)) + ((<fix> gensyms vals) + (fold shrink info gensyms vals)) (else info)))) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index a07ad669f..10b06b8d8 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -428,7 +428,7 @@ ;; new box (emit-code #f (make-glil-lexical #t #t 'box index))) (,x (error "what" x)))) - (reverse (lambda-case-vars lcase))) + (reverse (lambda-case-gensyms lcase))) (emit-branch src 'br (car (hashq-ref allocation lcase)))) ((lambda-case? lcase) ;; no match, try next case @@ -465,7 +465,7 @@ ((#t #t . ,index) ; boxed (emit-code #f (make-glil-lexical #t #t 'box index))) (,x (error "what" x)))) - (reverse (lambda-case-vars lcase))) + (reverse (lambda-case-gensyms lcase))) (emit-branch src 'br (car (hashq-ref allocation lcase)))) ((lambda-case? lcase) ;; no match, try next case @@ -669,15 +669,15 @@ (length free-locs)))))))) (maybe-emit-return)) - ((<lambda-case> src req opt rest kw inits vars alternate body) + ((<lambda-case> src req opt rest kw inits gensyms alternate body) ;; o/~ feature on top of feature o/~ ;; req := (name ...) ;; opt := (name ...) | #f ;; rest := name | #f ;; kw: (allow-other-keys? (keyword name var) ...) | #f - ;; vars: (sym ...) - ;; init: tree-il in context of vars - ;; vars map to named arguments in the following order: + ;; gensyms: (sym ...) + ;; init: tree-il in context of gensyms + ;; gensyms map to named arguments in the following order: ;; required, optional (positional), rest, keyword. (let* ((nreq (length req)) (nopt (if opt (length opt) 0)) @@ -687,7 +687,7 @@ (kw-indices (map (lambda (x) (pmatch x ((,key ,name ,var) - (cons key (list-index vars var))) + (cons key (list-index gensyms var))) (else (error "bad kwarg" x)))) (if kw (cdr kw) '()))) (nargs (apply max (+ nreq nopt (if rest 1 0)) @@ -695,10 +695,10 @@ (nlocs (cdr (hashq-ref allocation x))) (alternate-label (and alternate (make-label)))) (or (= nargs - (length vars) + (length gensyms) (+ nreq (length inits) (if rest 1 0))) (error "something went wrong" - req opt rest kw inits vars nreq nopt kw-indices nargs)) + req opt rest kw inits gensyms nreq nopt kw-indices nargs)) ;; the prelude, to check args & reset the stack pointer, ;; allowing room for locals (emit-code @@ -718,33 +718,33 @@ ((#t #t . ,n) (emit-code #f (make-glil-lexical #t #f 'ref n)) (emit-code #f (make-glil-lexical #t #t 'box n))))) - vars) + gensyms) ;; write bindings info - (if (not (null? vars)) + (if (not (null? gensyms)) (emit-bindings #f (let lp ((kw (if kw (cdr kw) '())) (names (append (reverse opt-names) (reverse req))) - (vars (list-tail vars (+ nreq nopt + (gensyms (list-tail gensyms (+ nreq nopt (if rest 1 0))))) (pmatch kw (() - ;; fixme: check that vars is empty + ;; fixme: check that gensyms is empty (reverse (if rest (cons rest names) names))) (((,key ,name ,var) . ,kw) - (if (memq var vars) - (lp kw (cons name names) (delq var vars)) - (lp kw names vars))) + (if (memq var gensyms) + (lp kw (cons name names) (delq var gensyms)) + (lp kw names gensyms))) (,kw (error "bad keywords, yo" kw)))) - vars allocation self emit-code)) + gensyms allocation self emit-code)) ;; init optional/kw args - (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq))) + (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq))) (cond ((null? inits)) ; done ((and rest-idx (= n rest-idx)) - (lp inits (1+ n) (cdr vars))) + (lp inits (1+ n) (cdr gensyms))) (#t - (pmatch (hashq-ref (hashq-ref allocation (car vars)) self) + (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self) ((#t ,boxed? . ,n*) (guard (= n* n)) (let ((L (make-label))) (emit-code #f (make-glil-lexical #t boxed? 'bound? n)) @@ -752,21 +752,21 @@ (comp-push (car inits)) (emit-code #f (make-glil-lexical #t boxed? 'set n)) (emit-label L) - (lp (cdr inits) (1+ n) (cdr vars)))) + (lp (cdr inits) (1+ n) (cdr gensyms)))) (#t (error "what" inits)))))) ;; post-prelude case label for label calls (emit-label (car (hashq-ref allocation x))) (comp-tail body) - (if (not (null? vars)) + (if (not (null? gensyms)) (emit-code #f (make-glil-unbind))) (if alternate-label (begin (emit-label alternate-label) (comp-tail alternate))))) - ((<let> src names vars vals body) + ((<let> src names gensyms vals body) (for-each comp-push vals) - (emit-bindings src names vars allocation self emit-code) + (emit-bindings src names gensyms allocation self emit-code) (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #f . ,n) @@ -774,29 +774,29 @@ ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'box n))) (,loc (error "badness" x loc)))) - (reverse vars)) + (reverse gensyms)) (comp-tail body) (emit-code #f (make-glil-unbind))) - ((<letrec> src names vars vals body) + ((<letrec> src names gensyms vals body) (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'empty-box n))) (,loc (error "badness" x loc)))) - vars) + gensyms) (for-each comp-push vals) - (emit-bindings src names vars allocation self emit-code) + (emit-bindings src names gensyms allocation self emit-code) (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) self) ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'set n))) (,loc (error "badness" x loc)))) - (reverse vars)) + (reverse gensyms)) (comp-tail body) (emit-code #f (make-glil-unbind))) - ((<fix> src names vars vals body) + ((<fix> src names gensyms vals body) ;; The ideal here is to just render the lambda bodies inline, and ;; wire the code together with gotos. We can do that if ;; analyze-lexicals has determined that a given var has "label" @@ -835,10 +835,10 @@ (let lp ((lcase (lambda-body x))) (if lcase (record-case lcase - ((<lambda-case> src req vars body alternate) + ((<lambda-case> src req gensyms body alternate) (emit-label (car (hashq-ref allocation lcase))) ;; FIXME: opt & kw args in the bindings - (emit-bindings #f req vars allocation self emit-code) + (emit-bindings #f req gensyms allocation self emit-code) (if src (emit-code #f (make-glil-source src))) (comp-fix body (or RA new-RA)) @@ -846,15 +846,15 @@ (lp alternate))) (emit-label POST))))))) vals - vars) + gensyms) ;; Emit bindings metadata for closures - (let ((binds (let lp ((out '()) (vars vars) (names names)) - (cond ((null? vars) (reverse! out)) - ((assq (car vars) fix-labels) - (lp out (cdr vars) (cdr names))) + (let ((binds (let lp ((out '()) (gensyms gensyms) (names names)) + (cond ((null? gensyms) (reverse! out)) + ((assq (car gensyms) fix-labels) + (lp out (cdr gensyms) (cdr names))) (else - (lp (acons (car vars) (car names) out) - (cdr vars) (cdr names))))))) + (lp (acons (car gensyms) (car names) out) + (cdr gensyms) (cdr names))))))) (emit-bindings src (map cdr binds) (map car binds) allocation self emit-code)) ;; Now go back and fix up the bindings for closures. @@ -878,7 +878,7 @@ (emit-code #f (make-glil-lexical #t #f 'fix n))) (,loc (error "badness" x loc))))))) vals - vars) + gensyms) (comp-tail body) (if new-RA (emit-label new-RA)) @@ -886,7 +886,7 @@ ((<let-values> src exp body) (record-case body - ((<lambda-case> req opt kw rest vars body alternate) + ((<lambda-case> req opt kw rest gensyms body alternate) (if (or opt kw alternate) (error "unexpected lambda-case in let-values" x)) (let ((MV (make-label))) @@ -896,7 +896,7 @@ (emit-code src (make-glil-mv-bind (vars->bind-list (append req (if rest (list rest) '())) - vars allocation self) + gensyms allocation self) (and rest #t))) (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) self) @@ -905,7 +905,7 @@ ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'box n))) (,loc (error "badness" x loc)))) - (reverse vars)) + (reverse gensyms)) (comp-tail body) (emit-code #f (make-glil-unbind)))))) @@ -1086,13 +1086,13 @@ ;; then the args to the continuation (pushed separately), and then the ;; number of args, including the continuation. (record-case handler - ((<lambda-case> req opt kw rest vars body alternate) + ((<lambda-case> req opt kw rest gensyms body alternate) (if (or opt kw alternate) (error "unexpected lambda-case in prompt" x)) (emit-code src (make-glil-mv-bind (vars->bind-list (append req (if rest (list rest) '())) - vars allocation self) + gensyms allocation self) (and rest #t))) (for-each (lambda (v) (pmatch (hashq-ref (hashq-ref allocation v) self) @@ -1101,7 +1101,7 @@ ((#t #t . ,n) (emit-code src (make-glil-lexical #t #t 'box n))) (,loc (error "badness" x loc)))) - (reverse vars)) + (reverse gensyms)) (comp-tail body) (emit-code #f (make-glil-unbind)))) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index bef31ce8c..e849e694b 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -1,6 +1,6 @@ ;;; transformation of letrec into simpler forms -;; Copyright (C) 2009 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -71,15 +71,15 @@ simple lambda* complex)) - ((<letrec> vars) - (values (append vars unref) + ((<letrec> gensyms) + (values (append gensyms unref) ref set simple lambda* complex)) - ((<let> vars) - (values (append vars unref) + ((<let> gensyms) + (values (append gensyms unref) ref set simple @@ -89,65 +89,65 @@ (values unref ref set simple lambda* complex)))) (lambda (x unref ref set simple lambda* complex) (record-case x - ((<letrec> (orig-vars vars) vals) - (let lp ((vars orig-vars) (vals vals) + ((<letrec> (orig-gensyms gensyms) vals) + (let lp ((gensyms orig-gensyms) (vals vals) (s '()) (l '()) (c '())) (cond - ((null? vars) + ((null? gensyms) (values unref ref set (append s simple) (append l lambda*) (append c complex))) - ((memq (car vars) unref) - (lp (cdr vars) (cdr vals) + ((memq (car gensyms) unref) + (lp (cdr gensyms) (cdr vals) s l c)) - ((memq (car vars) set) - (lp (cdr vars) (cdr vals) - s l (cons (car vars) c))) + ((memq (car gensyms) set) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c))) ((lambda? (car vals)) - (lp (cdr vars) (cdr vals) - s (cons (car vars) l) c)) - ((simple-expression? (car vals) orig-vars) - (lp (cdr vars) (cdr vals) - (cons (car vars) s) l c)) + (lp (cdr gensyms) (cdr vals) + s (cons (car gensyms) l) c)) + ((simple-expression? (car vals) orig-gensyms) + (lp (cdr gensyms) (cdr vals) + (cons (car gensyms) s) l c)) (else - (lp (cdr vars) (cdr vals) - s l (cons (car vars) c)))))) - ((<let> (orig-vars vars) vals) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c)))))) + ((<let> (orig-gensyms gensyms) vals) ;; The point is to compile let-bound lambdas as ;; efficiently as we do letrec-bound lambdas, so ;; we use the same algorithm for analyzing the - ;; vars. There is no problem recursing into the + ;; gensyms. There is no problem recursing into the ;; bindings after the let, because all variables ;; have been renamed. - (let lp ((vars orig-vars) (vals vals) + (let lp ((gensyms orig-gensyms) (vals vals) (s '()) (l '()) (c '())) (cond - ((null? vars) + ((null? gensyms) (values unref ref set (append s simple) (append l lambda*) (append c complex))) - ((memq (car vars) unref) - (lp (cdr vars) (cdr vals) + ((memq (car gensyms) unref) + (lp (cdr gensyms) (cdr vals) s l c)) - ((memq (car vars) set) - (lp (cdr vars) (cdr vals) - s l (cons (car vars) c))) + ((memq (car gensyms) set) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c))) ((and (lambda? (car vals)) - (not (memq (car vars) set))) - (lp (cdr vars) (cdr vals) - s (cons (car vars) l) c)) + (not (memq (car gensyms) set))) + (lp (cdr gensyms) (cdr vals) + s (cons (car gensyms) l) c)) ;; There is no difference between simple and ;; complex, for the purposes of let. Just lump ;; them all into complex. (else - (lp (cdr vars) (cdr vals) - s l (cons (car vars) c)))))) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c)))))) (else (values unref ref set simple lambda* complex)))) '() @@ -171,11 +171,11 @@ (make-sequence #f (list exp (make-void #f))) x)) - ((<letrec> src names vars vals body) - (let ((binds (map list vars names vals))) + ((<letrec> src names gensyms vals body) + (let ((binds (map list gensyms names vals))) (define (lookup set) (map (lambda (v) (assq v binds)) - (lset-intersection eq? vars set))) + (lset-intersection eq? gensyms set))) (let ((u (lookup unref)) (s (lookup simple)) (l (lookup lambda*)) @@ -216,11 +216,11 @@ ;; Finally, the body. body))))))))) - ((<let> src names vars vals body) - (let ((binds (map list vars names vals))) + ((<let> src names gensyms vals body) + (let ((binds (map list gensyms names vals))) (define (lookup set) (map (lambda (v) (assq v binds)) - (lset-intersection eq? vars set))) + (lset-intersection eq? gensyms set))) (let ((u (lookup unref)) (l (lookup lambda*)) (c (lookup complex))) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 8dd7dd334..706072940 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -44,9 +44,9 @@ (let lp ((lcase body)) (and lcase (record-case lcase - ((<lambda-case> req opt rest kw inits vars body alternate) - (if (and (= (length vars) (length req) (length args))) - (let ((x (make-let src req vars args body))) + ((<lambda-case> req opt rest kw inits gensyms body alternate) + (if (and (= (length gensyms) (length req) (length args))) + (let ((x (make-let src req gensyms args body))) (or (inline1 x) x)) (lp alternate))))))) @@ -101,24 +101,24 @@ (else #f))) - ((<let> vars body) - (if (null? vars) body x)) + ((<let> gensyms body) + (if (null? gensyms) body x)) - ((<letrec> vars body) - (if (null? vars) body x)) + ((<letrec> gensyms body) + (if (null? gensyms) body x)) - ((<fix> vars body) - (if (null? vars) body x)) + ((<fix> gensyms body) + (if (null? gensyms) body x)) - ((<lambda-case> req opt rest kw vars body alternate) - (define (args-compatible? args vars) - (let lp ((args args) (vars vars)) + ((<lambda-case> req opt rest kw gensyms body alternate) + (define (args-compatible? args gensyms) + (let lp ((args args) (gensyms gensyms)) (cond - ((null? args) (null? vars)) - ((null? vars) #f) + ((null? args) (null? gensyms)) + ((null? gensyms) #f) ((and (lexical-ref? (car args)) - (eq? (lexical-ref-gensym (car args)) (car vars))) - (lp (cdr args) (cdr vars))) + (eq? (lexical-ref-gensym (car args)) (car gensyms))) + (lp (cdr args) (cdr gensyms))) (else #f)))) (and (not opt) (not kw) rest (not alternate) @@ -129,7 +129,7 @@ (eq? (primitive-ref-name proc) '@apply) (pair? args) (lambda? (car args)) - (args-compatible? (cdr args) vars) + (args-compatible? (cdr args) gensyms) (lambda-body (car args)))) (else #f)))) @@ -138,7 +138,7 @@ ((<prompt> src tag body handler) (define (escape-only? handler) (and (pair? (lambda-case-req handler)) - (let ((cont (car (lambda-case-vars handler)))) + (let ((cont (car (lambda-case-gensyms handler)))) (tree-il-fold (lambda (leaf escape-only?) (and escape-only? (not |