From: Andy Wingo <wingo@pobox.com>
Date: Sat, 6 Jul 2013 11:06:02 +0000 (+0900)
Subject: <prompt> body and handler are lambdas; add escape-only? field
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/178a40928ab5221f6ce57c5af1067abe30a342b3

<prompt> body and handler are lambdas; add escape-only? field

* module/language/tree-il.scm (<prompt>): Change to have the body and
  handler be lambdas, and add an "escape-only?" field.  This will make
  generic prompts work better in CPS or ANF with the RTL VM, as it
  doesn't make sense in that context to capture only part of a frame.
  Escape-only prompts can still be fully inlined.
  (parse-tree-il, unparse-tree-il): Add escape-only? to the
  serialization.
  (make-tree-il-folder, pre-post-order): Deal with escape-only?.

* module/language/tree-il/analyze.scm (analyze-lexicals): Handle
  escape-only?, and the new expectations for the body and handler.

* module/language/tree-il/canonicalize.scm (canonicalize): Ensure that
  the body of an escape-only continuation is a thunk, and that the
  handler is always a lambda.
* module/language/tree-il/debug.scm (verify-tree-il): Assert that
  escape-only? is a boolean.

* module/language/tree-il/cse.scm (cse):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/peval.scm (peval):
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
* test-suite/tests/peval.test ("partial evaluation"):
* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Adapt
  to <prompt> change.
---

diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
index dca969f92..74778b4ca 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -435,7 +435,7 @@
         ((<prompt> tag body handler)
          `(call-with-prompt
            ,(recurse tag)
-           (lambda () ,@(recurse-body body))
+           ,(recurse body)
            ,(recurse handler)))
 
 
@@ -746,7 +746,6 @@
 
             ((<prompt> tag body handler)
              (primitive 'call-with-prompt)
-             (primitive 'lambda)
              (recurse tag) (recurse body) (recurse handler))
 
             ((<abort> tag args tail)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 16fdb96e5..4ae1484cb 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -39,6 +39,7 @@
             <seq> seq? make-seq seq-src seq-head seq-tail
             <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
             <lambda-case> lambda-case? make-lambda-case lambda-case-src
+            ;; idea: arity
                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
                           lambda-case-inits lambda-case-gensyms
                           lambda-case-body lambda-case-alternate
@@ -46,7 +47,7 @@
             <letrec> letrec? make-letrec letrec-src letrec-in-order? 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
-            <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
+            <prompt> prompt? make-prompt prompt-src prompt-escape-only? prompt-tag prompt-body prompt-handler
             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
 
             list->seq
@@ -131,7 +132,7 @@
 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
   (<fix> names gensyms vals body)
   (<let-values> exp body)
-  (<prompt> tag body handler)
+  (<prompt> escape-only? tag body handler)
   (<abort> tag args tail))
 
 
@@ -241,8 +242,9 @@
      (('let-values exp body)
       (make-let-values loc (retrans exp) (retrans body)))
 
-     (('prompt tag body handler)
-      (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
+     (('prompt escape-only? tag body handler)
+      (make-prompt loc escape-only?
+                   (retrans tag) (retrans body) (retrans handler)))
      
      (('abort tag args tail)
       (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
@@ -319,8 +321,9 @@
     (($ <let-values> src exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    (($ <prompt> src tag body handler)
-     `(prompt ,(unparse-tree-il tag)
+    (($ <prompt> src escape-only? tag body handler)
+     `(prompt ,escape-only?
+              ,(unparse-tree-il tag)
               ,(unparse-tree-il body)
               ,(unparse-tree-il handler)))
 
@@ -389,7 +392,7 @@
               (($ <let-values> src exp body)
                (let*-values (((seed ...) (foldts exp seed ...)))
                  (foldts body seed ...)))
-              (($ <prompt> src tag body handler)
+              (($ <prompt> src escape-only? tag body handler)
                (let*-values (((seed ...) (foldts tag seed ...))
                              ((seed ...) (foldts body seed ...)))
                  (foldts handler seed ...)))
@@ -479,8 +482,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
        (($ <let-values> src exp body)
         (make-let-values src (lp exp) (lp body)))
 
-       (($ <prompt> src tag body handler)
-        (make-prompt src (lp tag) (lp body) (lp handler)))
+       (($ <prompt> src escape-only? tag body handler)
+        (make-prompt src escape-only? (lp tag) (lp body) (lp handler)))
 
        (($ <abort> src tag args tail)
         (make-abort src (lp tag) (map lp args) (lp tail)))))))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index ca7cb80a4..6b6df18c3 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -337,8 +337,17 @@
       ((<let-values> exp body)
        (lset-union eq? (step exp) (step body)))
       
-      ((<prompt> tag body handler)
-       (lset-union eq? (step tag) (step body) (step-tail handler)))
+      ((<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))
+          (lset-union eq? (step tag) (step body) (step-tail handler)))))
       
       ((<abort> tag args tail)
        (apply lset-union eq? (step tag) (step tail) (map step args)))
@@ -499,14 +508,18 @@
       ((<let-values> exp body)
        (max (recur exp) (recur body)))
       
-      ((<prompt> tag body handler)
-       (let ((cont-var (and (lambda-case? 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))))
-      
+      ((<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))
+          (max (recur tag) (recur body) (recur handler)))))
+
       ((<abort> tag args tail)
        (apply max (recur tag) (recur tail) (map recur args)))
       
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 9b0c0c8cd..47c1db7ac 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -55,33 +55,48 @@
                  (make-const #f '())
                  (make-const #f #f)))
           #f)))
-       (($ <prompt> src tag body handler)
-        (define (escape-only? handler)
-          (match handler
-            (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
-             (not (tree-il-any (lambda (x)
-                                 (and (lexical-ref? x)
-                                      (eq? (lexical-ref-gensym x) cont)))
-                               body)))
-            (else #f)))
-        (define (thunk-application? x)
-          (match x
-            (($ <call> _
-                ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
-                ()) #t)
-            (_ #f)))
-        (define (make-thunk-application body)
-          (define thunk
-            (make-lambda #f '()
-                         (make-lambda-case #f '() #f #f #f '() '() body #f)))
-          (make-call #f thunk '()))
-
-        ;; This code has a nasty job to do: to ensure that either the
-        ;; handler is escape-only, or the body is the application of a
-        ;; thunk.  Sad but true.
-        (if (or (escape-only? handler)
-                (thunk-application? body))
-            x
-            (make-prompt src tag (make-thunk-application body) handler)))
+       (($ <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)))
        (_ x)))
    x))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 96a06ab71..fd67471f2 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -23,6 +23,7 @@
   #:use-module (system base pmatch)
   #:use-module (system base message)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
   #:use-module (language glil)
   #:use-module (system vm instruction)
   #:use-module (language tree-il)
@@ -954,10 +955,16 @@
       ;; if the continuation isn't referenced, we don't reify it. This makes it
       ;; possible to implement catch and throw with delimited continuations,
       ;; without any overhead.
-      ((<prompt> src tag body handler)
+      ((<prompt> src escape-only? tag body handler)
        (let ((H (make-label))
              (POST (make-label))
-             (escape-only? (hashq-ref allocation x)))
+             (body (if escape-only?
+                       (match body
+                         (($ <lambda> _ _
+                             ($ <lambda-case> _ () #f #f #f () () body #f))
+                          body))
+                       (make-call #f body '()))))
+
          ;; First, set up the prompt.
          (comp-push tag)
          (emit-code src (make-glil-prompt H escape-only?))
@@ -1003,15 +1010,15 @@
          ;; Now the handler. The stack is now made up of the continuation, and
          ;; 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 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) '()))
-                             gensyms allocation self)
-                            (and rest #t)))
+         (match handler
+           (($ <lambda> src meta
+               ($ <lambda-case> lsrc req #f rest #f () gensyms body #f))
+            (emit-code (or lsrc src)
+                       (make-glil-mv-bind
+                        (vars->bind-list
+                         (append req (if rest (list rest) '()))
+                         gensyms allocation self)
+                        (and rest #t)))
             (for-each (lambda (v)
                         (pmatch (hashq-ref (hashq-ref allocation v) self)
                           ((#t #f . ,n)
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 656dd72c6..9e5157c73 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -531,11 +531,11 @@
            (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
              (values (make-seq src head tail)
                      (concat db** db*)))))))
-      (($ <prompt> src tag body handler)
+      (($ <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)))
-         (return (make-prompt src tag body handler)
+         (return (make-prompt src escape-only? tag body handler)
                  db*)))
       (($ <abort> src tag args tail)
        (let*-values (((tag db*) (visit tag db env 'value))
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 8ec573a73..613dc2ea6 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -226,7 +226,9 @@
       (($ <seq> src head tail)
        (visit head env)
        (visit tail env))
-      (($ <prompt> src tag body handler)
+      (($ <prompt> src escape-only? tag body handler)
+       (unless (boolean? escape-only?)
+         (error "escape-only? should be a bool" escape-only?))
        (visit tag env)
        (visit body env)
        (visit handler env))
diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 467e4366a..6302662a8 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -361,7 +361,7 @@ of an expression."
                              (cause &zero-values))
             (compute-effects tail)))
 
-          (($ <prompt> _ tag body handler)
+          (($ <prompt> _ escape-only? tag body handler)
            (logior (compute-effects tag)
                    (compute-effects body)
                    (compute-effects handler)))
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 5b9852b01..af00e9904 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1514,7 +1514,7 @@ top-level bindings from ENV and return the resulting expression."
                            (seq-head head)
                            head)
                        tail))))
-      (($ <prompt> src tag body handler)
+      (($ <prompt> src escape-only? tag body handler)
        (define (make-prompt-tag? x)
          (match x
            (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
@@ -1522,7 +1522,7 @@ top-level bindings from ENV and return the resulting expression."
            (_ #f)))
 
        (let ((tag (for-value tag))
-             (body (for-tail body)))
+             (body (for-value body)))
          (cond
           ((find-definition tag 1)
            (lambda (val op)
@@ -1532,31 +1532,56 @@ 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)
-                body))
+                (for-tail (make-call src body '()))))
           ((find-definition tag 2)
            (lambda (val op)
              (and (make-prompt-tag? val)
-                  (abort? body)
-                  (tree-il=? (abort-tag body) tag)))
+                  (match body
+                    (($ <lambda> _ _
+                        ($ <lambda-case> _ () #f #f #f () ()
+                           ($ <abort> _ (? (cut tree-il=? <> tag)))))
+                     #t)
+                    (else #f))))
            => (lambda (val op)
                 ;; (let ((t (make-prompt-tag)))
                 ;;   (call-with-prompt t
                 ;;     (lambda () (abort-to-prompt t val ...))
                 ;;     (lambda (k arg ...) e ...)))
-                ;; => (let-values (((k arg ...) (values values val ...)))
-                ;;      e ...)
+                ;; => (call-with-values (lambda () (values values val ...))
+                ;;      (lambda (k arg ...) e ...))
                 (unrecord-operand-uses op 2)
-                (for-tail
-                 (make-let-values
-                  src
-                  (make-primcall #f 'apply
-                                 `(,(make-primitive-ref #f 'values)
-                                   ,(make-primitive-ref #f 'values)
-                                   ,@(abort-args body)
-                                   ,(abort-tail body)))
-                  (for-value handler)))))
+                (match body
+                  (($ <lambda> _ _
+                      ($ <lambda-case> _ () #f #f #f () ()
+                         ($ <abort> _ _ args tail)))
+                   (for-tail
+                    (make-primcall
+                     src 'call-with-values
+                     (list (make-lambda
+                            #f '()
+                            (make-lambda-case
+                             #f '() #f #f #f '() '()
+                             (make-primcall #f 'apply
+                                            `(,(make-primitive-ref #f 'values)
+                                              ,(make-primitive-ref #f 'values)
+                                              ,@args
+                                              ,tail))
+                             #f))
+                           handler)))))))
           (else
-           (make-prompt src tag body (for-value handler))))))
+           (let ((handler (for-value handler)))
+             (define (escape-only-handler? handler)
+               (match handler
+                 (($ <lambda> _ _
+                     ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
+                  (not (tree-il-any
+                        (match-lambda
+                         (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+                         (_ #f))
+                        body)))
+                 (else #f)))
+             (make-prompt src (or escape-only? (escape-only-handler? handler))
+                          tag body (for-value handler)))))))
       (($ <abort> src tag args tail)
        (make-abort src (for-value tag) (map for-value args)
                    (for-value tail))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 8cb090a24..f738b7459 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -538,21 +538,7 @@
             'call-with-prompt
             (case-lambda
               ((src tag thunk handler)
-               (let ((handler-sym (gensym))
-                     (args-sym (gensym)))
-                 (make-let
-                  src '(handler) (list handler-sym) (list handler)
-                  (make-prompt
-                   src tag (make-call #f thunk '())
-                   ;; If handler itself is a lambda, the inliner can do some
-                   ;; trickery here.
-                   (make-lambda-case
-                    (tree-il-src handler) '() #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)))))
+               (make-prompt src #f tag thunk handler))
               (else #f)))
 
 (hashq-set! *primitive-expand-table*
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index b8d753378..cb01b4b68 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1135,25 +1135,29 @@
    (call-with-prompt tag
                      (lambda () 1)
                      (lambda (k x) x))
-   (prompt (toplevel tag)
-           (const 1)
-           (lambda-case
-            (((k x) #f #f #f () (_ _))
-             (lexical x _)))))
+   (prompt #t
+           (toplevel tag)
+           (lambda _
+             (lambda-case
+              ((() #f #f #f () ())
+               (const 1))))
+           (lambda _
+             (lambda-case
+              (((k x) #f #f #f () (_ _))
+               (lexical x _))))))
 
   ;; Handler toplevel not inlined
   (pass-if-peval
-   (call-with-prompt tag
-                     (lambda () 1)
-                     handler)
-   (let (handler) (_) ((toplevel handler))
-        (prompt (toplevel tag)
-                (const 1)
-                (lambda-case
-                 ((() #f args #f () (_))
-                  (primcall apply
-                            (lexical handler _)
-                            (lexical args _)))))))
+      (call-with-prompt tag
+                        (lambda () 1)
+                        handler)
+    (prompt #f
+            (toplevel tag)
+            (lambda _
+              (lambda-case
+               ((() #f #f #f () ())
+                (const 1))))
+            (toplevel handler)))
 
   (pass-if-peval
    ;; `while' without `break' or `continue' has no prompts and gets its