mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 13:00:34 +02:00
Code Activity

tree-il analyzer and inliner handle <prompt>

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-01-30 15:49:50 +01:00
parent 1bf78495e9
commit 282d128cb4
2 changed files with 46 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/tree-il/analyze.scm
View file

@ -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 <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)

12
module/language/tree-il/inline.scm
View file

@ -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))