From ac644098bf1573cfbb4ee032e6cd32a23ca168b6 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 24 Feb 2010 00:32:07 +0100
Subject: [PATCH] ensure non-escape-only prompts have a thunk application as
 their body

* module/language/tree-il/inline.scm (inline!): Fix indenting for
  lambda-case. In an amusing turn of events, use the inliner to
  de-inline prompt bodies, if the prompt is not escape-only.
---
 module/language/tree-il/inline.scm | 68 +++++++++++++++++++++---------
 1 file changed, 47 insertions(+), 21 deletions(-)

diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index 905622d65..4e3863ef6 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -111,28 +111,54 @@
        (if (null? vars) body x))
        
       ((<lambda-case> req opt rest kw vars body alternate)
-       (let ()
-         (define (args-compatible? args vars)
-           (let lp ((args args) (vars vars))
-             (cond
-              ((null? args) (null? vars))
-              ((null? vars) #f)
-              ((and (lexical-ref? (car args))
-                    (eq? (lexical-ref-gensym (car args)) (car vars)))
-               (lp (cdr args) (cdr vars)))
-              (else #f))))
+       (define (args-compatible? args vars)
+         (let lp ((args args) (vars vars))
+           (cond
+            ((null? args) (null? vars))
+            ((null? vars) #f)
+            ((and (lexical-ref? (car args))
+                  (eq? (lexical-ref-gensym (car args)) (car vars)))
+             (lp (cdr args) (cdr vars)))
+            (else #f))))
          
-         (and (not opt) (not kw) (not alternate)
-              (record-case body
-                ((<application> proc args)
-                 ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
-                 (and (primitive-ref? proc)
-                      (eq? (primitive-ref-name proc) '@apply)
-                      (pair? args)
-                      (lambda? (car args))
-                      (args-compatible? (cdr args) vars)
-                      (lambda-body (car args))))
-                (else #f)))))
+       (and (not opt) (not kw) (not alternate)
+            (record-case body
+              ((<application> proc args)
+               ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+               (and (primitive-ref? proc)
+                    (eq? (primitive-ref-name proc) '@apply)
+                    (pair? args)
+                    (lambda? (car args))
+                    (args-compatible? (cdr args) vars)
+                    (lambda-body (car args))))
+              (else #f))))
+
+      ;; Actually the opposite of inlining -- if the prompt cannot be proven to
+      ;; be escape-only, ensure that its body is the application of a thunk.
+      ((<prompt> src tag body handler)
+       (define (escape-only? handler)
+         (and (pair? (lambda-case-req handler))
+              (let ((cont (car (lambda-case-vars handler))))
+                (tree-il-fold (lambda (leaf escape-only?)
+                                (and escape-only?
+                                     (not
+                                      (and (lexical-ref? leaf)
+                                           (eq? (lexical-ref-gensym leaf) cont)))))
+                              (lambda (down escape-only?) escape-only?)
+                              (lambda (up escape-only?) escape-only?)
+                              #t
+                              (lambda-case-body handler)))))
+       (define (make-thunk body)
+         (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
+
+       (if (or (and (application? body)
+                    (lambda? (application-proc body))
+                    (null? (application-args body)))
+               (escape-only? handler))
+           x
+           (make-prompt src tag
+                        (make-application #f (make-thunk body) '())
+                        handler)))
       
       (else #f)))
   (post-order! inline1 x))