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.

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1ae39e8..cfd26bf 100644 (file)
--- 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 2d1a252..c5f6cb9 100644 (file)
--- 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 85c9c11..64514d8 100644 (file)
--- 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