tree-il analyzer and inliner handle <prompt>

* module/language/tree-il/analyze.scm (analyze-lexicals): Add cases for
  <prompt>, <dynamic-wind>, and <control>. If a continuation is not
  referenced in the body of a prompt handler, mark the prompt as
  escape-only.
* module/language/tree-il/inline.scm (inline!): Inline the handler of a
  prompt if it is a simple lambda.

module/language/tree-il/analyze.scm

@@ -81,9 +81,9 @@
 ;; this specific case. A proper solution would be some sort of liveness
 ;; analysis, and not our linear allocation algorithm.
 ;;
-;; Closure variables are captured when a closure is created, and stored
+;; Closure variables are captured when a closure is created, and stored in a
-;; in a vector. Each closure variable has a unique index into that
+;; vector inline to the closure object itself. Each closure variable has a
-;; vector.
+;; unique index into that vector.
 ;;
 ;; There is one more complication. Procedures bound by <fix> may, in
 ;; some cases, be rendered inline to their parent procedure. That is to
@@ -124,11 +124,18 @@
 ;; generated code can skip argument checks at runtime if they match at
 ;; compile-time.
 ;;
+;; Also, while we're a-traversing and an-allocating, we check prompt
+;; handlers to see if the "continuation" argument is used. If not, we
+;; mark the prompt as being "escape-only". This allows us to implement
+;; `catch' and `throw' using `prompt' and `control', but without causing
+;; a continuation to be reified. Heh heh.
+;;
 ;; That is:
 ;;
 ;;  sym -> {lambda -> address}
 ;;  lambda -> (labels . free-locs)
 ;;  lambda-case -> (gensym . nlocs)
+;;  prompt -> escape-only?
 ;;
 ;; address ::= (local? boxed? . index)
 ;; labels ::= ((sym . lambda) ...)
@@ -328,6 +335,16 @@
       ((<let-values> exp body)
        (lset-union eq? (step exp) (step body)))
       
+      ((<dynamic-wind> body winder unwinder)
+       (lset-union eq? (step body) (step winder) (step unwinder)))
+      
+      ((<prompt> tag body handler pre-unwind-handler)
+       (lset-union eq? (step tag) (step handler)
+                   (if pre-unwind-handler (step pre-unwind-handler) '())))
+      
+      ((<control> tag type args)
+       (apply lset-union eq? (step tag) (map step args)))
+      
       (else '())))
   
   ;; allocation: sym -> {lambda -> address}
@@ -479,6 +496,21 @@
       ((<let-values> exp body)
        (max (recur exp) (recur body)))
       
+      ((<dynamic-wind> body winder unwinder)
+       (max (recur body) (recur winder) (recur unwinder)))
+      
+      ((<prompt> tag body handler pre-unwind-handler)
+       (let ((cont-var (and (lambda-case? handler)
+                            (pair? (lambda-case-vars handler))
+                            (car (lambda-case-vars handler)))))
+         (hashq-set! allocation x
+                     (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
+         (max (recur tag) (recur body) (recur handler)
+              (if pre-unwind-handler (recur pre-unwind-handler) 0))))
+      
+      ((<control> tag type args)
+       (apply max (recur tag) (map recur args)))
+      
       (else n)))
 
   (analyze! x #f '() #t #f)

module/language/tree-il/inline.scm

@@ -1,6 +1,6 @@
 ;;; a simple inliner
 
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -110,5 +110,15 @@
       ((<fix> vars body)
        (if (null? vars) body x))
        
+      ((<prompt> src tag body handler pre-unwind-handler)
+       ;; If the handler is a simple lambda, inline it.
+       (if (and (lambda? handler)
+                (record-case (lambda-body handler)
+                  ((<lambda-case> req opt kw rest alternate)
+                   (and (pair? req) (not opt) (not kw) (not alternate)))
+                  (else #f)))
+           (make-prompt src tag body (lambda-body handler) pre-unwind-handler)
+           x))
+       
       (else #f)))
   (post-order! inline1 x))