diff options
| -rw-r--r-- | share/txr/stdlib/asm.tl | 99 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 11 | ||||
| -rw-r--r-- | share/txr/stdlib/vm-param.tl | 32 | ||||
| -rw-r--r-- | vm.c | 58 |
4 files changed, 142 insertions, 58 deletions
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl index 1c4e76c2..08f378c0 100644 --- a/share/txr/stdlib/asm.tl +++ b/share/txr/stdlib/asm.tl @@ -24,6 +24,8 @@ ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(load "vm-param") + (defstruct oc-base nil (:method synerr (me fmt . args) (error `opcode @{me.symbol}: @fmt` . args)) @@ -41,6 +43,9 @@ (:method backpatch (me asm at offs) (error `assembler: @{me.symbol} doesn't backpatch`))) +(defmacro small-op-p (val) + ^(< ,val ,1024)) + (compile-only (defstruct assembler nil buf @@ -163,14 +168,16 @@ oc.(synerr "argument ~a of ~s invalid; ~a expected" n syntax [me.operand-name type])) (when (and (member type '(d ds)) - (or (zerop parg) (<= 256 parg 511))) + (or (zerop parg) (<= %lev-size% + parg + (+ %lev-size% %max-lev-idx%)))) oc.(synerr "argument ~a of ~s cannot be destination" n syntax)) (when (and (member type '(rs ds)) - (not (< parg 1024))) + (not (small-op-p parg))) oc.(synerr "argument ~a of ~s isn't a small register" n syntax)) - (when (and (member type '(r rs d ds)) (< parg 256)) + (when (and (member type '(r rs d ds)) (< parg %lev-size%)) (set me.max-treg (max parg me.max-treg))) parg)) pattern (rest syntax) (range 1))) @@ -242,36 +249,36 @@ (defun parse-compound-operand (cons) (tree-case cons ((sym arg) - (when (<= 0 arg 255) + (when (< -1 arg %lev-size%) (caseq sym ((t) arg) - (d (+ arg 256))))) + (d (+ arg %lev-size%))))) ((sym arg1 arg2) - (when (and (<= 0 arg1 253) - (<= 0 arg2 255)) + (when (and (<= 0 arg1 %max-v-lev%) + (<= 0 arg2 %max-lev%)) (caseq sym - (v (+ (* (ssucc arg1) 256) arg2))))))) + (v (+ (* (ssucc arg1) %lev-size%) arg2))))))) (defun parse-operand (str) (cond ((r^$ #/t[0-9A-Fa-f][0-9A-Fa-f]?/ str) (int-str [str 1..:] 16)) ((r^$ #/d[0-9A-Fa-f][0-9A-Fa-f]?/ str) - (+ 256 (int-str [str 1..:] 16))) + (+ %lev-size% (int-str [str 1..:] 16))) ((r^$ #/v[0-9A-Fa-f]?[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]/ str) (let ((xn (int-str [`0@{str[1..:]}` -4..-2] 16)) (yn (int-str [str -2..:] 16))) - (+ (* 256 (+ 2 xn)) yn))))) + (+ (* %lev-size% (ssucc xn)) yn))))) (defun operand-to-sym (val) - (let ((xn (ash val -8)) - (yn (logtrunc val 8))) + (let ((xn (ash val (- %lev-bits%))) + (yn (logtrunc val %lev-bits%))) (caseql xn (0 (if (eql yn 0) nil (intern (fmt "t~,02X" yn)))) (1 (intern (fmt "d~,02X" yn))) - (t (intern (fmt "v~,02X~,02X" (- xn 2) yn)))))) + (t (intern (fmt "v~,02X~,02X" (ssucc xn) yn)))))) (defun bits-to-obj (bits width) (let ((tag (logtrunc bits 2)) @@ -281,6 +288,10 @@ (2 (chr-int val)) (t (error "assembler: bad immediate operand: ~s" bits))))) +(defmacro enc-small-op (val) val) + +(defmacro small-op-to-sym (val) ^(operand-to-sym ,val)) + (defstruct backpatch-low16 nil (:method backpatch (me asm at offs) (tree-bind (hi lo) asm.(get-pair) @@ -331,10 +342,12 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (lev size) asm.(parse-args me syntax '(n n)) - (unless (<= 1 lev 255) - me.(synerr "level must range from 2 to 256")) - (unless (<= 0 size 256) - me.(synerr "size must range from 0 to 256")) + (unless (<= 2 lev %max-lev-idx%) + me.(synerr "level must range from 2 to ~a" + %max-lev-idx%)) + (unless (<= 0 size %lev-size%) + me.(synerr "size must range from 0 to ~a" + %lev-size%)) asm.(put-insn me.code lev size))) (:method dis (me asm lev size) ^(,me.symbol ,lev ,size))) @@ -414,19 +427,19 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (dst src) asm.(parse-args me syntax '(d rs)) - asm.(put-insn me.code src dst))) + asm.(put-insn me.code (enc-small-op src) dst))) (:method dis (me asm src dst) - ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src)))) + ^(,me.symbol ,(operand-to-sym dst) ,(small-op-to-sym src)))) (defopcode op-movsr movsr auto (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (dst src) asm.(parse-args me syntax '(ds r)) - asm.(put-insn me.code dst src))) + asm.(put-insn me.code (enc-small-op dst) src))) (:method dis (me asm dst src) - ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src)))) + ^(,me.symbol ,(small-op-to-sym dst) ,(operand-to-sym src)))) (defopcode op-movrr movrr auto (:method asm (me asm syntax) @@ -443,8 +456,8 @@ (:method asm (me asm syntax) (tree-bind (dst src) asm.(parse-args me syntax '(d r)) (let ((real [%oc-hash% (cond - ((< dst 1024) 'movsr) - ((< src 1024) 'movrs) + ((small-op-p dst) 'movsr) + ((small-op-p src) 'movrs) (t 'movrr))])) real.(asm asm syntax))))) @@ -461,15 +474,16 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (dst imm) asm.(parse-args me syntax '(ds mi)) - asm.(put-insn me.code dst (logtrunc (sys:bits imm) 16)))) + asm.(put-insn me.code (enc-small-op dst) + (logtrunc (sys:bits imm) 16)))) (:method dis (me asm dst imm ) - ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 16)))) + ^(,me.symbol ,(small-op-to-sym dst) ,(bits-to-obj imm 16)))) (defopcode op-movrbi movrbi auto (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) - (tree-bind (dst imm) asm.(parse-args me syntax '(ds bi)) + (tree-bind (dst imm) asm.(parse-args me syntax '(d bi)) asm.(put-insn me.code 0 dst) asm.(put-word (logtrunc (sys:bits imm) 32)))) @@ -483,7 +497,7 @@ (let ((real [%oc-hash% (cond (asm.(immediate-fits-type src 'si) 'movrsi) ((and asm.(immediate-fits-type src 'si) - (< dst 1024)) 'movsmi) + (small-op-p dst)) 'movsmi) (t 'movrbi))])) real.(asm asm syntax))))) @@ -578,19 +592,19 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (name reg) asm.(parse-args me syntax '(rs r)) - asm.(put-insn me.code name reg))) + asm.(put-insn me.code (enc-small-op name) reg))) (:method dis (me asm name reg) - ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg)))) + ^(,me.symbol ,(small-op-to-sym name) ,(operand-to-sym reg)))) (defopcode op-retrs retrs auto (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (name reg) asm.(parse-args me syntax '(r rs)) - asm.(put-insn me.code reg name))) + asm.(put-insn me.code (enc-small-op reg) name))) (:method dis (me asm reg name) - ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg)))) + ^(,me.symbol ,(operand-to-sym name) ,(small-op-to-sym reg)))) (defopcode op-retrr retrr auto (:method asm (me asm syntax) @@ -608,8 +622,8 @@ me.(chk-arg-count 2 syntax) (tree-bind (name reg) asm.(parse-args me syntax '(r r)) (let ((real [%oc-hash% (cond - ((< name 1024) 'retsr) - ((< reg 1024) 'retrs) + ((small-op-p name) 'retsr) + ((small-op-p reg) 'retrs) (t 'retrr))])) real.(asm asm syntax))))) @@ -648,9 +662,9 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (reg name) asm.(parse-args me syntax '(d rs)) - asm.(put-insn me.code name reg))) + asm.(put-insn me.code (enc-small-op name) reg))) (:method dis (me asm name reg) - ^(,me.symbol ,(operand-to-sym reg) ,(operand-to-sym name)))) + ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) (defopcode-derived op-getf getf auto op-getv) @@ -666,9 +680,9 @@ (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) (tree-bind (reg name) asm.(parse-args me syntax '(r rs)) - asm.(put-insn me.code name reg))) + asm.(put-insn me.code (enc-small-op name) reg))) (:method dis (me asm name reg) - ^(,me.symbol ,(operand-to-sym reg) ,(operand-to-sym name)))) + ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) (defopcode-derived op-setl1 setl1 auto op-setv) @@ -680,10 +694,10 @@ (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)) - (unless (<= 0 frsize 255) - me.(synerr "frame size must be 0 to 255")) + (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) 8) frsize) reg) + asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg) asm.(put-pair req fix) (unless (eql fix (- (len regs) (if vari 1 0))) me.(synerr "wrong number of registers")) @@ -698,10 +712,11 @@ (:method dis (me asm high16 low16) (let ((dst (logior (ash high16 16) low16))) (tree-bind (vari-frsize reg) asm.(get-pair) - (let ((vari (bit vari-frsize 8))) + (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 8) + (add me.symbol (operand-to-sym reg) + (logtrunc vari-frsize %lev-bits%) dst fix req vari) (when vari (inc fix)) diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 4d37b9b5..0571e10c 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -24,6 +24,8 @@ ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +(load "vm-param") + (defstruct (frag oreg code : fvars ffuns) nil oreg code @@ -171,7 +173,7 @@ (condlet ((((null atom))) '(t 0)) (((dreg [me.dreg atom])) dreg) - ((((< me.dreg-cntr 256))) + ((((< me.dreg-cntr %lev-size%))) (let* ((dreg ^(d ,(pinc me.dreg-cntr)))) (set [me.data (cadr dreg)] atom) (set [me.dreg atom] dreg))) @@ -193,7 +195,7 @@ (defmeth compiler alloc-treg (me) (cond (me.tregs (pop me.tregs)) - ((< me.treg-cntr 256) ^(t ,(pinc me.treg-cntr))) + ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) (t (compile-error me.last-form "code too complex: out of registers")))) (defmeth compiler free-treg (me treg) @@ -219,6 +221,9 @@ (defmeth compiler new-env (me env) (when (>= env.lev me.nlev) + (unless (<= env.lev %max-lev%) + (compile-error me.last-form + "code too complex: lexical nesting too deep")) (set me.nlev (succ env.lev)))) (defmeth compiler compile (me oreg env form) @@ -290,7 +295,7 @@ (cond ((null form) (new (frag '(t 0) nil))) ((or (and (integerp form) - (< (width form) 32)) + (< (width form) %imm-width%)) (chrp form)) (new (frag oreg ^((movi ,oreg ,form))))) (t (let ((dreg me.(get-dreg form))) diff --git a/share/txr/stdlib/vm-param.tl b/share/txr/stdlib/vm-param.tl new file mode 100644 index 00000000..40ab68f6 --- /dev/null +++ b/share/txr/stdlib/vm-param.tl @@ -0,0 +1,32 @@ +;; Copyright 2018 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defsymacro %lev-size% 256) +(defsymacro %max-lev-idx% (macro-time (ppred %lev-size%))) +(defsymacro %lev-bits% 8) +(defsymacro %max-lev% 255) +(defsymacro %max-v-lev% (macro-time (ppred %max-lev%))) +(defsymacro %imm-width% 32) @@ -293,18 +293,49 @@ static void vm_reset(struct vm *vm, struct vm_desc *vd, #define vm_insn_bigop(insn) (((insn) & 0x3FFFFFFU)) #define vm_arg_operand_lo(arg) ((arg) & 0xFFFFU) #define vm_arg_operand_hi(arg) ((arg) >> 16) +#define VM_LEV_BITS 8 +#define VM_LEV_MASK 0xFF +#define VM_SM_LEV_BITS 8 +#define VM_SM_LEV_MASK 0xFF +#define vm_lev(arg) ((arg) >> VM_LEV_BITS) +#define vm_idx(arg) ((arg) & VM_LEV_MASK) +#define vm_sm_lev(arg) ((arg) >> VM_SM_LEV_BITS) +#define vm_sm_idx(arg) ((arg) & VM_SM_LEV_MASK) static val vm_execute(struct vm *vm); INLINE val vm_get(struct vm_env *dspl, unsigned ref) { - return dspl[ref >> 8].mem[ref & 0xFF]; + return dspl[vm_lev(ref)].mem[vm_idx(ref)]; +} + +INLINE val vm_sm_get(struct vm_env *dspl, unsigned ref) +{ + return dspl[vm_sm_lev(ref)].mem[vm_sm_idx(ref)]; } INLINE void vm_set(struct vm_env *dspl, unsigned ref, val newval) { - unsigned d = ref >> 8; - unsigned i = ref & 0xFF; + unsigned d = vm_lev(ref); + unsigned i = vm_idx(ref); + struct vm_env *env = &dspl[d]; + + if (d == 1) + uw_throwf(error_s, lit("modification of VM static data"), nao); + + if (ref == 0) + uw_throwf(error_s, lit("modification of t00/nil"), nao); + + env->mem[i] = newval; + + if (is_ptr(env->vec)) + mut(env->vec); +} + +INLINE void vm_sm_set(struct vm_env *dspl, unsigned ref, val newval) +{ + unsigned d = vm_sm_lev(ref); + unsigned i = vm_sm_idx(ref); struct vm_env *env = &dspl[d]; if (d == 1) @@ -319,6 +350,7 @@ INLINE void vm_set(struct vm_env *dspl, unsigned ref, val newval) mut(env->vec); } + static void vm_do_frame(struct vm *vm, vm_word_t insn, int capturable) { int lev = vm_insn_extra(insn); @@ -511,14 +543,14 @@ static void vm_gapply(struct vm *vm, vm_word_t insn) static void vm_movrs(struct vm *vm, vm_word_t insn) { - val datum = vm_get(vm->dspl, vm_insn_extra(insn)); + val datum = vm_sm_get(vm->dspl, vm_insn_extra(insn)); vm_set(vm->dspl, vm_insn_operand(insn), datum); } static void vm_movsr(struct vm *vm, vm_word_t insn) { val datum = vm_get(vm->dspl, vm_insn_operand(insn)); - vm_set(vm->dspl, vm_insn_extra(insn), datum); + vm_sm_set(vm->dspl, vm_insn_extra(insn), datum); } static void vm_movrr(struct vm *vm, vm_word_t insn) @@ -549,7 +581,7 @@ static void vm_movsmi(struct vm *vm, vm_word_t insn) if ((imm & TAG_MASK) == NUM && (imm & 0x8000)) imm |= negmask; - vm_set(vm->dspl, dst, coerce(val, imm)); + vm_sm_set(vm->dspl, dst, coerce(val, imm)); } static void vm_movrbi(struct vm *vm, vm_word_t insn) @@ -669,7 +701,7 @@ static void vm_no_block_err(struct vm *vm, val name) static void vm_retsr(struct vm *vm, vm_word_t insn) { val res = vm_get(vm->dspl, vm_insn_operand(insn)); - val tag = vm_get(vm->dspl, vm_insn_extra(insn)); + val tag = vm_sm_get(vm->dspl, vm_insn_extra(insn)); uw_block_return(tag, res); vm_no_block_err(vm, tag); @@ -677,7 +709,7 @@ static void vm_retsr(struct vm *vm, vm_word_t insn) static void vm_retrs(struct vm *vm, vm_word_t insn) { - val res = vm_get(vm->dspl, vm_insn_extra(insn)); + val res = vm_sm_get(vm->dspl, vm_insn_extra(insn)); val tag = vm_get(vm->dspl, vm_insn_operand(insn)); uw_block_return(tag, res); @@ -697,7 +729,7 @@ static void vm_retrr(struct vm *vm, vm_word_t insn) static void vm_abscsr(struct vm *vm, vm_word_t insn) { val res = vm_get(vm->dspl, vm_insn_operand(insn)); - val tag = vm_get(vm->dspl, vm_insn_extra(insn)); + val tag = vm_sm_get(vm->dspl, vm_insn_extra(insn)); uw_block_abscond(tag, res); vm_no_block_err(vm, tag); @@ -750,7 +782,7 @@ static val vm_get_binding(struct vm *vm, vm_word_t insn, val (*lookup_fn)(val env, val sym), val kind_str) { - val sym = vm_get(vm->dspl, vm_insn_extra(insn)); + val sym = vm_sm_get(vm->dspl, vm_insn_extra(insn)); val binding = lookup_fn(nil, sym); if (nilp(binding)) @@ -788,7 +820,7 @@ static void vm_setsym(struct vm *vm, vm_word_t insn, static void vm_bindv(struct vm *vm, vm_word_t insn) { - val sym = vm_get(vm->dspl, vm_insn_extra(insn)); + val sym = vm_sm_get(vm->dspl, vm_insn_extra(insn)); int src = vm_insn_operand(insn); if (nilp(dyn_env)) @@ -804,8 +836,8 @@ static void vm_close(struct vm *vm, vm_word_t insn) vm_word_t arg1 = vm->code[vm->ip++]; vm_word_t arg2 = vm->code[vm->ip++]; unsigned vari_fr = vm_arg_operand_hi(arg1); - int variadic = vari_fr & 0x100; - int frsz = vari_fr & 0xFF; + 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); |