summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-02-11 06:52:46 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-02-11 06:52:46 -0800
commitd662a6c925b959b0b521c2954c87863e46478897 (patch)
tree73958b54600b93e340cb8ac88fe98d88e1f7ed7f
parent512fa869e31d3fde5eb9422a5ed46e3fec58c94a (diff)
downloadtxr-d662a6c925b959b0b521c2954c87863e46478897.tar.gz
txr-d662a6c925b959b0b521c2954c87863e46478897.tar.bz2
txr-d662a6c925b959b0b521c2954c87863e46478897.zip
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.
-rw-r--r--parser.c2
-rw-r--r--share/txr/stdlib/asm.tl30
-rw-r--r--share/txr/stdlib/compiler.tl234
-rw-r--r--txr.13
-rw-r--r--vm.c22
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; \