diff options
author | Andy Wingo <wingo@pobox.com> | 2010-02-19 11:42:00 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-02-19 12:10:12 +0100 |
commit | 706a705eca032f84562ec84ac439b3d4a7ca8c66 (patch) | |
tree | 910f12a608d822bf351248855475dca0cbb10f9b /module | |
parent | 1e7a0337f1180343ca2f81557bfdeb78e23cd532 (diff) | |
download | guile-706a705eca032f84562ec84ac439b3d4a7ca8c66.tar.gz |
add <dynref> and <dynset> to tree-il
* module/language/tree-il.scm (<dynref>, <dynset>): New tree-il language
elements, corresponding to fluid-ref and fluid-set.
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm: Wire them up in the usual
manner.
Diffstat (limited to 'module')
-rw-r--r-- | module/language/tree-il.scm | 45 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 12 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 18 |
3 files changed, 75 insertions, 0 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 1ae39e874..cfd26bfc6 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -47,6 +47,8 @@ <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 + <dynref> dynref? make-dynref dynref-src dynref-fluid + <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler <abort> abort? make-abort abort-src abort-tag abort-args @@ -81,6 +83,8 @@ (<let-values> exp body) (<dynwind> winder body unwinder) (<dynlet> fluids vals body) + (<dynref> fluid) + (<dynset> fluid exp) (<prompt> tag body handler) (<abort> tag args)) @@ -179,6 +183,12 @@ ((dynlet ,fluids ,vals ,body) (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body))) + ((dynref ,fluid) + (make-dynref loc (retrans fluid))) + + ((dynset ,fluid ,exp) + (make-dynset loc (retrans fluid) (retrans exp))) + ((prompt ,tag ,body ,handler) (make-prompt loc (retrans tag) (retrans body) (retrans handler))) @@ -257,6 +267,12 @@ `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals) ,(unparse-tree-il body))) + ((<dynref> fluid) + `(dynref ,(unparse-tree-il fluid))) + + ((<dynset> fluid exp) + `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) + ((<prompt> tag body handler) `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler))) @@ -346,6 +362,12 @@ (map tree-il->scheme vals)) ,(tree-il->scheme body))) + ((<dynref> fluid) + `(fluid-ref ,(tree-il->scheme fluid))) + + ((<dynset> fluid exp) + `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) + ((<prompt> tag body handler) `((@ (ice-9 control) prompt) ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body)) @@ -414,6 +436,10 @@ This is an implementation of `foldts' as described by Andy Wingo in (up tree (loop body (loop vals (loop fluids (down tree result)))))) + ((<dynref> fluid) + (up tree (loop fluid (down tree result)))) + ((<dynset> fluid exp) + (up tree (loop exp (loop fluid (down tree result))))) ((<prompt> tag body handler) (up tree (loop tag (loop body (loop handler @@ -483,6 +509,11 @@ This is an implementation of `foldts' as described by Andy Wingo in (let*-values (((seed ...) (fold-values foldts fluids seed ...)) ((seed ...) (fold-values foldts vals seed ...))) (foldts body seed ...))) + ((<dynref> fluid) + (foldts fluid seed ...)) + ((<dynset> fluid exp) + (let*-values (((seed ...) (foldts fluid seed ...))) + (foldts exp seed ...))) ((<prompt> tag body handler) (let*-values (((seed ...) (foldts tag seed ...)) ((seed ...) (foldts body seed ...))) @@ -556,6 +587,13 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (dynlet-vals x) (map lp vals)) (set! (dynlet-body x) (lp body))) + ((<dynref> fluid) + (set! (dynref-fluid x) (lp fluid))) + + ((<dynset> fluid exp) + (set! (dynset-fluid x) (lp fluid)) + (set! (dynset-exp x) (lp exp))) + ((<prompt> tag body handler) (set! (prompt-tag x) (lp tag)) (set! (prompt-body x) (lp body)) @@ -631,6 +669,13 @@ This is an implementation of `foldts' as described by Andy Wingo in (set! (dynlet-vals x) (map lp vals)) (set! (dynlet-body x) (lp body))) + ((<dynref> fluid) + (set! (dynref-fluid x) (lp fluid))) + + ((<dynset> fluid exp) + (set! (dynset-fluid x) (lp fluid)) + (set! (dynset-exp x) (lp exp))) + ((<prompt> tag body handler) (set! (prompt-tag x) (lp tag)) (set! (prompt-body x) (lp body)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 2d1a25289..c5f6cb9aa 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -342,6 +342,12 @@ ((<dynlet> fluids vals body) (apply lset-union eq? (step body) (map step (append fluids vals)))) + ((<dynref> fluid) + (step fluid)) + + ((<dynset> fluid exp) + (lset-union eq? (step fluid) (step exp))) + ((<prompt> tag body handler) (lset-union eq? (step tag) (step handler))) @@ -505,6 +511,12 @@ ((<dynlet> fluids vals body) (apply max (recur body) (map recur (append fluids vals)))) + ((<dynref> fluid) + (recur fluid)) + + ((<dynset> fluid exp) + (max (recur fluid) (recur exp))) + ((<prompt> tag body handler) (let ((cont-var (and (lambda-case? handler) (pair? (lambda-case-vars handler)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 85c9c116e..64514d855 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -1013,6 +1013,24 @@ (if RA (emit-branch #f 'br RA))))) + ((<dynref> src fluid) + (case context + ((drop) + (comp-drop fluid)) + ((push vals tail) + (comp-push fluid) + (emit-code #f (make-glil-call 'fluid-ref 1)))) + (maybe-emit-return)) + + ((<dynset> src fluid exp) + (comp-push fluid) + (comp-push exp) + (emit-code #f (make-glil-call 'fluid-set 2)) + (case context + ((push vals tail) + (emit-code #f (make-glil-void)))) + (maybe-emit-return)) + ;; What's the deal here? The deal is that we are compiling the start of a ;; delimited continuation. We try to avoid heap allocation in the normal ;; case; so the body is an expression, not a thunk, and we try to render |