mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Andy Wingo
parent
915aca30ba
commit
93f63467e6
5 changed files with 216 additions and 216 deletions
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue