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.

1 files changed, 5 insertions, 3 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);