From 3038f6b7ea60599058251339773412e2d02eb5c8 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 12 Feb 2021 19:25:29 -0800 Subject: 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. --- eval.c | 8 +++++--- share/txr/stdlib/compiler.tl | 16 +++++++++------- 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)))))) -- cgit v1.2.3