compiler/vm: more compact frame size for closures.

Closures do not share t-registers with surrounding code; they
do not store a value into such a register that code outside
the closure would read and vice versa.

When compiling closures, we can can temporarily reset the
compiler's t-register allocator machinery to get low
t-register values.  Then, when executing the closure, we
reserve space just for the registers it needs, not based off
the containing vm description.

Here we make a backwards-incompatible change. The VM close
instruction needs an extra parameter indicating the number of
t-regisers. This is stored into the closure and used for
allocating the frame when it is dispatched.

* parser.c (read_file_common): We read nothing but version 6
tlo files now.

* share/txr/stdlib/asm.tl (op-close asm): Parse new ntreg
argument from close syntax, and put it out as an extra word.
Here is where we pay for this improvement in extra code size.
(op-close dis): Extract the new argument from the machine code
and add it to the disassembled format.

* share/txr/stdlib/compiler.tl (compile-in-toplevel): Save and
restore the t-reg discards list also. Don't bother with a
gensym for the compiler; the argument is always a symbol,
which we can use unhygienically like in with-var-spy.
(compile-with-fresh-tregs): New macro based on
compile-in-toplevel: almost the same but doesn't reset the
level.
(comp-lambda-impl): Use compile-with-fresh-tregs to compile
the entire closure with a minimized register set.
Place the treg-cntr into the closure instruction to indicate
the number of registers the closure requires.

* vm.c (struct vm): New member, nreg.
(vm_make_closure): New parameter, nreg, stored into the
closure.
(vm_close): Extract a third opcode word, and pull the nreg
value from the bottom half. Pass this to vm_make_closure.
(vm_execute_closure, vm_funcall_common): Calculate frame size
based on the closur's nreg rather than the VM description's.

* txr.1: Document that the upcoming version 252 produces
version 6.0 object files and only loads version 6.

5 files changed, 161 insertions, 130 deletions

diff --git a/parser.c b/parser.c
index 5282b75f..77797b19 100644
--- a/parser.c
+++ b/parser.c
@@ -741,7 +741,7 @@ static val read_file_common(val self, val stream, val error_stream, val compiled
 
     if (compiled && first) {
       val major = car(form);
-      if (lt(major, one) || gt(major, num_fast(6)))
+      if (neq(major, num_fast(6)))
         uw_throwf(error_s,
                   lit("cannot load ~s: version number mismatch"),
                   stream, nao);
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index b4a739fe..365cda78 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -727,13 +727,14 @@
   (:method asm (me asm syntax)
     me.(chk-arg-count-min 6 syntax)
     (let* ((syn-pat (repeat '(d) (- (length syntax) 7))))
-      (tree-bind (reg frsize dst fix req vari . regs)
-                 asm.(parse-args me syntax ^(d n l n n o ,*syn-pat))
+      (tree-bind (reg frsize ntreg dst fix req vari . regs)
+                 asm.(parse-args me syntax ^(d n n l n n o,*syn-pat))
         (unless (<= 0 frsize %lev-size%)
           me.(synerr "frame size must be 0 to ~a" %lev-size%))
         asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
         asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg)
         asm.(put-pair req fix)
+        asm.(put-pair 0 ntreg)
         (unless (eql fix (- (len regs) (if vari 1 0)))
           me.(synerr "wrong number of registers"))
         (while regs
@@ -749,18 +750,19 @@
       (tree-bind (vari-frsize reg) asm.(get-pair)
         (let ((vari (bit vari-frsize %lev-bits%)))
           (tree-bind (req fix) asm.(get-pair)
-            (build
-              (add me.symbol (operand-to-sym reg)
-                   (logtrunc vari-frsize %lev-bits%)
-                   dst fix req vari)
-              (when vari
-                (inc fix))
-              (while (> fix 0)
-                (dec fix 2)
-                (tree-bind (y x) asm.(get-pair)
-                  (add (operand-to-sym x))
-                  (unless (minusp fix)
-                    (add (operand-to-sym y))))))))))))
+            (tree-bind (ign ntreg) asm.(get-pair)
+              (build
+                (add me.symbol (operand-to-sym reg)
+                     (logtrunc vari-frsize %lev-bits%)
+                     ntreg dst fix req vari)
+                (when vari
+                  (inc fix))
+                (while (> fix 0)
+                  (dec fix 2)
+                  (tree-bind (y x) asm.(get-pair)
+                    (add (operand-to-sym x))
+                    (unless (minusp fix)
+                      (add (operand-to-sym y)))))))))))))
 
 (defopcode op-getlx getlx auto
   (:method asm (me asm syntax)
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index c06238bd..f9f052dc 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -188,23 +188,42 @@
     var-spies))
 
 (eval-only
-  (defmacro compile-in-toplevel (comp . body)
-    (with-gensyms (comp-var saved-tregs saved-treg-cntr saved-nlev)
-      ^(let* ((,comp-var ,comp)
-              (,saved-tregs (qref ,comp-var tregs))
-              (,saved-treg-cntr (qref ,comp-var treg-cntr))
-              (,saved-nlev (qref ,comp-var nlev)))
+  (defmacro compile-in-toplevel (me . body)
+    (with-gensyms (saved-tregs saved-treg-cntr saved-nlev saved-discards)
+      ^(let* ((,saved-tregs (qref ,me tregs))
+              (,saved-treg-cntr (qref ,me treg-cntr))
+              (,saved-discards (qref ,me discards))
+              (,saved-nlev (qref ,me nlev)))
          (unwind-protect
            (progn
-             (set (qref ,comp-var tregs) nil
-                  (qref ,comp-var treg-cntr) 2
-                  (qref ,comp-var nlev) 2)
+             (set (qref ,me tregs) nil
+                  (qref ,me treg-cntr) 2
+                  (qref ,me discards) nil
+                  (qref ,me nlev) 2)
              (prog1
                (progn ,*body)
-               (qref ,comp-var (check-treg-leak))))
-           (set (qref ,comp-var tregs) ,saved-tregs
-                (qref ,comp-var treg-cntr) ,saved-treg-cntr
-                (qref ,comp-var nlev) ,saved-nlev)))))
+               (qref ,me (check-treg-leak))))
+           (set (qref ,me tregs) ,saved-tregs
+                (qref ,me treg-cntr) ,saved-treg-cntr
+                (qref ,me discards) ,saved-discards
+                (qref ,me nlev) ,saved-nlev)))))
+
+  (defmacro compile-with-fresh-tregs (me . body)
+    (with-gensyms (saved-tregs saved-treg-cntr saved-discards)
+      ^(let* ((,saved-tregs (qref ,me tregs))
+              (,saved-treg-cntr (qref ,me treg-cntr))
+              (,saved-discards (qref ,me discards)))
+         (unwind-protect
+           (progn
+             (set (qref ,me tregs) nil
+                  (qref ,me treg-cntr) 2
+                  (qref ,me discards) nil)
+             (prog1
+               (progn ,*body)
+               (qref ,me (check-treg-leak))))
+           (set (qref ,me tregs) ,saved-tregs
+                (qref ,me treg-cntr) ,saved-treg-cntr
+                (qref ,me discards) ,saved-discards)))))
 
   (defmacro with-var-spy (me flag spy spy-expr . body)
     ^(let ((,spy (if ,flag ,spy-expr)))
@@ -938,101 +957,102 @@
     (with-var-spy me me.var-spies
                   spy (new capture-var-spy
                            var-spies me.var-spies)
-      (let* ((*load-time* 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))
-             lexsyms fvars specials need-dframe)
-        (when (> pars.nfix %max-lambda-fixed-args%)
-          (compile-warning form "~s arguments in a lambda (max is ~s)"
-                           pars.nfix %max-lambda-fixed-args%))
-        (flet ((spec-sub (sym)
-                 (cond
-                   ((special-var-p sym)
-                    (let ((sub (gensym)))
-                      (push (cons sym sub) specials)
-                      (set need-dframe t)
-                      nenv.(extend-var sub)
-                      sub))
-                   (t
-                     (push sym lexsyms)
-                     nenv.(extend-var sym)
-                     sym))))
-          (let* ((req-pars (collect-each ((rp pars.req))
-                             (spec-sub rp)))
-                 (opt-pars (collect-each ((op pars.opt))
-                             (tree-bind (var-sym : init-form have-sym) op
-                               (list (spec-sub var-sym)
-                                     init-form
-                                     (if have-sym (spec-sub have-sym))))))
-                 (rest-par (when pars.rest (spec-sub pars.rest)))
-                 (allsyms req-pars))
-            (upd specials nreverse)
-            (let* ((col-reg (if opt-pars me.(get-dreg :)))
-                   (tee-reg (if opt-pars me.(get-dreg t)))
-                   (ifrags (collect-each ((op opt-pars))
-                             (tree-bind (var-sym init-form have-sym) op
-                               (let* ((vbind nenv.(lookup-var var-sym))
-                                      (ifrag me.(compile vbind.loc nenv init-form)))
-                                 (set fvars (uni fvars
-                                                 (diff ifrag.fvars allsyms)))
-                                 (push var-sym allsyms)
-                                 (push have-sym allsyms)
-                                 ifrag))))
-                   (opt-code (append-each ((op opt-pars)
-                                           (ifrg ifrags))
+      (compile-with-fresh-tregs me
+        (let* ((*load-time* 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))
+               lexsyms fvars specials need-dframe)
+          (when (> pars.nfix %max-lambda-fixed-args%)
+            (compile-warning form "~s arguments in a lambda (max is ~s)"
+                             pars.nfix %max-lambda-fixed-args%))
+          (flet ((spec-sub (sym)
+                   (cond
+                     ((special-var-p sym)
+                      (let ((sub (gensym)))
+                        (push (cons sym sub) specials)
+                        (set need-dframe t)
+                        nenv.(extend-var sub)
+                        sub))
+                     (t
+                       (push sym lexsyms)
+                       nenv.(extend-var sym)
+                       sym))))
+            (let* ((req-pars (collect-each ((rp pars.req))
+                               (spec-sub rp)))
+                   (opt-pars (collect-each ((op pars.opt))
+                               (tree-bind (var-sym : init-form have-sym) op
+                                 (list (spec-sub var-sym)
+                                       init-form
+                                       (if have-sym (spec-sub have-sym))))))
+                   (rest-par (when pars.rest (spec-sub pars.rest)))
+                   (allsyms req-pars))
+              (upd specials nreverse)
+              (let* ((col-reg (if opt-pars me.(get-dreg :)))
+                     (tee-reg (if opt-pars me.(get-dreg t)))
+                     (ifrags (collect-each ((op opt-pars))
                                (tree-bind (var-sym init-form have-sym) op
-                                 (let ((vbind nenv.(lookup-var var-sym))
-                                       (have-bind nenv.(lookup-var have-sym))
-                                       (lskip (gensym "l")))
-                                   ^(,*(if have-sym
-                                         ^((mov ,have-bind.loc ,tee-reg)))
-                                      (ifq ,vbind.loc ,col-reg ,lskip)
-                                      ,*(if have-sym
-                                          ^((mov ,have-bind.loc nil)))
-                                      ,*ifrg.code
-                                      ,*me.(maybe-mov vbind.loc ifrg.oreg)
-                                      ,lskip
-                                      ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
-                                          (set specials [remq var-sym specials cdr])
-                                          ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub)))))
-                                      ,*(whenlet ((spec-sub [find have-sym specials : cdr]))
-                                          (set specials [remq have-sym specials cdr])
-                                          ^((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))
-                   (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg))
-                   (lskip (gensym "l"))
-                   (frsize (if need-frame nenv.v-cntr 0)))
-              me.(free-treg btreg)
-              (new (frag oreg
-                         ^((close ,oreg ,frsize ,lskip ,pars.nfix ,pars.nreq
-                                  ,(if rest-par t nil)
-                                  ,*(collect-each ((rp req-pars))
-                                      nenv.(lookup-var rp).loc)
-                                  ,*(collect-each ((op opt-pars))
-                                      nenv.(lookup-var (car op)).loc)
-                                  ,*(if rest-par
-                                      (list nenv.(lookup-var rest-par).loc)))
-                           ,*(if need-dframe
-                               ^((dframe ,benv.lev 0)))
-                           ,*(if specials
-                               (collect-each ((vs specials))
-                                 (tree-bind (special . gensym) vs
-                                   (let ((sub-bind nenv.(lookup-var gensym))
-                                         (dreg me.(get-dreg special)))
-                                     ^(bindv ,sub-bind.loc ,dreg)))))
-                           ,*opt-code
-                           ,*bfrag.code
-                           ,*(if need-dframe
-                               ^((end ,boreg)))
-                           ,*me.(maybe-mov boreg bfrag.oreg)
-                           (end ,boreg)
-                           ,lskip)
-                         (uni fvars (diff bfrag.fvars lexsyms))
-                         (uni [reduce-left uni ifrags nil .ffuns]
-                              bfrag.ffuns))))))))))
+                                 (let* ((vbind nenv.(lookup-var var-sym))
+                                        (ifrag me.(compile vbind.loc nenv init-form)))
+                                   (set fvars (uni fvars
+                                                   (diff ifrag.fvars allsyms)))
+                                   (push var-sym allsyms)
+                                   (push have-sym allsyms)
+                                   ifrag))))
+                     (opt-code (append-each ((op opt-pars)
+                                             (ifrg ifrags))
+                                 (tree-bind (var-sym init-form have-sym) op
+                                   (let ((vbind nenv.(lookup-var var-sym))
+                                         (have-bind nenv.(lookup-var have-sym))
+                                         (lskip (gensym "l")))
+                                     ^(,*(if have-sym
+                                           ^((mov ,have-bind.loc ,tee-reg)))
+                                        (ifq ,vbind.loc ,col-reg ,lskip)
+                                        ,*(if have-sym
+                                            ^((mov ,have-bind.loc nil)))
+                                        ,*ifrg.code
+                                        ,*me.(maybe-mov vbind.loc ifrg.oreg)
+                                        ,lskip
+                                        ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
+                                            (set specials [remq var-sym specials cdr])
+                                            ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub)))))
+                                        ,*(whenlet ((spec-sub [find have-sym specials : cdr]))
+                                            (set specials [remq have-sym specials cdr])
+                                            ^((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))
+                     (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg))
+                     (lskip (gensym "l"))
+                     (frsize (if need-frame nenv.v-cntr 0)))
+                me.(free-treg btreg)
+                (new (frag oreg
+                           ^((close ,oreg ,frsize ,me.treg-cntr ,lskip
+                                    ,pars.nfix ,pars.nreq ,(if rest-par t nil)
+                                    ,*(collect-each ((rp req-pars))
+                                        nenv.(lookup-var rp).loc)
+                                    ,*(collect-each ((op opt-pars))
+                                        nenv.(lookup-var (car op)).loc)
+                                    ,*(if rest-par
+                                        (list nenv.(lookup-var rest-par).loc)))
+                             ,*(if need-dframe
+                                 ^((dframe ,benv.lev 0)))
+                             ,*(if specials
+                                 (collect-each ((vs specials))
+                                   (tree-bind (special . gensym) vs
+                                     (let ((sub-bind nenv.(lookup-var gensym))
+                                           (dreg me.(get-dreg special)))
+                                       ^(bindv ,sub-bind.loc ,dreg)))))
+                             ,*opt-code
+                             ,*bfrag.code
+                             ,*(if need-dframe
+                                 ^((end ,boreg)))
+                             ,*me.(maybe-mov boreg bfrag.oreg)
+                             (end ,boreg)
+                             ,lskip)
+                           (uni fvars (diff bfrag.fvars lexsyms))
+                           (uni [reduce-left uni ifrags nil .ffuns]
+                                bfrag.ffuns)))))))))))
 
 (defmeth compiler comp-lambda (me oreg env form)
   (if *load-time*
diff --git a/txr.1 b/txr.1
index 6fdf650f..e54505a1 100644
--- a/txr.1
+++ b/txr.1
@@ -74820,6 +74820,9 @@ version 2, 3, 4 or 5, regardless of minor version.
 Versions 244 through 251 produce version 5.1 files and load
 version 2, 3, 4 or 5, regardless of minor version.
 
+Version 252 produces version 6.0 files and loads only version 6,
+regardless of minor version.
+
 .SS* Semantic Differences between Compilation and Interpretation
 
 The
diff --git a/vm.c b/vm.c
index 8e7433f0..85db9fa7 100644
--- a/vm.c
+++ b/vm.c
@@ -91,6 +91,7 @@ struct vm {
 struct vm_closure {
   struct vm_desc *vd;
   int frsz;
+  int nreg;
   int nlvl;
   unsigned ip;
   struct vm_env dspl[1];
@@ -232,7 +233,7 @@ static struct vm_closure *vm_closure_struct(val self, val obj)
   return coerce(struct vm_closure *, cobj_handle(self, obj, vm_closure_s));
 }
 
-static val vm_make_closure(struct vm *vm, int frsz)
+static val vm_make_closure(struct vm *vm, int frsz, int nreg)
 {
   val self = lit("vm");
   size_t dspl_sz = vm->nlvl * sizeof (struct vm_env);
@@ -245,6 +246,7 @@ static val vm_make_closure(struct vm *vm, int frsz)
   vc->frsz = frsz;
   vc->ip = vm->ip;
   vc->nlvl = vm->lev + 1;
+  vc->nreg = nreg;
   vc->vd = vm->vd;
 
   memset(vc->dspl, 0, dspl_sz);
@@ -967,13 +969,15 @@ NOINLINE static void vm_close(struct vm *vm, vm_word_t insn)
   unsigned dst = vm_insn_bigop(insn);
   vm_word_t arg1 = vm->code[vm->ip++];
   vm_word_t arg2 = vm->code[vm->ip++];
+  vm_word_t arg3 = vm->code[vm->ip++];
   unsigned vari_fr = vm_arg_operand_hi(arg1);
   int variadic = vari_fr & (1 << VM_LEV_BITS);
   int frsz = vari_fr & VM_LEV_MASK;
   unsigned reg = vm_arg_operand_lo(arg1);
   int reqargs = vm_arg_operand_hi(arg2);
   int fixparam = vm_arg_operand_lo(arg2);
-  val closure = vm_make_closure(vm, frsz);
+  int ntregs = vm_arg_operand_lo(arg3);
+  val closure = vm_make_closure(vm, frsz, ntregs);
   val vf = func_vm(closure, vm->vd->self, fixparam, reqargs, variadic);
 
   vm_set(vm->dspl, reg, vf);
@@ -1152,15 +1156,16 @@ val vm_execute_closure(val fun, struct args *args)
   struct vm_desc *vd = vm_desc_struct(self, desc);
   struct vm_closure *vc = coerce(struct vm_closure *, closure->co.handle);
   struct vm vm;
-  val *frame = coerce(val *, zalloca(sizeof *frame * vd->frsz));
-  struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg);
+  int frsz = vd->nlvl * 2 + vc->nreg;
+  val *frame = coerce(val *, zalloca(sizeof *frame * frsz));
+  struct vm_env *dspl = coerce(struct vm_env *, frame + vc->nreg);
   val vargs = if3(variadic, args_get_rest(args, fixparam), nil);
   cnum ix = 0;
   vm_word_t argw = 0;
 
   vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip);
 
-  vm.dspl = coerce(struct vm_env *, frame + vd->nreg);
+  vm.dspl = coerce(struct vm_env *, frame + vc->nreg);
 
   frame[0] = nil;
 
@@ -1214,10 +1219,11 @@ val vm_execute_closure(val fun, struct args *args)
   struct vm_desc *vd = vm_desc_struct(self, desc);                           \
   struct vm_closure *vc = coerce(struct vm_closure *, closure->co.handle);   \
   struct vm vm;                                                              \
-  val *frame = coerce(val *, zalloca(sizeof *frame * vd->frsz));             \
-  struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg);           \
+  int frsz = vd->nlvl * 2 + vc->nreg;                                        \
+  val *frame = coerce(val *, zalloca(sizeof *frame * frsz));                 \
+  struct vm_env *dspl = coerce(struct vm_env *, frame + vc->nreg);           \
   vm_reset(&vm, vd, dspl, vc->nlvl - 1, vc->ip);                             \
-  vm.dspl = coerce(struct vm_env *, frame + vd->nreg);                       \
+  vm.dspl = coerce(struct vm_env *, frame + vc->nreg);                       \
   frame[0] = nil;                                                            \
   vm.dspl[0].mem = frame;                                                    \
   vm.dspl[0].vec = nil;                                                      \