compiler: prepare tail call identification context.

* stdlib/compiler.tl (tail-fun-info): New struct type.
The *tail-fun* special will be bound to instances of
this.
(compiler compile): Handle sys:rt-defun specially,
via new comp-rt-defun.
(compiler comp-return-from): Adjustment here; *tail-fun*
does not carry the name, but a context structure with
a name slot.
(compiler comp-fbind): Whe compiling lbind, and thus
potentially recursive functions, bind *tail-fun* to
a new tail-fun-info context object carrying the name
and lambda function. The env will be filled in later
the compilation of the lambda.
(compiler comp-lambda-impl): When compiling exactly that
lambda expression that is indicated the *tail-fun*
structure, store the parameter environment object into
that structure, and also bind *tail-pos* to indicate that
the body of the lambda is in the tail position.
(compiler comp-rt-defun): New method, which destructures
the (sys:rt-defun ...) call to extract the name and
lambda, and uses those to wrap a tail-fun-info context
around the compilation, similarly to what is done for
local functions in comp-fbind.

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))