diff options
| -rw-r--r-- | stdlib/compiler.tl | 29 |
1 files changed, 27 insertions, 2 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index 98cdb7c4..f9566b27 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -176,6 +176,12 @@ (if (and (symbol-package sym) (not bn.used)) (diag form "~a ~s unused" nuance sym)))))) +(defstruct tail-fun-info () + name + env + lambda + called) + (defstruct closure-spy () env cap-vars @@ -529,6 +535,7 @@ ((+ *) me.(comp-arith-form oreg env form)) ((- /) me.(comp-arith-neg-form oreg env form)) (typep me.(comp-typep oreg env form)) + ((sys:rt-defun) me.(comp-rt-defun oreg env form)) ;; function call (t me.(comp-fun-form oreg env form)))) ((and (consp sym) @@ -841,7 +848,8 @@ (defmeth compiler comp-return-from (me oreg env form) (mac-param-bind form (op name : value) form - (let* ((*tail-pos* (if (equal name *tail-fun*) *tail-pos* nil)) + (let* ((*tail-pos* (if (and name (eq name *tail-fun*.?name)) + *tail-pos* nil)) (nreg (if (null name) nil me.(get-dreg name))) @@ -1060,6 +1068,10 @@ (ffrags (collect-each ((fi fis)) (tree-bind (sym : form) fi (let* ((bind nenv.(lookup-fun sym)) + (*tail-fun* (if rec + (new tail-fun-info + name sym + lambda form))) (frag (ntp me.(compile bind.loc (if rec nenv eenv) form)))) @@ -1102,6 +1114,8 @@ (compile-with-fresh-tregs me (let* ((*load-time* nil) (*top-level* nil) + (tfn *tail-fun*) + (tpos nil) (pars (new (fun-param-parser par-syntax form))) (need-frame (or (plusp pars.nfix) pars.rest)) (nenv (if need-frame (new env up env co me) env)) @@ -1109,6 +1123,9 @@ (when (> pars.nfix %max-lambda-fixed-args%) (compile-warning form "~s arguments in a lambda (max is ~s)" pars.nfix %max-lambda-fixed-args%)) + (when (and tfn (eq tfn.lambda form)) + (set tfn.env env + tpos t)) (flet ((spec-sub (sym : (loc :)) (cond ((special-var-p sym) @@ -1165,7 +1182,8 @@ ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub)))))))))) (benv (if need-dframe (new env up nenv co me) nenv)) (btreg me.(alloc-treg)) - (bfrag me.(comp-progn btreg benv body)) + (bfrag (let ((*tail-pos* tpos)) + me.(comp-progn btreg benv body))) (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg)) (lskip (gensym "l")) (frsize (if need-frame nenv.v-cntr 0)) @@ -1381,6 +1399,13 @@ [mapcar [chain cadr no-dvbind-eval] bindings] me.(comp-progn oreg env body)))) +(defmeth compiler comp-rt-defun (me oreg env form) + (match (@nil '@name @lambda) form + (let ((*tail-fun* (new tail-fun-info + name name + lambda lambda))) + me.(comp-fun-form oreg env form)))) + (defmeth compiler comp-fun-form (me oreg env form) (let* ((olev *opt-level*) (sym (car form)) |