diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-02-11 06:52:46 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-02-11 06:52:46 -0800 |
commit | d662a6c925b959b0b521c2954c87863e46478897 (patch) | |
tree | 73958b54600b93e340cb8ac88fe98d88e1f7ed7f | |
parent | 512fa869e31d3fde5eb9422a5ed46e3fec58c94a (diff) | |
download | txr-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.c | 2 | ||||
-rw-r--r-- | share/txr/stdlib/asm.tl | 30 | ||||
-rw-r--r-- | share/txr/stdlib/compiler.tl | 234 | ||||
-rw-r--r-- | txr.1 | 3 | ||||
-rw-r--r-- | vm.c | 22 |
5 files changed, 161 insertions, 130 deletions
@@ -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* @@ -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 @@ -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; \ |