Inline escape-only prompt bodies in the Tree-IL

* module/language/scheme/decompile-tree-il.scm (do-decompile):
* module/language/tree-il/analyze.scm (analyze-lexicals):
* module/language/tree-il/canonicalize.scm (canonicalize):
* module/language/tree-il/compile-glil.scm (flatten-lambda-case):
* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/peval.scm (peval):
* test-suite/tests/peval.test ("partial evaluation"):  Partially revert
  178a40928, so that escape-only prompts explicitly inline their bodies.

diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index 74778b4..2decd97 100644 (file)
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -432,10 +432,12 @@
          `(call-with-values (lambda () ,@(recurse-body exp))
             ,(recurse (make-lambda #f '() body))))
 
-        ((<prompt> tag body handler)
+        ((<prompt> escape-only? tag body handler)
          `(call-with-prompt
            ,(recurse tag)
-           ,(recurse body)
+           ,(if escape-only?
+                `(lambda () ,(recurse body))
+                (recurse body))
            ,(recurse handler)))
 
 

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 6b6df18..2f6e369 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -338,15 +338,8 @@
        (lset-union eq? (step exp) (step body)))
       
       ((<prompt> escape-only? tag body handler)
-       (match x
-         ;; Escape-only: the body is inlined.
-         (($ <prompt> _ #t tag
-             ($ <lambda> _ _
-                ($ <lambda-case> _ () #f #f #f () () body #f))
-             ($ <lambda> _ _ handler))
-          (lset-union eq? (step tag) (step body) (step-tail handler)))
-         ;; Full: we make a closure.
-         (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+       (match handler
+         (($ <lambda> _ _ handler)
           (lset-union eq? (step tag) (step body) (step-tail handler)))))
       
       ((<abort> tag args tail)
@@ -509,15 +502,8 @@
        (max (recur exp) (recur body)))
       
       ((<prompt> escape-only? tag body handler)
-       (match x
-         ;; Escape-only: the body is inlined.
-         (($ <prompt> _ #t tag
-             ($ <lambda> _ _
-                ($ <lambda-case> _ () #f #f #f () () body #f))
-             ($ <lambda> _ _ handler))
-          (max (recur tag) (recur body) (recur handler)))
-         ;; Full: we make a closure.
-         (($ <prompt> _ #f tag body ($ <lambda> _ _ handler))
+       (match handler
+         (($ <lambda> _ _ handler)
           (max (recur tag) (recur body) (recur handler)))))
 
       ((<abort> tag args tail)

diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 47c1db7..9de4caa 100644 (file)
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -55,48 +55,28 @@
                  (make-const #f '())
                  (make-const #f #f)))
           #f)))
-       (($ <prompt> src)
-        (define (ensure-lambda-body prompt)
-          ;; If the prompt is escape-only, the body should be a thunk.
-          (match prompt
-            (($ <prompt> _ escape-only? tag body handler)
-             (match body
-               ((or ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
-                    (? (lambda _ (not escape-only?))))
-                prompt)
-               (else
-                (make-prompt
-                 src escape-only? tag
-                 (make-lambda #f '()
-                              (make-lambda-case #f '() #f #f #f '() '()
-                                                (make-call #f body '())
-                                                #f))
-                 handler))))))
-        (define (ensure-lambda-handler prompt)
-          (match prompt
-            (($ <prompt> _ escape-only? tag body handler)
-             ;; The prompt handler should be a simple lambda, so that we
-             ;; can inline it.
-             (match handler
-               (($ <lambda> _ _
-                   ($ <lambda-case> _ req #f rest #f () syms body #f))
-                prompt)
-               (else
-                (let ((handler-sym (gensym))
-                      (args-sym (gensym)))
-                  (make-let
-                   #f (list 'handler) (list handler-sym) (list handler)
-                   (make-prompt
-                    src escape-only? tag body
-                    (make-lambda
-                     #f '()
-                     (make-lambda-case
-                      #f '() #f 'args #f '() (list args-sym)
-                      (make-primcall
-                       #f 'apply
-                       (list (make-lexical-ref #f 'handler handler-sym)
-                             (make-lexical-ref #f 'args args-sym)))
-                      #f))))))))))
-        (ensure-lambda-handler (ensure-lambda-body x)))
+       (($ <prompt> src escape-only? tag body handler)
+        ;; The prompt handler should be a simple lambda, so that we
+        ;; can inline it.
+        (match handler
+          (($ <lambda> _ _
+              ($ <lambda-case> _ req #f rest #f () syms body #f))
+           x)
+          (else
+           (let ((handler-sym (gensym))
+                 (args-sym (gensym)))
+             (make-let
+              #f (list 'handler) (list handler-sym) (list handler)
+              (make-prompt
+               src escape-only? tag body
+               (make-lambda
+                #f '()
+                (make-lambda-case
+                 #f '() #f 'args #f '() (list args-sym)
+                 (make-primcall
+                  #f 'apply
+                  (list (make-lexical-ref #f 'handler handler-sym)
+                        (make-lexical-ref #f 'args args-sym)))
+                 #f))))))))
        (_ x)))
    x))

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index fd67471..34855b9 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -958,12 +958,7 @@
       ((<prompt> src escape-only? tag body handler)
        (let ((H (make-label))
              (POST (make-label))
-             (body (if escape-only?
-                       (match body
-                         (($ <lambda> _ _
-                             ($ <lambda-case> _ () #f #f #f () () body #f))
-                          body))
-                       (make-call #f body '()))))
+             (body (if escape-only? body (make-call #f body '()))))
 
          ;; First, set up the prompt.
          (comp-push tag)

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 9e5157c..5d0277f 100644 (file)
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -533,8 +533,9 @@
                      (concat db** db*)))))))
       (($ <prompt> src escape-only? tag body handler)
        (let*-values (((tag db*) (visit tag db env 'value))
-                     ((body _) (visit body (concat db* db) env ctx))
-                     ((handler _) (visit handler (concat db* db) env ctx)))
+                     ((body _) (visit body (concat db* db) env
+                                      (if escape-only? ctx 'value)))
+                     ((handler _) (visit handler (concat db* db) env 'value)))
          (return (make-prompt src escape-only? tag body handler)
                  db*)))
       (($ <abort> src tag args tail)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 57832a6..3d35039 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting expression."
            (_ #f)))
 
        (let ((tag (for-value tag))
-             (body (for-value body)))
+             (body (if escape-only? (for-tail body) (for-value body))))
          (cond
           ((find-definition tag 1)
            (lambda (val op)
@@ -1532,7 +1532,7 @@ top-level bindings from ENV and return the resulting expression."
                 ;; for this <prompt>, so we can elide the <prompt>
                 ;; entirely.
                 (unrecord-operand-uses op 1)
-                (for-tail (make-call src body '()))))
+                (for-tail (if escape-only? body (make-call src body '())))))
           (else
            (let ((handler (for-value handler)))
              (define (escape-only-handler? handler)
@@ -1545,8 +1545,13 @@ top-level bindings from ENV and return the resulting expression."
                          (_ #f))
                         body)))
                  (else #f)))
-             (make-prompt src (or escape-only? (escape-only-handler? handler))
-                          tag body (for-value handler)))))))
+             (if (and (not escape-only?) (escape-only-handler? handler))
+                 ;; Prompt transitioning to escape-only; transition body
+                 ;; to be an expression.
+                 (for-tail
+                  (make-prompt src #t tag (make-call #f body '()) handler))
+                 (make-prompt src escape-only? tag body handler)))))))
+
       (($ <abort> src tag args tail)
        (make-abort src (for-value tag) (map for-value args)
                    (for-value tail))))))

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 6d83fb7..0b981d8 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1137,10 +1137,7 @@
                      (lambda (k x) x))
    (prompt #t
            (toplevel tag)
-           (lambda _
-             (lambda-case
-              ((() #f #f #f () ())
-               (const 1))))
+           (const 1)
            (lambda _
              (lambda-case
               (((k x) #f #f #f () (_ _))