From: Andy Wingo <wingo@pobox.com>
Date: Fri, 28 Mar 2014 16:51:37 +0000 (+0100)
Subject: Prompt-related refactor in compile-cps
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/ef58442a0541eb382476d833f540fff01a4e4007

Prompt-related refactor in compile-cps

* module/language/tree-il/compile-cps.scm (fix-prompts): New procedure.
  Eta-expand prompts before compiling to ensure that they have inline
  handlers.
---

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 0fc186294..6f5467869 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -464,41 +464,6 @@
                               ($continue kbody (tree-il-src body)
                                 ($prompt #f tag khargs))))))))))))))
 
-    ;; Eta-convert prompts without inline handlers.
-    (($ <prompt> src escape-only? tag body handler)
-     (let ((h (gensym "h "))
-           (args (gensym "args ")))
-       (convert
-        (make-let
-         src (list 'h) (list h) (list handler)
-         (make-seq
-          src
-          (make-conditional
-           src
-           (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
-           (make-void src)
-           (make-primcall
-            src 'scm-error
-            (list
-             (make-const #f 'wrong-type-arg)
-             (make-const #f "call-with-prompt")
-             (make-const #f "Wrong type (expecting procedure): ~S")
-             (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
-             (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
-          (make-prompt
-           src escape-only? tag body
-           (make-lambda
-            src '()
-            (make-lambda-case
-             src '() #f 'args #f '() (list args)
-             (make-primcall
-              src 'apply
-              (list (make-lexical-ref #f 'h h)
-                    (make-lexical-ref #f 'args args)))
-             #f)))))
-        k
-        subst)))
-
     (($ <abort> src tag args ($ <const> _ ()))
      (convert-args (cons tag args)
        (lambda (args*)
@@ -663,8 +628,52 @@ indicates that the replacement variable is in a box."
 
   (optimize x e opts))
 
+(define (fix-prompts exp)
+  (post-order
+   (lambda (exp)
+     (match exp
+       (($ <prompt> src escape-only? tag body
+           ($ <lambda> hsrc hmeta
+              ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+        exp)
+
+       ;; Eta-convert prompts without inline handlers.
+       (($ <prompt> src escape-only? tag body handler)
+        (let ((h (gensym "h "))
+              (args (gensym "args ")))
+          (make-let
+           src (list 'h) (list h) (list handler)
+           (make-seq
+            src
+            (make-conditional
+             src
+             (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+             (make-void src)
+             (make-primcall
+              src 'scm-error
+              (list
+               (make-const #f 'wrong-type-arg)
+               (make-const #f "call-with-prompt")
+               (make-const #f "Wrong type (expecting procedure): ~S")
+               (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+               (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+            (make-prompt
+             src escape-only? tag body
+             (make-lambda
+              src '()
+              (make-lambda-case
+               src '() #f 'args #f '() (list args)
+               (make-primcall
+                src 'apply
+                (list (make-lexical-ref #f 'h h)
+                      (make-lexical-ref #f 'args args)))
+               #f)))))))
+       (_ exp)))
+   exp))
+
 (define (compile-cps exp env opts)
-  (values (cps-convert/thunk (optimize-tree-il exp env opts))
+  (values (cps-convert/thunk
+           (fix-prompts (optimize-tree-il exp env opts)))
           env
           env))