Ensure <prompt> handler is values handler

* module/language/tree-il/primitives.scm (call-with-prompt): Only pass
  "values handlers" as handler: lambdas with only req and rest args, and
  only one clause.
* module/language/tree-il/compile-cps.scm (canonicalize): Remove
  eta-conversion pass here.
* test-suite/tests/peval.test ("partial evaluation"): Adapt test.

3 files changed, 46 insertions, 34 deletions

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 8f048a504..5d3457e16 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2556,32 +2556,6 @@ integer."
                 (make-primcall src 'rsh (list a n)))
               (make-primcall src 'lsh (list a b)))))))
 
-       ;; Eta-convert prompts without inline handlers.
-       (($ <prompt> src escape-only? tag body handler)
-        (let ((h (gensym "h "))
-              (args (gensym "args ")))
-          (define-syntax-rule (primcall name . args)
-            (make-primcall src 'name (list . args)))
-          (define-syntax-rule (const val)
-            (make-const src val))
-          (with-lexicals src (handler)
-            (make-conditional
-             src
-             (primcall procedure? handler)
-             (make-prompt
-              src escape-only? tag body
-              (make-lambda
-               src '()
-               (make-lambda-case
-                src '() #f 'args #f '() (list args)
-                (primcall apply handler (make-lexical-ref #f 'args args))
-                #f)))
-             (primcall throw
-                       (const 'wrong-type-arg)
-                       (const "call-with-prompt")
-                       (const "Wrong type (expecting procedure): ~S")
-                       (primcall cons handler (const '()))
-                       (primcall cons handler (const '())))))))
        (_ exp)))
    exp))
 
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 300080d45..b1fa344af 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -651,7 +651,37 @@
 (define-primitive-expander! 'call-with-prompt
   (case-lambda
    ((src tag thunk handler)
-    (make-prompt src #f tag thunk handler))
+    (match handler
+      (($ <lambda> _ _ ($ <lambda-case> _ _ #f _ #f () _ _ #f))
+       (make-prompt src #f tag thunk handler))
+      (_
+       ;; Eta-convert prompts without inline handlers.
+       (let ((h (gensym "h "))
+             (args (gensym "args ")))
+         (define-syntax-rule (primcall name . args)
+           (make-primcall src 'name (list . args)))
+         (define-syntax-rule (const val)
+           (make-const src val))
+         (make-let
+          src (list 'handler) (list h) (list handler)
+          (let ((handler (make-lexical-ref src 'handler h)))
+            (make-conditional
+             src
+             (primcall procedure? handler)
+             (make-prompt
+              src #f tag thunk
+              (make-lambda
+               src '()
+               (make-lambda-case
+                src '() #f 'args #f '() (list args)
+                (primcall apply handler (make-lexical-ref #f 'args args))
+                #f)))
+             (primcall throw
+                       (const 'wrong-type-arg)
+                       (const "call-with-prompt")
+                       (const "Wrong type (expecting procedure): ~S")
+                       (primcall list handler)
+                       (primcall list handler)))))))))
    (else #f)))
 
 (define-primitive-expander! 'abort-to-prompt*
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 2eecc8218..3805259f0 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1223,13 +1223,21 @@
       (call-with-prompt tag
                         (lambda () 1)
                         handler)
-    (prompt #f
-            (toplevel tag)
-            (lambda _
-              (lambda-case
-               ((() #f #f #f () ())
-                (const 1))))
-            (toplevel handler)))
+    (let (handler) (_) ((toplevel handler))
+         (if (primcall procedure? (lexical handler _))
+             (prompt #f
+                     (toplevel tag)
+                     (lambda _
+                       (lambda-case
+                        ((() #f #f #f () ())
+                         (const 1))))
+                     (lambda _
+                       (lambda-case
+                        ((() #f args #f () (_))
+                         (primcall apply
+                                   (lexical handler _)
+                                   (lexical args _))))))
+             (primcall throw . _))))
 
   (pass-if-peval
    ;; `while' without `break' or `continue' has no prompts and gets its