compiler: eliminate block from recursive functions.

The block elimination logic doesn't work for self-recursive
functions, even if they invoke no block returning, and use
only system functions that don't have anything to do with
block returns. This is because the recursive call is not
recognized, and treated as a call to an unknown function.

Let's put in a simple hack. The defun and defmacro operators
will use a new secret special operator called sys:blk instead
of block to generate the block. The compilation of sys:blk
will assume that (sys:blk name ...) is only used in a defun or
defmacro by that same name, and include name in the list of OK
functions.

So that functions created using the interpreter and then
dynamically compiled will also benefit, we add this operator
to the interpreter.

* eval.c (sys_blk_s): New symbol variable.
(op_defun): For defun and defmacro, use sys:blk for the block
for the block
(eval_init): Initialize sys_blk_s with the interned symbol
sys:blk. Register the sys:blk operator.

* share/txr/stdlib/compiler.tl (compiler compile): Recognize
the sys:blk special form and handle via comp-block.
(comp-block): If sys:blk is being compiled, then include the
block name in the list of functions that do not perform block
returns. (If this is false, other checks will fail before use
that.)
(expand-defun): Use sys:blk for defun and defmacro.

2 files changed, 14 insertions, 10 deletions

diff --git a/eval.c b/eval.c
index 71901251..07869c41 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,7 @@ val op_table, pm_table;
 val dyn_env;
 
 val eval_error_s;
-val dwim_s, progn_s, prog1_s, prog2_s;
+val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s;
 val let_s, let_star_s, lambda_s, call_s, dvbind_s;
 val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s;
 val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s;
@@ -2038,7 +2038,7 @@ static val op_defun(val form, val env)
   trace_check(name);
 
   if (!consp(name)) {
-    val block = cons(block_s, cons(name, body));
+    val block = cons(sys_blk_s, cons(name, body));
     val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
     return rt_defun(name, func_interp(env, fun));
   } else if (car(name) == meth_s) {
@@ -2053,7 +2053,7 @@ static val op_defun(val form, val env)
     return funcall3(cdr(binding), type_sym, meth_name, func_interp(env, fun));
   } else if (car(name) == macro_s) {
     val sym = cadr(name);
-    val block = cons(block_s, cons(sym, body));
+    val block = cons(sys_blk_s, cons(sym, body));
     val fun = rlcp(cons(name, cons(params, cons(block, nil))), form);
 
     if (!bindable(sym))
@@ -6303,6 +6303,7 @@ void eval_init(void)
   progn_s = intern(lit("progn"), user_package);
   prog1_s = intern(lit("prog1"), user_package);
   prog2_s = intern(lit("prog2"), user_package);
+  sys_blk_s = intern(lit("blk"), system_package);
   let_s = intern(lit("let"), user_package);
   let_star_s = intern(lit("let*"), user_package);
   lambda_s = intern(lit("lambda"), user_package);
@@ -6463,6 +6464,7 @@ void eval_init(void)
   reg_op(uw_protect_s, op_unwind_protect);
   reg_op(block_s, op_block);
   reg_op(block_star_s, op_block_star);
+  reg_op(sys_blk_s, op_block);
   reg_op(return_s, op_return);
   reg_op(return_from_s, op_return_from);
   reg_op(sys_abscond_from_s, op_abscond_from);
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index f9f052dc..a735739b 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -389,7 +389,7 @@
               (if me.(comp-if oreg env form))
               (switch me.(comp-switch oreg env form))
               (unwind-protect me.(comp-unwind-protect oreg env form))
-              ((block block*) me.(comp-block oreg env form))
+              ((block block* sys:blk) me.(comp-block oreg env form))
               ((return-from sys:abscond-from) me.(comp-return-from oreg env form))
               (return me.(comp-return oreg env form))
               (handler-bind me.(comp-handler-bind oreg env form))
@@ -716,7 +716,9 @@
         me.(maybe-free-treg treg oreg))
       (if (and (not star)
                (not binfo.used)
-               [all bfrag.ffuns system-symbol-p]
+               (and (if (eq op 'sys:blk)
+                      [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
         (new (frag oreg
@@ -1686,19 +1688,19 @@
 
 (defun expand-defun (form)
   (mac-param-bind form (op name args . body) form
-    (flet ((mklambda (block-name)
-             ^(lambda ,args (block ,block-name ,*body))))
+    (flet ((mklambda (block-name block-sym)
+             ^(lambda ,args (,block-sym ,block-name ,*body))))
       (cond
         ((bindable name)
-         ^(sys:rt-defun ',name ,(mklambda name)))
+         ^(sys:rt-defun ',name ,(mklambda name 'sys:blk)))
         ((consp name)
          (caseq (car name)
            (meth
              (mac-param-bind form (meth type slot) name
-               ^(sys:define-method ',type ',slot ,(mklambda slot))))
+               ^(sys:define-method ',type ',slot ,(mklambda slot 'block))))
            (macro
              (mac-param-bind form (macro sym) name
-               ^(sys:rt-defmacro ',sym ',name ,(mklambda sym))))
+               ^(sys:rt-defmacro ',sym ',name ,(mklambda sym 'sys:blk))))
            (t (compile-error form "~s isn't a valid compound function name"
                              name))))
         (t (compile-error form "~s isn't a valid function name" name))))))