diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 122b88056..b80dd89c6 100644 --- a/module/language/tree-il/analyze.scm +++ b/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 -;; in a vector. Each closure variable has a unique index into that -;; vector. +;; Closure variables are captured when a closure is created, and stored in a +;; vector inline to the closure object itself. Each closure variable has a +;; unique index into that vector. ;; ;; There is one more complication. Procedures bound by 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 @@ (( exp body) (lset-union eq? (step exp) (step body))) + (( body winder unwinder) + (lset-union eq? (step body) (step winder) (step unwinder))) + + (( tag body handler pre-unwind-handler) + (lset-union eq? (step tag) (step handler) + (if pre-unwind-handler (step pre-unwind-handler) '()))) + + (( tag type args) + (apply lset-union eq? (step tag) (map step args))) + (else '()))) ;; allocation: sym -> {lambda -> address} @@ -479,6 +496,21 @@ (( exp body) (max (recur exp) (recur body))) + (( body winder unwinder) + (max (recur body) (recur winder) (recur unwinder))) + + (( 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)))) + + (( tag type args) + (apply max (recur tag) (map recur args))) + (else n))) (analyze! x #f '() #t #f) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index fa1c1d565..ec030c89a 100644 --- a/module/language/tree-il/inline.scm +++ b/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 @@ (( vars body) (if (null? vars) body x)) + (( 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) + (( 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))