compiler: implement eliding of blocks.

It is time-wasting to have a block in every function.  In this
patch we have the compiler eliminate blocks if it is obvious
that they will not be the targets of any exits or continuation
captures through any direct function calls.

If a block contains only calls to library functions,
and doesn't call certain functions, then it is removed.

It is possible for this removal to be strictly wrong
and different from interpreted code. This is true if
the code enclosed in a block invokes a function indirectly or
via a quoted symbol, and that function tries to return from
the block or capture a continuation using that block as
a prompt. Such a call doesn't prevent the block from being
removed.

For instance, this won't work in compiled code
any more:

  (defun tricky (fun)
    (call fun))

  (tricky (lambda () (return-from tricky 42)))

The call function is considered safe; the (call fun)
form doesn't prevent the block inside the tricky
function from being removed.

* share/txr/stdlib/compiler.tl (blockinfo): New struct.
(env): New slot, bb.
(env lookup-block, env extend-block): New methods.
(%block-using-funs%): New global variable.
(compiler comp-block): Implement the elision of the block
based on what free functions are referenced in the body,
and whether the block is referenced lexically.
Also, bind the block in the environment using the bb
member in the env structure.
(comp-return-from): Lookup the block lexically and
mark it as used.
(system-symbol-p): New function.

* txr.1: Document the rules for elision of blocks.

1 files changed, 48 insertions, 13 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 7defa0de..ea9b932d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -41,9 +41,15 @@
 
 (defstruct fbinding binding)
 
+(defstruct blockinfo nil
+  sym
+  used
+  sys:env)
+
 (defstruct sys:env nil
   vb
   fb
+  bb
   up
   co
   lev
@@ -75,6 +81,12 @@
       (((up me.up)) up.(lookup-lisp1 sym))
       (t nil)))
 
+  (:method lookup-block (me sym)
+    (condlet
+      (((cell (assoc sym me.bb))) (cdr cell))
+      (((up me.up)) up.(lookup-block sym))
+      (t nil)))
+
   (:method extend-var (me sym)
     (when (assoc sym me.vb)
       (compile-error me.co.last-form "duplicate variable: ~s" sym))
@@ -103,7 +115,11 @@
   (:method out-of-scope (me reg)
     (if (eq (car reg) 'v)
       (let ((lev (ssucc (cadr reg))))
-        (< me.lev lev)))))
+        (< me.lev lev))))
+
+  (:method extend-block (me sym)
+    (let* ((bn (new blockinfo sym sym env me)))
+      (set me.bb (acons sym bn me.bb)))))
 
 (compile-only
   (defstruct compiler nil
@@ -187,6 +203,9 @@
 
 (defvarl %test-inv% (relate %test-funs-pos% %test-funs-neg%))
 
+(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun
+                              eval load compile compile-file compile-toplevel))
+
 (defmeth compiler get-dreg (me atom)
   (condlet
     ((((null atom))) '(t 0))
@@ -566,22 +585,31 @@
 (defmeth compiler comp-block (me oreg env form)
   (mac-param-bind form (op name . body) form
     (let* ((star (and name (eq op 'block*)))
+           (nenv (unless star
+                   (new env up env lev env.lev co me)))
+           (binfo (unless star
+                    (cdar nenv.(extend-block name))))
            (treg (if star me.(maybe-alloc-treg oreg)))
-           (nfrag (if star me.(compile treg env name)))
+           (nfrag (if star me.(compile treg nenv name)))
            (nreg (if star nfrag.oreg me.(get-dreg name)))
-           (bfrag me.(comp-progn oreg env body))
+           (bfrag me.(comp-progn oreg nenv body))
            (lskip (gensym "l")))
       (when treg
         me.(maybe-free-treg treg oreg))
-      (new (frag oreg
-                 ^(,*(if nfrag nfrag.code)
-                   (block ,oreg ,nreg ,lskip)
-                   ,*bfrag.code
-                   ,*(maybe-mov oreg bfrag.oreg)
-                   (end ,oreg)
-                   ,lskip)
-                 bfrag.fvars
-                 bfrag.ffuns)))))
+      (if (and (not star)
+               (not binfo.used)
+               [all bfrag.ffuns system-symbol-p]
+               [none bfrag.ffuns (op member @1 %block-using-funs%)])
+        bfrag
+        (new (frag oreg
+                   ^(,*(if nfrag nfrag.code)
+                      (block ,oreg ,nreg ,lskip)
+                      ,*bfrag.code
+                      ,*(maybe-mov oreg bfrag.oreg)
+                      (end ,oreg)
+                      ,lskip)
+                   bfrag.fvars
+                   bfrag.ffuns))))))
 
 (defmeth compiler comp-return-from (me oreg env form)
   (mac-param-bind form (op name : value) form
@@ -589,7 +617,10 @@
                    nil
                    me.(get-dreg name)))
            (opcode (if (eq op 'return-from) 'ret 'abscsr))
-           (vfrag me.(compile oreg env value)))
+           (vfrag me.(compile oreg env value))
+           (binfo env.(lookup-block name)))
+      (when binfo
+        (set binfo.used t))
       (new (frag oreg
                  ^(,*vfrag.code
                    (,opcode ,nreg ,vfrag.oreg))
@@ -1419,6 +1450,10 @@
                       (add ^(,pars.rest))))))
          ,*lm-body))))
 
+(defun system-symbol-p (sym)
+  (member (symbol-package sym)
+          (load-time (list user-package system-package))))
+
 (defun usr:compile-toplevel (exp : (expanded-p nil))
   (let ((co (new compiler))
         (as (new assembler)))