summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-02-12 19:25:29 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-02-12 19:25:29 -0800
commit779754a6f5564e691041b36f350c4ad6bf5ba561 (patch)
treea59d25593937726b402177a45e4571651e9fab96
parentacc3891f909a40fb342fe57f33abba8e0c628640 (diff)
downloadtxr-779754a6f5564e691041b36f350c4ad6bf5ba561.tar.gz
txr-779754a6f5564e691041b36f350c4ad6bf5ba561.tar.bz2
txr-779754a6f5564e691041b36f350c4ad6bf5ba561.zip
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.
-rw-r--r--eval.c8
-rw-r--r--share/txr/stdlib/compiler.tl16
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))))))