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? make-let-values let-values-src let-values-exp let-values-body dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body + dynref? make-dynref dynref-src dynref-fluid + dynset? make-dynset dynset-src dynset-fluid dynset-exp prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler abort? make-abort abort-src abort-tag abort-args @@ -81,6 +83,8 @@ ( exp body) ( winder body unwinder) ( fluids vals body) + ( fluid) + ( fluid exp) ( tag body handler) ( 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))) + (( fluid) + `(dynref ,(unparse-tree-il fluid))) + + (( fluid exp) + `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) + (( 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))) + (( fluid) + `(fluid-ref ,(tree-il->scheme fluid))) + + (( fluid exp) + `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp))) + (( 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)))))) + (( fluid) + (up tree (loop fluid (down tree result)))) + (( fluid exp) + (up tree (loop exp (loop fluid (down tree result))))) (( 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 ...))) + (( fluid) + (foldts fluid seed ...)) + (( fluid exp) + (let*-values (((seed ...) (foldts fluid seed ...))) + (foldts exp seed ...))) (( 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))) + (( fluid) + (set! (dynref-fluid x) (lp fluid))) + + (( fluid exp) + (set! (dynset-fluid x) (lp fluid)) + (set! (dynset-exp x) (lp exp))) + (( 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))) + (( fluid) + (set! (dynref-fluid x) (lp fluid))) + + (( fluid exp) + (set! (dynset-fluid x) (lp fluid)) + (set! (dynset-exp x) (lp exp))) + (( 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 @@ (( fluids vals body) (apply lset-union eq? (step body) (map step (append fluids vals)))) + (( fluid) + (step fluid)) + + (( fluid exp) + (lset-union eq? (step fluid) (step exp))) + (( tag body handler) (lset-union eq? (step tag) (step handler))) @@ -505,6 +511,12 @@ (( fluids vals body) (apply max (recur body) (map recur (append fluids vals)))) + (( fluid) + (recur fluid)) + + (( fluid exp) + (max (recur fluid) (recur exp))) + (( 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))))) + (( 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)) + + (( 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