mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

rename vars' field in tree-il binding constructs to gensyms'

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-05-02 11:22:23 +02:00
parent 915aca30ba
commit 93f63467e6
5 changed files with 216 additions and 216 deletions
Download patch file Download diff file Expand all files Collapse all files

74
module/language/tree-il.scm
View file

@ -39,11 +39,11 @@
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src <lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw 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 lambda-case-body lambda-case-alternate
<let> let? make-let let-src let-names let-vars let-vals let-body <let> let? make-let let-src let-names let-gensyms let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body <letrec> letrec? make-letrec letrec-src letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-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 <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 <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
@ -76,10 +76,10 @@
(<application> proc args) (<application> proc args)
(<sequence> exps) (<sequence> exps)
(<lambda> meta body) (<lambda> meta body)
(<lambda-case> req opt rest kw inits vars body alternate) (<lambda-case> req opt rest kw inits gensyms body alternate)
(<let> names vars vals body) (<let> names gensyms vals body)
(<letrec> names vars vals body) (<letrec> names gensyms vals body)
(<fix> names vars vals body) (<fix> names gensyms vals body)
(<let-values> exp body) (<let-values> exp body)
(<dynwind> winder body unwinder) (<dynwind> winder body unwinder)
(<dynlet> fluids vals body) (<dynlet> fluids vals body)
@ -147,15 +147,15 @@
((lambda ,meta ,body) ((lambda ,meta ,body)
(make-lambda loc meta (retrans 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 (make-lambda-case loc req opt rest kw
(map retrans inits) vars (map retrans inits) gensyms
(retrans body) (retrans body)
(and=> alternate retrans))) (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 (make-lambda-case loc req opt rest kw
(map retrans inits) vars (map retrans inits) gensyms
(retrans body) (retrans body)
#f)) #f))
@ -165,14 +165,14 @@
((begin . ,exps) ((begin . ,exps)
(make-sequence loc (map retrans exps))) (make-sequence loc (map retrans exps)))
((let ,names ,vars ,vals ,body) ((let ,names ,gensyms ,vals ,body)
(make-let loc names vars (map retrans vals) (retrans body))) (make-let loc names gensyms (map retrans vals) (retrans body)))
((letrec ,names ,vars ,vals ,body) ((letrec ,names ,gensyms ,vals ,body)
(make-letrec loc names vars (map retrans vals) (retrans body))) (make-letrec loc names gensyms (map retrans vals) (retrans body)))
((fix ,names ,vars ,vals ,body) ((fix ,names ,gensyms ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body))) (make-fix loc names gensyms (map retrans vals) (retrans body)))
((let-values ,exp ,body) ((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body))) (make-let-values loc (retrans exp) (retrans body)))
@ -236,8 +236,8 @@
((<lambda> meta body) ((<lambda> meta body)
`(lambda ,meta ,(unparse-tree-il body))) `(lambda ,meta ,(unparse-tree-il body)))
((<lambda-case> req opt rest kw inits vars body alternate) ((<lambda-case> req opt rest kw inits gensyms body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars) `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
,(unparse-tree-il body)) ,(unparse-tree-il body))
. ,(if alternate (list (unparse-tree-il alternate)) '()))) . ,(if alternate (list (unparse-tree-il alternate)) '())))
@ -247,14 +247,14 @@
((<sequence> exps) ((<sequence> exps)
`(begin ,@(map unparse-tree-il exps))) `(begin ,@(map unparse-tree-il exps)))
((<let> names vars vals body) ((<let> names gensyms vals body)
`(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<letrec> names vars vals body) ((<letrec> names gensyms vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) `(letrec ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<fix> names vars vals body) ((<fix> names gensyms vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<let-values> exp body) ((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
@ -324,9 +324,9 @@
`(lambda ,@(car (tree-il->scheme body))) `(lambda ,@(car (tree-il->scheme body)))
`(case-lambda ,@(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? ;; FIXME! use parse-lambda-case?
`((,(if rest (apply cons* vars) vars) `((,(if rest (apply cons* gensyms) gensyms)
,(tree-il->scheme body)) ,(tree-il->scheme body))
,@(if alternate (tree-il->scheme alternate) '()))) ,@(if alternate (tree-il->scheme alternate) '())))
@ -338,15 +338,15 @@
((<sequence> exps) ((<sequence> exps)
`(begin ,@(map tree-il->scheme exps))) `(begin ,@(map tree-il->scheme exps)))
((<let> vars vals body) ((<let> gensyms vals body)
`(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body))) `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
((<letrec> vars vals body) ((<letrec> gensyms vals body)
`(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)))
((<fix> vars vals body) ((<fix> gensyms vals body)
;; not a typo, we really do translate back to letrec ;; 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) ((<let-values> exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp)) `(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) ((<sequence> exps)
(set! (sequence-exps x) (map lp 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-vals x) (map lp vals))
(set! (let-body x) (lp body))) (set! (let-body x) (lp body)))
((<letrec> vars vals body) ((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals)) (set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body))) (set! (letrec-body x) (lp body)))
((<fix> vars vals body) ((<fix> gensyms vals body)
(set! (fix-vals x) (map lp vals)) (set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body))) (set! (fix-body x) (lp body)))

150
module/language/tree-il/analyze.scm
View file

@ -235,39 +235,39 @@
(hashq-set! free-vars x free) (hashq-set! free-vars x free)
free)) free))
((<lambda-case> opt kw inits vars body alternate) ((<lambda-case> opt kw inits gensyms body alternate)
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-union (lset-union
eq? eq?
(lset-difference eq? (lset-difference eq?
(lset-union eq? (lset-union eq?
(apply lset-union eq? (map step inits)) (apply lset-union eq? (map step inits))
(step-tail body)) (step-tail body))
vars) gensyms)
(if alternate (step-tail alternate) '()))) (if alternate (step-tail alternate) '())))
((<let> vars vals body) ((<let> gensyms vals body)
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-difference eq? (lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals)) (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 (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse gensyms) (hashq-ref bound-vars proc)))
(for-each (lambda (sym) (hashq-set! assigned sym #t)) vars) (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
(lset-difference eq? (lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals)) (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. ;; Try to allocate these procedures as labels.
(for-each (lambda (sym val) (hashq-set! labels sym val)) (for-each (lambda (sym val) (hashq-set! labels sym val))
vars vals) gensyms vals)
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse gensyms) (hashq-ref bound-vars proc)))
;; Step into subexpressions. ;; Step into subexpressions.
(let* ((var-refs (let* ((var-refs
(map (map
@ -282,13 +282,13 @@
;; just like the closure case, except here we use ;; just like the closure case, except here we use
;; recur/labels instead of recur ;; recur/labels instead of recur
(hashq-set! bound-vars x '()) (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! bound-vars x (reverse! (hashq-ref bound-vars x)))
(hashq-set! free-vars x free) (hashq-set! free-vars x free)
free)))) free))))
vals)) vals))
(vars-with-refs (map cons vars var-refs)) (vars-with-refs (map cons gensyms var-refs))
(body-refs (recur/labels body proc vars))) (body-refs (recur/labels body proc gensyms)))
(define (delabel-dependents! sym) (define (delabel-dependents! sym)
(let ((refs (assq-ref vars-with-refs sym))) (let ((refs (assq-ref vars-with-refs sym)))
(if refs (if refs
@ -314,7 +314,7 @@
(for-each (lambda (sym) (for-each (lambda (sym)
(if (not (hashq-ref labels sym)) (if (not (hashq-ref labels sym))
(delabel-dependents! sym))) (delabel-dependents! sym)))
vars) gensyms)
;; Now lift bound variables with label-allocated lambdas to the ;; Now lift bound variables with label-allocated lambdas to the
;; parent procedure. ;; parent procedure.
(for-each (for-each
@ -328,10 +328,10 @@
(hashq-ref bound-vars proc))) (hashq-ref bound-vars proc)))
(hashq-remove! bound-vars val) (hashq-remove! bound-vars val)
(hashq-remove! free-vars val)))) (hashq-remove! free-vars val))))
vars vals) gensyms vals)
(lset-difference eq? (lset-difference eq?
(apply lset-union eq? body-refs var-refs) (apply lset-union eq? body-refs var-refs)
vars))) gensyms)))
((<let-values> exp body) ((<let-values> exp body)
(lset-union eq? (step exp) (step body))) (lset-union eq? (step exp) (step body)))
@ -407,10 +407,10 @@
(hashq-set! allocation x (cons labels free-addresses))) (hashq-set! allocation x (cons labels free-addresses)))
n) n)
((<lambda-case> opt kw inits vars body alternate) ((<lambda-case> opt kw inits gensyms body alternate)
(max (max
(let lp ((vars vars) (n n)) (let lp ((gensyms gensyms) (n n))
(if (null? vars) (if (null? gensyms)
(let ((nlocs (apply (let ((nlocs (apply
max max
(allocate! body proc n) (allocate! body proc n)
@ -421,72 +421,72 @@
(hashq-set! allocation x (cons (gensym ":LCASE") nlocs)) (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
nlocs) nlocs)
(begin (begin
(hashq-set! allocation (car vars) (hashq-set! allocation (car gensyms)
(make-hashq (make-hashq
proc `(#t ,(hashq-ref assigned (car vars)) . ,n))) proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n)))
(lp (cdr vars) (1+ n))))) (lp (cdr gensyms) (1+ n)))))
(if alternate (allocate! alternate proc n) n))) (if alternate (allocate! alternate proc n) n)))
((<let> vars vals body) ((<let> gensyms vals body)
(let ((nmax (apply max (map recur vals)))) (let ((nmax (apply max (map recur vals))))
(cond (cond
;; the `or' hack ;; the `or' hack
((and (conditional? body) ((and (conditional? body)
(= (length vars) 1) (= (length gensyms) 1)
(let ((v (car vars))) (let ((v (car gensyms)))
(and (not (hashq-ref assigned v)) (and (not (hashq-ref assigned v))
(= (hashq-ref refcounts v 0) 2) (= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test body)) (lexical-ref? (conditional-test body))
(eq? (lexical-ref-gensym (conditional-test body)) v) (eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-consequent body)) (lexical-ref? (conditional-consequent body))
(eq? (lexical-ref-gensym (conditional-consequent body)) v)))) (eq? (lexical-ref-gensym (conditional-consequent body)) v))))
(hashq-set! allocation (car vars) (hashq-set! allocation (car gensyms)
(make-hashq proc `(#t #f . ,n))) (make-hashq proc `(#t #f . ,n)))
;; the 1+ for this var ;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-alternate body) proc n))) (max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
(else (else
(let lp ((vars vars) (n n)) (let lp ((gensyms gensyms) (n n))
(if (null? vars) (if (null? gensyms)
(max nmax (allocate! body proc n)) (max nmax (allocate! body proc n))
(let ((v (car vars))) (let ((v (car gensyms)))
(hashq-set! (hashq-set!
allocation v allocation v
(make-hashq proc (make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n))) `(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))))) (lp (cdr gensyms) (1+ n)))))))))
((<letrec> vars vals body) ((<letrec> gensyms vals body)
(let lp ((vars vars) (n n)) (let lp ((gensyms gensyms) (n n))
(if (null? vars) (if (null? gensyms)
(let ((nmax (apply max (let ((nmax (apply max
(map (lambda (x) (map (lambda (x)
(allocate! x proc n)) (allocate! x proc n))
vals)))) vals))))
(max nmax (allocate! body proc n))) (max nmax (allocate! body proc n)))
(let ((v (car vars))) (let ((v (car gensyms)))
(hashq-set! (hashq-set!
allocation v allocation v
(make-hashq proc (make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n))) `(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n)))))) (lp (cdr gensyms) (1+ n))))))
((<fix> vars vals body) ((<fix> gensyms vals body)
(let lp ((in vars) (n n)) (let lp ((in gensyms) (n n))
(if (null? in) (if (null? in)
(let lp ((vars vars) (vals vals) (nmax n)) (let lp ((gensyms gensyms) (vals vals) (nmax n))
(cond (cond
((null? vars) ((null? gensyms)
(max nmax (allocate! body proc n))) (max nmax (allocate! body proc n)))
((hashq-ref labels (car vars)) ((hashq-ref labels (car gensyms))
;; allocate lambda body inline to proc ;; allocate lambda body inline to proc
(lp (cdr vars) (lp (cdr gensyms)
(cdr vals) (cdr vals)
(record-case (car vals) (record-case (car vals)
((<lambda> body) ((<lambda> body)
(max nmax (allocate! body proc n)))))) (max nmax (allocate! body proc n))))))
(else (else
;; allocate closure ;; allocate closure
(lp (cdr vars) (lp (cdr gensyms)
(cdr vals) (cdr vals)
(max nmax (allocate! (car vals) proc n)))))) (max nmax (allocate! (car vals) proc n))))))
@ -519,8 +519,8 @@
((<prompt> tag body handler) ((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler) (let ((cont-var (and (lambda-case? handler)
(pair? (lambda-case-vars handler)) (pair? (lambda-case-gensyms handler))
(car (lambda-case-vars handler))))) (car (lambda-case-gensyms handler)))))
(hashq-set! allocation x (hashq-set! allocation x
(and cont-var (zero? (hashq-ref refcounts cont-var 0)))) (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
(max (recur tag) (recur body) (recur handler)))) (max (recur tag) (recur body) (recur handler))))
@ -629,18 +629,18 @@ accurate information is missing from a given `tree-il' element."
(record-case x (record-case x
((<lexical-set> gensym) ((<lexical-set> gensym)
(make-binding-info vars (vhash-consq gensym #t refs))) (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 (let ((names `(,@req
,@(or opt '()) ,@(or opt '())
,@(if rest (list rest) '()) ,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '())))) ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend vars names) refs))) (make-binding-info (extend gensyms names) refs)))
((<let> vars names) ((<let> gensyms names)
(make-binding-info (extend vars names) refs)) (make-binding-info (extend gensyms names) refs))
((<letrec> vars names) ((<letrec> gensyms names)
(make-binding-info (extend vars names) refs)) (make-binding-info (extend gensyms names) refs))
((<fix> vars names) ((<fix> gensyms names)
(make-binding-info (extend vars names) refs)) (make-binding-info (extend gensyms names) refs))
(else info)))) (else info))))
(lambda (x info env locs) (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 ;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat. ;; makes REFS unnecessarily fat.
(record-case x (record-case x
((<lambda-case> vars) ((<lambda-case> gensyms)
(make-binding-info (shrink vars refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<let> vars) ((<let> gensyms)
(make-binding-info (shrink vars refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<letrec> vars) ((<letrec> gensyms)
(make-binding-info (shrink vars refs) refs)) (make-binding-info (shrink gensyms refs) refs))
((<fix> vars) ((<fix> gensyms)
(make-binding-info (shrink vars refs) refs)) (make-binding-info (shrink gensyms refs) refs))
(else info)))) (else info))))
(lambda (result env) #t) (lambda (result env) #t)
@ -1106,12 +1106,12 @@ accurate information is missing from a given `tree-il' element."
exp) exp)
toplevel-lambdas)))) toplevel-lambdas))))
(else info))) (else info)))
((<let> vars vals) ((<let> gensyms vals)
(fold extend info vars vals)) (fold extend info gensyms vals))
((<letrec> vars vals) ((<letrec> gensyms vals)
(fold extend info vars vals)) (fold extend info gensyms vals))
((<fix> vars vals) ((<fix> gensyms vals)
(fold extend info vars vals)) (fold extend info gensyms vals))
((<application> proc args src) ((<application> proc args src)
(record-case proc (record-case proc
@ -1158,12 +1158,12 @@ accurate information is missing from a given `tree-il' element."
(lexical-lambdas (lexical-lambdas info)) (lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info))) (toplevel-lambdas (toplevel-lambdas info)))
(record-case x (record-case x
((<let> vars vals) ((<let> gensyms vals)
(fold shrink info vars vals)) (fold shrink info gensyms vals))
((<letrec> vars vals) ((<letrec> gensyms vals)
(fold shrink info vars vals)) (fold shrink info gensyms vals))
((<fix> vars vals) ((<fix> gensyms vals)
(fold shrink info vars vals)) (fold shrink info gensyms vals))
(else info)))) (else info))))

92
module/language/tree-il/compile-glil.scm
View file

@ -428,7 +428,7 @@
;; new box ;; new box
(emit-code #f (make-glil-lexical #t #t 'box index))) (emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x)))) (,x (error "what" x))))
(reverse (lambda-case-vars lcase))) (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase)))) (emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase) ((lambda-case? lcase)
;; no match, try next case ;; no match, try next case
@ -465,7 +465,7 @@
((#t #t . ,index) ; boxed ((#t #t . ,index) ; boxed
(emit-code #f (make-glil-lexical #t #t 'box index))) (emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x)))) (,x (error "what" x))))
(reverse (lambda-case-vars lcase))) (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase)))) (emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase) ((lambda-case? lcase)
;; no match, try next case ;; no match, try next case
@ -669,15 +669,15 @@
(length free-locs)))))))) (length free-locs))))))))
(maybe-emit-return)) (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/~ ;; o/~ feature on top of feature o/~
;; req := (name ...) ;; req := (name ...)
;; opt := (name ...) | #f ;; opt := (name ...) | #f
;; rest := name | #f ;; rest := name | #f
;; kw: (allow-other-keys? (keyword name var) ...) | #f ;; kw: (allow-other-keys? (keyword name var) ...) | #f
;; vars: (sym ...) ;; gensyms: (sym ...)
;; init: tree-il in context of vars ;; init: tree-il in context of gensyms
;; vars map to named arguments in the following order: ;; gensyms map to named arguments in the following order:
;; required, optional (positional), rest, keyword. ;; required, optional (positional), rest, keyword.
(let* ((nreq (length req)) (let* ((nreq (length req))
(nopt (if opt (length opt) 0)) (nopt (if opt (length opt) 0))
@ -687,7 +687,7 @@
(kw-indices (map (lambda (x) (kw-indices (map (lambda (x)
(pmatch x (pmatch x
((,key ,name ,var) ((,key ,name ,var)
(cons key (list-index vars var))) (cons key (list-index gensyms var)))
(else (error "bad kwarg" x)))) (else (error "bad kwarg" x))))
(if kw (cdr kw) '()))) (if kw (cdr kw) '())))
(nargs (apply max (+ nreq nopt (if rest 1 0)) (nargs (apply max (+ nreq nopt (if rest 1 0))
@ -695,10 +695,10 @@
(nlocs (cdr (hashq-ref allocation x))) (nlocs (cdr (hashq-ref allocation x)))
(alternate-label (and alternate (make-label)))) (alternate-label (and alternate (make-label))))
(or (= nargs (or (= nargs
(length vars) (length gensyms)
(+ nreq (length inits) (if rest 1 0))) (+ nreq (length inits) (if rest 1 0)))
(error "something went wrong" (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, ;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals ;; allowing room for locals
(emit-code (emit-code
@ -718,33 +718,33 @@
((#t #t . ,n) ((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n)) (emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n))))) (emit-code #f (make-glil-lexical #t #t 'box n)))))
vars) gensyms)
;; write bindings info ;; write bindings info
(if (not (null? vars)) (if (not (null? gensyms))
(emit-bindings (emit-bindings
#f #f
(let lp ((kw (if kw (cdr kw) '())) (let lp ((kw (if kw (cdr kw) '()))
(names (append (reverse opt-names) (reverse req))) (names (append (reverse opt-names) (reverse req)))
(vars (list-tail vars (+ nreq nopt (gensyms (list-tail gensyms (+ nreq nopt
(if rest 1 0))))) (if rest 1 0)))))
(pmatch kw (pmatch kw
(() (()
;; fixme: check that vars is empty ;; fixme: check that gensyms is empty
(reverse (if rest (cons rest names) names))) (reverse (if rest (cons rest names) names)))
(((,key ,name ,var) . ,kw) (((,key ,name ,var) . ,kw)
(if (memq var vars) (if (memq var gensyms)
(lp kw (cons name names) (delq var vars)) (lp kw (cons name names) (delq var gensyms))
(lp kw names vars))) (lp kw names gensyms)))
(,kw (error "bad keywords, yo" kw)))) (,kw (error "bad keywords, yo" kw))))
vars allocation self emit-code)) gensyms allocation self emit-code))
;; init optional/kw args ;; 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 (cond
((null? inits)) ; done ((null? inits)) ; done
((and rest-idx (= n rest-idx)) ((and rest-idx (= n rest-idx))
(lp inits (1+ n) (cdr vars))) (lp inits (1+ n) (cdr gensyms)))
(#t (#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)) ((#t ,boxed? . ,n*) (guard (= n* n))
(let ((L (make-label))) (let ((L (make-label)))
(emit-code #f (make-glil-lexical #t boxed? 'bound? n)) (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
@ -752,21 +752,21 @@
(comp-push (car inits)) (comp-push (car inits))
(emit-code #f (make-glil-lexical #t boxed? 'set n)) (emit-code #f (make-glil-lexical #t boxed? 'set n))
(emit-label L) (emit-label L)
(lp (cdr inits) (1+ n) (cdr vars)))) (lp (cdr inits) (1+ n) (cdr gensyms))))
(#t (error "what" inits)))))) (#t (error "what" inits))))))
;; post-prelude case label for label calls ;; post-prelude case label for label calls
(emit-label (car (hashq-ref allocation x))) (emit-label (car (hashq-ref allocation x)))
(comp-tail body) (comp-tail body)
(if (not (null? vars)) (if (not (null? gensyms))
(emit-code #f (make-glil-unbind))) (emit-code #f (make-glil-unbind)))
(if alternate-label (if alternate-label
(begin (begin
(emit-label alternate-label) (emit-label alternate-label)
(comp-tail alternate))))) (comp-tail alternate)))))
((<let> src names vars vals body) ((<let> src names gensyms vals body)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n) ((#t #f . ,n)
@ -774,29 +774,29 @@
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n))) (emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
(reverse vars)) (reverse gensyms))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind))) (emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals body) ((<letrec> src names gensyms vals body)
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n))) (emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
vars) gensyms)
(for-each comp-push vals) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n))) (emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
(reverse vars)) (reverse gensyms))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind))) (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 ;; The ideal here is to just render the lambda bodies inline, and
;; wire the code together with gotos. We can do that if ;; wire the code together with gotos. We can do that if
;; analyze-lexicals has determined that a given var has "label" ;; analyze-lexicals has determined that a given var has "label"
@ -835,10 +835,10 @@
(let lp ((lcase (lambda-body x))) (let lp ((lcase (lambda-body x)))
(if lcase (if lcase
(record-case 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))) (emit-label (car (hashq-ref allocation lcase)))
;; FIXME: opt & kw args in the bindings ;; 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 (if src
(emit-code #f (make-glil-source src))) (emit-code #f (make-glil-source src)))
(comp-fix body (or RA new-RA)) (comp-fix body (or RA new-RA))
@ -846,15 +846,15 @@
(lp alternate))) (lp alternate)))
(emit-label POST))))))) (emit-label POST)))))))
vals vals
vars) gensyms)
;; Emit bindings metadata for closures ;; Emit bindings metadata for closures
(let ((binds (let lp ((out '()) (vars vars) (names names)) (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
(cond ((null? vars) (reverse! out)) (cond ((null? gensyms) (reverse! out))
((assq (car vars) fix-labels) ((assq (car gensyms) fix-labels)
(lp out (cdr vars) (cdr names))) (lp out (cdr gensyms) (cdr names)))
(else (else
(lp (acons (car vars) (car names) out) (lp (acons (car gensyms) (car names) out)
(cdr vars) (cdr names))))))) (cdr gensyms) (cdr names)))))))
(emit-bindings src (map cdr binds) (map car binds) (emit-bindings src (map cdr binds) (map car binds)
allocation self emit-code)) allocation self emit-code))
;; Now go back and fix up the bindings for closures. ;; Now go back and fix up the bindings for closures.
@ -878,7 +878,7 @@
(emit-code #f (make-glil-lexical #t #f 'fix n))) (emit-code #f (make-glil-lexical #t #f 'fix n)))
(,loc (error "badness" x loc))))))) (,loc (error "badness" x loc)))))))
vals vals
vars) gensyms)
(comp-tail body) (comp-tail body)
(if new-RA (if new-RA
(emit-label new-RA)) (emit-label new-RA))
@ -886,7 +886,7 @@
((<let-values> src exp body) ((<let-values> src exp body)
(record-case 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) (if (or opt kw alternate)
(error "unexpected lambda-case in let-values" x)) (error "unexpected lambda-case in let-values" x))
(let ((MV (make-label))) (let ((MV (make-label)))
@ -896,7 +896,7 @@
(emit-code src (make-glil-mv-bind (emit-code src (make-glil-mv-bind
(vars->bind-list (vars->bind-list
(append req (if rest (list rest) '())) (append req (if rest (list rest) '()))
vars allocation self) gensyms allocation self)
(and rest #t))) (and rest #t)))
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
@ -905,7 +905,7 @@
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n))) (emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
(reverse vars)) (reverse gensyms))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind)))))) (emit-code #f (make-glil-unbind))))))
@ -1086,13 +1086,13 @@
;; then the args to the continuation (pushed separately), and then the ;; then the args to the continuation (pushed separately), and then the
;; number of args, including the continuation. ;; number of args, including the continuation.
(record-case handler (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) (if (or opt kw alternate)
(error "unexpected lambda-case in prompt" x)) (error "unexpected lambda-case in prompt" x))
(emit-code src (make-glil-mv-bind (emit-code src (make-glil-mv-bind
(vars->bind-list (vars->bind-list
(append req (if rest (list rest) '())) (append req (if rest (list rest) '()))
vars allocation self) gensyms allocation self)
(and rest #t))) (and rest #t)))
(for-each (lambda (v) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
@ -1101,7 +1101,7 @@
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n))) (emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
(reverse vars)) (reverse gensyms))
(comp-tail body) (comp-tail body)
(emit-code #f (make-glil-unbind)))) (emit-code #f (make-glil-unbind))))

80
module/language/tree-il/fix-letrec.scm
View file

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -71,15 +71,15 @@
simple simple
lambda* lambda*
complex)) complex))
((<letrec> vars) ((<letrec> gensyms)
(values (append vars unref) (values (append gensyms unref)
ref ref
set set
simple simple
lambda* lambda*
complex)) complex))
((<let> vars) ((<let> gensyms)
(values (append vars unref) (values (append gensyms unref)
ref ref
set set
simple simple
@ -89,65 +89,65 @@
(values unref ref set simple lambda* complex)))) (values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex) (lambda (x unref ref set simple lambda* complex)
(record-case x (record-case x
((<letrec> (orig-vars vars) vals) ((<letrec> (orig-gensyms gensyms) vals)
(let lp ((vars orig-vars) (vals vals) (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '())) (s '()) (l '()) (c '()))
(cond (cond
((null? vars) ((null? gensyms)
(values unref (values unref
ref ref
set set
(append s simple) (append s simple)
(append l lambda*) (append l lambda*)
(append c complex))) (append c complex)))
((memq (car vars) unref) ((memq (car gensyms) unref)
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l c)) s l c))
((memq (car vars) set) ((memq (car gensyms) set)
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l (cons (car vars) c))) s l (cons (car gensyms) c)))
((lambda? (car vals)) ((lambda? (car vals))
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s (cons (car vars) l) c)) s (cons (car gensyms) l) c))
((simple-expression? (car vals) orig-vars) ((simple-expression? (car vals) orig-gensyms)
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
(cons (car vars) s) l c)) (cons (car gensyms) s) l c))
(else (else
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l (cons (car vars) c)))))) s l (cons (car gensyms) c))))))
((<let> (orig-vars vars) vals) ((<let> (orig-gensyms gensyms) vals)
;; The point is to compile let-bound lambdas as ;; The point is to compile let-bound lambdas as
;; efficiently as we do letrec-bound lambdas, so ;; efficiently as we do letrec-bound lambdas, so
;; we use the same algorithm for analyzing the ;; 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 ;; bindings after the let, because all variables
;; have been renamed. ;; have been renamed.
(let lp ((vars orig-vars) (vals vals) (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '())) (s '()) (l '()) (c '()))
(cond (cond
((null? vars) ((null? gensyms)
(values unref (values unref
ref ref
set set
(append s simple) (append s simple)
(append l lambda*) (append l lambda*)
(append c complex))) (append c complex)))
((memq (car vars) unref) ((memq (car gensyms) unref)
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l c)) s l c))
((memq (car vars) set) ((memq (car gensyms) set)
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l (cons (car vars) c))) s l (cons (car gensyms) c)))
((and (lambda? (car vals)) ((and (lambda? (car vals))
(not (memq (car vars) set))) (not (memq (car gensyms) set)))
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s (cons (car vars) l) c)) s (cons (car gensyms) l) c))
;; There is no difference between simple and ;; There is no difference between simple and
;; complex, for the purposes of let. Just lump ;; complex, for the purposes of let. Just lump
;; them all into complex. ;; them all into complex.
(else (else
(lp (cdr vars) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l (cons (car vars) c)))))) s l (cons (car gensyms) c))))))
(else (else
(values unref ref set simple lambda* complex)))) (values unref ref set simple lambda* complex))))
'() '()
@ -171,11 +171,11 @@
(make-sequence #f (list exp (make-void #f))) (make-sequence #f (list exp (make-void #f)))
x)) x))
((<letrec> src names vars vals body) ((<letrec> src names gensyms vals body)
(let ((binds (map list vars names vals))) (let ((binds (map list gensyms names vals)))
(define (lookup set) (define (lookup set)
(map (lambda (v) (assq v binds)) (map (lambda (v) (assq v binds))
(lset-intersection eq? vars set))) (lset-intersection eq? gensyms set)))
(let ((u (lookup unref)) (let ((u (lookup unref))
(s (lookup simple)) (s (lookup simple))
(l (lookup lambda*)) (l (lookup lambda*))
@ -216,11 +216,11 @@
;; Finally, the body. ;; Finally, the body.
body))))))))) body)))))))))
((<let> src names vars vals body) ((<let> src names gensyms vals body)
(let ((binds (map list vars names vals))) (let ((binds (map list gensyms names vals)))
(define (lookup set) (define (lookup set)
(map (lambda (v) (assq v binds)) (map (lambda (v) (assq v binds))
(lset-intersection eq? vars set))) (lset-intersection eq? gensyms set)))
(let ((u (lookup unref)) (let ((u (lookup unref))
(l (lookup lambda*)) (l (lookup lambda*))
(c (lookup complex))) (c (lookup complex)))

36
module/language/tree-il/inline.scm
View file

@ -44,9 +44,9 @@
(let lp ((lcase body)) (let lp ((lcase body))
(and lcase (and lcase
(record-case lcase (record-case lcase
((<lambda-case> req opt rest kw inits vars body alternate) ((<lambda-case> req opt rest kw inits gensyms body alternate)
(if (and (= (length vars) (length req) (length args))) (if (and (= (length gensyms) (length req) (length args)))
(let ((x (make-let src req vars args body))) (let ((x (make-let src req gensyms args body)))
(or (inline1 x) x)) (or (inline1 x) x))
(lp alternate))))))) (lp alternate)))))))
@ -101,24 +101,24 @@
(else #f))) (else #f)))
((<let> vars body) ((<let> gensyms body)
(if (null? vars) body x)) (if (null? gensyms) body x))
((<letrec> vars body) ((<letrec> gensyms body)
(if (null? vars) body x)) (if (null? gensyms) body x))
((<fix> vars body) ((<fix> gensyms body)
(if (null? vars) body x)) (if (null? gensyms) body x))
((<lambda-case> req opt rest kw vars body alternate) ((<lambda-case> req opt rest kw gensyms body alternate)
(define (args-compatible? args vars) (define (args-compatible? args gensyms)
(let lp ((args args) (vars vars)) (let lp ((args args) (gensyms gensyms))
(cond (cond
((null? args) (null? vars)) ((null? args) (null? gensyms))
((null? vars) #f) ((null? gensyms) #f)
((and (lexical-ref? (car args)) ((and (lexical-ref? (car args))
(eq? (lexical-ref-gensym (car args)) (car vars))) (eq? (lexical-ref-gensym (car args)) (car gensyms)))
(lp (cdr args) (cdr vars))) (lp (cdr args) (cdr gensyms)))
(else #f)))) (else #f))))
(and (not opt) (not kw) rest (not alternate) (and (not opt) (not kw) rest (not alternate)
@ -129,7 +129,7 @@
(eq? (primitive-ref-name proc) '@apply) (eq? (primitive-ref-name proc) '@apply)
(pair? args) (pair? args)
(lambda? (car args)) (lambda? (car args))
(args-compatible? (cdr args) vars) (args-compatible? (cdr args) gensyms)
(lambda-body (car args)))) (lambda-body (car args))))
(else #f)))) (else #f))))
@ -138,7 +138,7 @@
((<prompt> src tag body handler) ((<prompt> src tag body handler)
(define (escape-only? handler) (define (escape-only? handler)
(and (pair? (lambda-case-req 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?) (tree-il-fold (lambda (leaf escape-only?)
(and escape-only? (and escape-only?
(not (not