compiler: TCO code complete.

Fixed point iteration over stdlib works; tests pass.

* stdlib/compiler.tl (tail-fun-info): Remove called slot.
This is replaced by tjmp-occurs in the compiler.
New slot, label. Identifies the backwards jump label for
the tail call.
(compiler): New slot, tjmp-occurs. If any tail call jump
occurs we set this. Special post processing is required
to insert some instructions before the jmp, in order to
bail out of some nested blocks/frames.
(compiler compile): Pass env in two parmeter positions
to comp-setq. Compile new setq-in-env compiler-only operator
which recurses to comp-setq but allows the variable env
to be independently specified.
(compiler comp-setq): Take two environment parameters;
one for resolving the value, and the other the variable.
We need this capability for setting the function parameters
in before the tail call jump. The parameters are in an outer
environment and may be shadowed.
(compiler comp-setq-in-env): New method; parses compiler-
generated (setq-in-env <var> <val> <env-obj>) syntax and
calls comp-setq.
(compiler comp-lambda-impl): If there is a tail context
for this lambda, create the jump label for it and store
it in the context. Also, we need the tfn.env to be nenv
not env; env is the outside context of the lambda, without
the parameters! Also, we inject the label into the top of
the code.
(compiler comp-fun-form): If we are in tail position, compile
the function form via comp-tail-call. Turn off the tail
position before recursing: the arguments of the tail call
are not themselves in a tail position.
(compiler comp-tail-call): New function. This is the workhorse.
To generate the tail call, we create a fake lambda and use the
lambda-apply-transform-function in order to obtain the
syntax for an immediate call. We then destructure the pieces,
arrange them into the code we need and compile it in the correct
environments to generate the fragment, adding the backwards
jump to it.  This requires a post-processing fixup.
(compiler comp-for): Bugfix: the body of a for is not
in tail position, only the result forms.
(compiler comp-prof): Also disable tail position; we don't
want code to jump out of a prof block.
(convert-tjmps): New function. This has to analyze the code
to find (tjmp ...) pseudo-instructions representing the backwards
jumps of tail calls. Before these jmps, we have to insert
end instructions, so that the tail call does not jump out of
a nested context, such as a variable frame/dframe or block.
(usr:compile): When an interpreted function object is compiled,
or a symbol naming such an object, we set up the tail-fun-info
structure for it, so that tail calls work, like we are already
doing for defun and labels.

1 files changed, 69 insertions, 9 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index c3043d38..6a5e189f 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -180,7 +180,7 @@
   name
   env
   lambda
-  called)
+  label)
 
 (defstruct closure-spy ()
   env
@@ -230,6 +230,7 @@
     top-form
     closure-spies
     access-spies
+    tjmp-occurs
 
     (:method snapshot (me)
       (let ((snap (copy me)))
@@ -479,7 +480,7 @@
            ((bindable sym)
             (caseq sym
               (quote me.(comp-atom oreg (cadr form)))
-              (sys:setq me.(comp-setq oreg env form))
+              (sys:setq me.(comp-setq oreg env env form))
               (sys:lisp1-setq me.(comp-lisp1-setq oreg env form))
               (sys:setqf me.(comp-setqf oreg env form))
               (cond me.(comp-cond oreg env form))
@@ -520,6 +521,7 @@
               (sys:load-time-lit me.(comp-load-time-lit oreg env form))
               ;; compiler-only special operators:
               (ift me.(comp-ift oreg env form))
+              (setq-in-env me.(comp-setq-in-env oreg env form))
               (compiler-let me.(comp-compiler-let oreg env form))
               ;; error cases
               ((macrolet symacrolet macro-time)
@@ -562,9 +564,9 @@
          (new (frag oreg ^((getv ,oreg ,dreg)) (list sym)))))
       (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym)))))))
 
-(defmeth compiler comp-setq (me oreg env form)
+(defmeth compiler comp-setq (me oreg env venv form)
   (mac-param-bind form (t sym value) form
-    (let* ((bind env.(lookup-var sym))
+    (let* ((bind venv.(lookup-var sym))
            (spec (special-var-p sym))
            (vloc (cond
                    (bind bind.loc)
@@ -743,6 +745,10 @@
                    (uni (uni le-frag.ffuns ri-frag.ffuns)
                         (uni th-frag.ffuns el-frag.ffuns))))))))
 
+(defmeth compiler comp-setq-in-env (me oreg env form)
+  (mac-param-bind form (op sym value venv) form
+    me.(comp-setq oreg env venv ^(,op ,sym ,value))))
+
 (defmeth compiler comp-switch (me oreg env form)
   (mac-param-bind form (t idx-form cases-vec) form
     (let* ((ncases (len cases-vec))
@@ -1129,7 +1135,8 @@
             (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
+            (set tfn.env nenv
+                 tfn.label (gensym "l")
                  tpos t))
           (flet ((spec-sub (sym : (loc :))
                    (cond
@@ -1200,6 +1207,8 @@
                                           nenv.(lookup-var (car op)).loc)
                                       ,*(if rest-par
                                           (list nenv.(lookup-var rest-par).loc)))
+                               ,*(when tpos
+                                   ^(,tfn.label))
                                ,*(if need-dframe
                                    ^((dframe ,benv.lev 0)))
                                ,*(if specials
@@ -1413,6 +1422,9 @@
 
 (defmeth compiler comp-fun-form (me oreg env form)
   (let* ((olev *opt-level*)
+         (tfn *tail-fun*)
+         (tpos *tail-pos*)
+         (*tail-pos* nil)
          (sym (car form))
          (nargs (len (cdr form)))
          (fbin env.(lookup-fun sym t))
@@ -1422,6 +1434,9 @@
       (param-check form nargs pars)
       (push (cons form nargs) *unchecked-calls*))
 
+    (if (and tpos (eq tfn.?name sym))
+      (return-from comp-fun-form me.(comp-tail-call oreg env form)))
+
     (when (null fbin)
       (when (plusp olev)
         (match-case form
@@ -1582,6 +1597,26 @@
                                                          apply-list-arg
                                                          nil)))))
 
+(defmeth compiler comp-tail-call (me oreg env form)
+  (let* ((tfn *tail-fun*)
+         (tenv (new env up tfn.env lev (succ env.lev) co me)))
+    (match (lambda @params . @nil) tfn.lambda
+      (let* ((lamb ^(lambda ,params))
+             (args (butlastn 0 (cdr form)))
+             (dot-arg (nthlast 0 form))
+             (lat (sys:lambda-apply-transform lamb args dot-arg nil)))
+        (match (@(or alet let) @temps (let* @sets . @code)) lat
+          (let* ((xsets (mapcar (tb ((sym val))
+                                   ^(sys:setq-in-env ,sym ,val ,tenv))
+                                sets))
+                 (sfrag me.(comp-let oreg env ^(let ,temps ,*xsets)))
+                 (cfrag me.(compile oreg tenv (expand ^(progn ,*code)))))
+            (set me.tjmp-occurs t)
+            (new (frag cfrag.oreg
+                       (append sfrag.code cfrag.code ^((tjmp ,tfn.label)))
+                       (uni sfrag.fvars cfrag.fvars)
+                       (uni sfrag.ffuns cfrag.ffuns)))))))))
+
 (defmeth compiler comp-for (me oreg env form)
   (mac-param-bind form (t inits (: (test nil test-p) . rets) incs . body) form
     (let* ((treg me.(alloc-treg))
@@ -1590,7 +1625,7 @@
            (tfrag (if test-p (ntp me.(compile treg env test))))
            (rfrag me.(comp-progn oreg env rets))
            (nfrag (ntp me.(comp-progn treg env incs)))
-           (bfrag me.(comp-progn treg env body))
+           (bfrag (ntp me.(comp-progn treg env body)))
            (lback (gensym "l"))
            (lskip (gensym "l"))
            (frags (build
@@ -1732,7 +1767,8 @@
 
 (defmeth compiler comp-prof (me oreg env form)
   (mac-param-bind form (t . forms) form
-    (let ((bfrag me.(comp-progn oreg env forms)))
+    (let ((*tail-pos* nil)
+          (bfrag me.(comp-progn oreg env forms)))
       (new (frag oreg
                  ^((prof ,oreg)
                    ,*bfrag.code
@@ -1827,7 +1863,29 @@
                             @1))]
             insns)))
 
+(defun convert-tjmps (insns)
+  (build
+    (while-true-match-case insns
+       (((tjmp @top) . @rest)
+        (let ((bal 0))
+          (while-true-match-case rest
+            (((jend . @nil) . @nil)
+             (add ^(jmp ,top))
+             (pop insns)
+             (return))
+            (((@(or frame dframe block handle catch uwprot) . @nil) . @nil)
+             (inc bal)
+             (pop rest))
+            (((end . @nil) . @nil)
+             (cond
+               ((zerop bal) (add (pop rest)))
+               (t (dec bal) (pop rest))))
+            (@nil (pop rest)))))
+       (@nil (add (pop insns))))))
+
 (defmeth compiler optimize (me insns)
+  (when me.tjmp-occurs
+    (set insns (convert-tjmps insns)))
   (let ((olev *opt-level*))
     (if (>= olev 4)
       (let* ((lt-dregs (mapcar .oreg me.lt-frags))
@@ -2770,17 +2828,19 @@
 (defun usr:compile (obj)
   (match-case obj
     (@(functionp)
-     (tree-bind (t args . body) (func-get-form obj)
+     (tree-bind (name args . body) (func-get-form obj)
        (let* ((form (sys:env-to-let (func-get-env obj)
                                     ^(lambda ,args ,*body)))
+              (*tail-fun* (new tail-fun-info name name lambda form))
               (vm-desc (compile-toplevel form t)))
          (vm-execute-toplevel vm-desc))))
     ((lambda . @nil)
      [(compile-toplevel obj nil)])
     (@(@fun (symbol-function))
-      (tree-bind (t args . body) (func-get-form fun)
+      (tree-bind (name args . body) (func-get-form fun)
         (let* ((form (sys:env-to-let (func-get-env fun)
                                      ^(lambda ,args ,*body)))
+               (*tail-fun* (new tail-fun-info name name lambda form))
                (vm-desc (compile-toplevel form t))
                (comp-fun (vm-execute-toplevel vm-desc)))
           (set (symbol-function obj) comp-fun))))