compiler: optimized block returns.

* stdlib/compiler.t (blockinfo): New slots: label, oreg.
These inform the compiler, when it is generating a
jump out of a block, what register to put in the
block return value and where to jump.
(env lookup-block): Lose the mark-used optional
argument; this function is only called in one place,
and that place will now decide whether to mark the
block used after doing the lookup, not before.
(env extend-block): Add the parameters label and
oreg, to pass through these values to the block-info
structure's new slots.
(compiler): New slot: bjmp-occurs. We are going to use a
pseudo instruction (bjmp ...) to denote a call out of
a block similarly to how we used (tjmp ...) for a tail
call. There will be a similar post-processing needed for
them.
(compiler comp-block): Pass oreg and lskip to extend-block,
so block returns in the inner compilation have this info
if they need to compile a direct jump out of the block.
The *esc-blocks* needs to be set conditionally. If we
are compiling a block*, then name is not a symbol but
an expression evaluating to it, and so we don't extend
*esc-blocks*; there can be no direct jumps out of a
block with a dynamic name. (Or perhaps there could be with
more complication and more work).  The case when the block
is eliminated is more complicated now. Even though the block
is eliminated, there can be jumps out of that block in the
code. Those jumps expect the output register to be oreg
and they expect the lskip label to be present, so we need
to add these features to the bfrag.code and also adjust
bfrag.oreg.
(compiler comp-return-from): We use *esc-blocks* to decide
whether to compile a jmp or a dynamic block return.
In the one case, we must inform the compiler structure
that a bjmp instruction is now present. In the other we
must indicate that the block is used for a dynamic transfer,
and so cannot be optimized away.
(convert-tjmps): Rename to convert-t-b-jmps and handle
the bjmp instruction. When a (bjmp <label>) is seen, we
scan forward to an occurrence of <label>, similarly to
how for a (tjmp <...>) we scan toward a (jend ...)
function end. We insert any intervening end instructions
before the bjmp and convert to jmp.
(compiler optimize): Call convert-t-b-jmps if either the
tjmp-occurs or bjmp-occurs flag is set. These flags
could be merged into a single one, but let's leave it
for now.

1 files changed, 49 insertions, 20 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index f3c27153..7ad727e0 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -56,6 +56,8 @@
 
 (defstruct blockinfo nil
   sym
+  label
+  oreg
   used
   sys:env)
 
@@ -103,13 +105,10 @@
       (((up me.up)) up.(lookup-lisp1 sym mark-used))
       (t nil)))
 
-  (:method lookup-block (me sym : mark-used)
+  (:method lookup-block (me sym)
     (condlet
-      (((cell (assoc sym me.bb)))
-       (let ((bi (cdr cell)))
-         (if mark-used (set bi.used t))
-         bi))
-      (((up me.up)) up.(lookup-block sym mark-used))
+      (((cell (assoc sym me.bb))) (cdr cell))
+      (((up me.up)) up.(lookup-block sym))
       (t nil)))
 
   (:method get-loc (me)
@@ -166,8 +165,8 @@
       (let ((lev (ssucc (cadr reg))))
         (< me.lev lev))))
 
-  (:method extend-block (me sym)
-    (let* ((bn (new blockinfo sym sym env me)))
+  (:method extend-block (me sym label oreg)
+    (let* ((bn (new blockinfo sym sym label label oreg oreg env me)))
       (set me.bb (acons sym bn me.bb))))
  
   (:method unused-check (me form nuance)
@@ -231,6 +230,7 @@
     closure-spies
     access-spies
     tjmp-occurs
+    bjmp-occurs
 
     (:method snapshot (me)
       (let ((snap (copy me)))
@@ -835,14 +835,16 @@
     (let* ((star (and name (eq op 'block*)))
            (nenv (unless star
                    (new env up env lev env.lev co me)))
+           (lskip (gensym "l"))
            (binfo (unless star
-                    (cdar nenv.(extend-block name))))
+                    (cdar nenv.(extend-block name lskip oreg))))
            (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")))
+           (*esc-blocks* (if star
+                           *esc-blocks*
+                           (cons name *esc-blocks*)))
+           (bfrag me.(comp-progn oreg (or nenv env) body)))
       (when treg
         me.(maybe-free-treg treg oreg))
       (if (and (>= *opt-level* 2)
@@ -852,7 +854,11 @@
                  [all bfrag.ffuns [orf system-symbol-p (op eq name)]]
                  [all bfrag.ffuns system-symbol-p])
                [none bfrag.ffuns (op member @1 %block-using-funs%)])
-        bfrag
+        (set bfrag.code (append bfrag.code
+                                ^(,*(maybe-mov oreg bfrag.oreg)
+                                  ,lskip))
+             bfrag.oreg oreg
+             bfrag bfrag)
         (new (frag oreg
                    ^(,*(if nfrag nfrag.code)
                       (block ,oreg ,nreg ,lskip)
@@ -871,11 +877,19 @@
                    nil
                    me.(get-dreg name)))
            (opcode (if (eq op 'return-from) 'ret 'abscsr))
-           (vfrag me.(compile oreg env value)))
-      env.(lookup-block name t)
+           (vfrag me.(compile oreg env value))
+           (binfo env.(lookup-block name)))
       (new (frag oreg
-                 ^(,*vfrag.code
-                   (,opcode ,nreg ,vfrag.oreg))
+                 (cond
+                   ((member name *esc-blocks*)
+                    (set me.bjmp-occurs t)
+                    ^(,*vfrag.code
+                      ,*(maybe-mov binfo.oreg vfrag.oreg)
+                      (bjmp ,binfo.label)))
+                   (t (if binfo
+                        (set binfo.used t))
+                      ^(,*vfrag.code
+                        (,opcode ,nreg ,vfrag.oreg))))
                  vfrag.fvars
                  vfrag.ffuns)))))
 
@@ -1873,7 +1887,7 @@
                             @1))]
             insns)))
 
-(defun convert-tjmps (insns)
+(defun convert-t-b-jmps (insns)
   (build
     (while-true-match-case insns
        (((tjmp @top) . @rest)
@@ -1891,11 +1905,26 @@
                ((zerop bal) (add (pop rest)))
                (t (dec bal) (pop rest))))
             (@nil (pop rest)))))
+       (((bjmp @bskip) . @rest)
+        (let ((bal 0))
+          (while-true-match-case rest
+            ((@bskip . @nil)
+             (add ^(jmp ,bskip))
+             (pop insns)
+             (return))
+            (((@(or frame dframe block handle catch uwprot) . @nil) . @nil)
+             (inc bal)
+             (pop rest))
+            (((end . @nil) . @nil)
+             (cond
+               ((zerop bal) (add (pop rest)))
+               (t (dec bal) (pop rest))))
+            (@nil (pop rest)))))
        (@nil (add (pop insns))))))
 
 (defmeth compiler optimize (me insns)
-  (when me.tjmp-occurs
-    (set insns (convert-tjmps insns)))
+  (when (or me.tjmp-occurs me.bjmp-occurs)
+    (set insns (convert-t-b-jmps insns)))
   (let ((olev *opt-level*))
     (if (>= olev 4)
       (let* ((lt-dregs (mapcar .oreg me.lt-frags))