compiler: block escape list.

The new dynamic variable *esc-blocks* keeps track of
what blocks, in a given scope, may be abandoned by
a simple jmp instruction instead of a full blown
dynamic return. We will not try to handle unwinding
statically; any contour that needs unwinding cannot
be jumped across.

* stdlib/compiler.tl (*esc-blocks*): New special variable.
(compile-in-top-level): Clear *esc-blocks* for
top-level compilations.
(compiler (comp-unwind-protect, comp-catch,
comp-lambda-impl, comp-prof): These contexts cannot be
abandoned by a jmp instruction: we cannot jump out of
the middle of an unwind-protect, catch, lambda or prof.
So we compile these with *esc-blocks* set to nil.
New blocks entirely contained in these constructs can
of course build up the list locally. E.g. within a function,
of course we can have blocks that are abandoned by a
simple jmp instruction. Just we cannot jump out.
(compiler comp-block): When compiling a block, we bind
*esc-blocks* to a list consisting of the previous value,
plus the new block name consed to the front.

1 files changed, 9 insertions, 1 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index 0ad03aea..f3c27153 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -253,7 +253,8 @@
     (with-gensyms (saved-tregs saved-treg-cntr)
       ^(let* ((,saved-tregs (qref ,me tregs))
               (,saved-treg-cntr (qref ,me treg-cntr))
-              (*tail-pos* nil))
+              (*tail-pos* nil)
+              (*esc-blocks* nil))
          (unwind-protect
            (progn
              (set (qref ,me tregs) nil
@@ -341,6 +342,8 @@
 
 (defvar *tail-fun*)
 
+(defvar *esc-blocks*)
+
 ;; 0 - no optimization
 ;; 1 - constant folding, algebraics.
 ;; 2 - block elimination, frame elimination, self tail calls
@@ -804,6 +807,7 @@
 (defmeth compiler comp-unwind-protect (me oreg env form)
   (mac-param-bind form (t prot-form . cleanup-body) form
     (let* ((*tail-pos* nil)
+           (*esc-blocks* nil)
            (treg me.(alloc-treg))
            (pfrag me.(compile oreg env prot-form))
            (cfrag me.(comp-progn treg env cleanup-body))
@@ -836,6 +840,7 @@
            (treg (if star me.(maybe-alloc-treg oreg)))
            (nfrag (if star (ntp me.(compile treg env name))))
            (nreg (if star nfrag.oreg me.(get-dreg name)))
+           (*esc-blocks* (cons name *esc-blocks*))
            (bfrag me.(comp-progn oreg (or nenv env) body))
            (lskip (gensym "l")))
       (when treg
@@ -901,6 +906,7 @@
       me.(compile oreg env try-expr)
       (with-gensyms (ex-sym-var ex-args-var)
         (let* ((*tail-pos* nil)
+               (*esc-blocks* nil)
                (nenv (new env up env co me))
                (esvb nenv.(extend-var ex-sym-var))
                (eavb nenv.(extend-var ex-args-var))
@@ -1129,6 +1135,7 @@
                (tfn *tail-fun*)
                (tpos nil)
                (tco *compile-opts*.opt-tail-calls)
+               (*esc-blocks* nil)
                (pars (new (fun-param-parser par-syntax form)))
                (need-frame (or (plusp pars.nfix) pars.rest))
                (nenv (if need-frame (new env up env co me) env))
@@ -1770,6 +1777,7 @@
 (defmeth compiler comp-prof (me oreg env form)
   (mac-param-bind form (t . forms) form
     (let ((*tail-pos* nil)
+          (*esc-blocks* nil)
           (bfrag me.(comp-progn oreg env forms)))
       (new (frag oreg
                  ^((prof ,oreg)