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.

2 files changed, 139 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)))
diff --git a/txr.1 b/txr.1
index ac141a73..dc2ff60f 100644
--- a/txr.1
+++ b/txr.1
@@ -15704,6 +15704,97 @@ sense to have support a dynamically computed name.
 Thus blocks in \*(TL provide dynamic non-local returns, as well
 as returns out of lexical nesting.
 
+It is permitted for blocks to be aggressively
+.codn progn -converted
+by compilation.  This means that a
+.code block
+form which meets certain criteria is converted to a
+.code progn
+form which surrounds the
+.metn body-form -s
+and thus no longer establishes an exit point.
+
+A
+.code block
+form will be spared from
+.codn progn -conversion
+by the compiler if it meets the following rules.
+.RS
+.IP 1
+Any
+.meta body-form
+references the block's
+.meta name
+in a
+.codn return ,
+.codn return-from ,
+.code sys:abscond-from
+or
+.code sys:capture-cont
+expression.
+.IP 2
+The form contains at least one direct call to a function
+not in the standard \*(TL library.
+.IP 3
+The form contains at least one direct call to the functions
+.codn sys:capture-cont ,
+.codn return* ,
+.codn sys:abscond* ,
+.codn match-fun ,
+.codn eval ,
+.codn load ,
+.codn compile ,
+.code compile-file
+or
+.codn compile-toplevel .
+.IP 4
+The form references any of the functions in rules 2 and 3
+as a function binding via the
+.code dwim
+operator (or the DWIM brackets notation) or via the
+.code fun
+operator.
+.RE
+.PP
+Removal of blocks under the above rules means that some use of blocks which
+works in interpreted code will not work in compiled programs. Programs which
+adhere to the rules are not affected by such a difference.
+
+Additionally, the compiler may
+.codn progn -convert
+blocks in contravention of the above rules, but only if doing so makes no
+difference to visible program behavior.
+
+.TP* Examples:
+.cblk
+  (defun helper ()
+    (return-from top 42))
+
+  ;; defun implicitly defines a block named top
+  (defun top ()
+    (helper) ;; function returns 42
+    (prinl 'notreached)) ;; never printed
+
+  (defun top2 ()
+    (let ((h (fun helper)))
+      (block top (call h))   ;; may progn-convert
+      (block top (call 'helper)) ;; may progn-convert
+      (block top (helper)))) ;; not removed
+.cble
+In the above examples, the block containing
+.code "(call h)"
+may be converted to
+.code progn
+because it doesn't express a
+.B direct
+call to the
+.code helper
+function. The block which calls
+.code helper
+using
+.code "(call 'helper)"
+is also not considered to be making a direct call.
+
 .TP* "Dialect Note:"
 In Common Lisp, blocks are lexical. A separate mechanism consisting of
 catch and throw operators performs non-local transfer based on symbols.