diff options
| -rw-r--r-- | share/txr/stdlib/asm.tl | 37 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 2 | ||||
| -rw-r--r-- | vm.c | 112 | ||||
| -rw-r--r-- | vm.h | 3 | ||||
| -rw-r--r-- | vmop.h | 56 |
5 files changed, 176 insertions, 34 deletions
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl index 521fcaff..6ebf03da 100644 --- a/share/txr/stdlib/asm.tl +++ b/share/txr/stdlib/asm.tl @@ -360,6 +360,34 @@ (defopcode-derived op-apply apply auto op-call) +(defopcode op-gcall gcall auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 2 syntax) + (let* ((nargs (pred (len syntax))) + (syn-pat (list* 'r 'n (repeat '(r) (sssucc nargs)))) + (funargs (ppred nargs)) + (args asm.(parse-args me syntax syn-pat))) + asm.(put-insn me.code funargs (pop args)) + (while args + (let ((x (pop args)) + (y (or (pop args) 0))) + asm.(put-pair y x))))) + + (:method dis (me asm funargs arg0) + (let ((first t)) + (build + (add me.symbol) + (add (operand-to-sym arg0)) + (inc funargs 1) + (while (> funargs 0) + (dec funargs 2) + (tree-bind (y x) asm.(get-pair) + (add (if (zap first) x (operand-to-sym x))) + (unless (minusp funargs) + (add (operand-to-sym y))))))))) + +(defopcode-derived op-gapply gapply auto op-gcall) + (defopcode op-movrs movrs auto (:method asm (me asm syntax) me.(chk-arg-count 2 syntax) @@ -635,14 +663,19 @@ (unless (minusp fix) (add (operand-to-sym y)))))))))))) -(defun disassemble-c-d (code data *stdout*) +(defun disassemble-c-d (code data funv *stdout*) (let ((asm (new assembler buf code))) (put-line "data:") (mapdo (do format t " d~,02x: ~s\n" @1 @2) (range 0) data) + (put-line "funs:") + (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) funv) (put-line "code:") asm.(dis-listing))) (defun usr:disassemble (obj : (stream *stdout*)) (typecase obj - (vm-desc (disassemble-c-d (vm-desc-bytecode obj) (vm-desc-datavec obj) stream)) + (vm-desc (disassemble-c-d (vm-desc-bytecode obj) + (vm-desc-datavec obj) + (vm-desc-funvec obj) + stream)) (t (error "~s: not a compiled object: ~s" 'vm-disassemble obj)))) diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 54251aed..cd7eb719 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -484,4 +484,4 @@ (let* ((oreg co.(alloc-treg)) (frag co.(compile oreg (new env) (expand* exp)))) as.(asm ^(,*frag.code (end ,frag.oreg))) - (vm-make-desc co.nlev co.nreg as.buf co.(get-datavec))))) + (vm-make-desc co.nlev co.nreg as.buf co.(get-datavec) #())))) @@ -67,8 +67,15 @@ struct vm_desc { int frsz; val bytecode; val datavec; + val funvec; vm_word_t *code; val *data; + struct vm_ftent *ftab; +}; + +struct vm_ftent { + val fb; + loc fbloc; }; struct vm_env { @@ -104,7 +111,8 @@ static struct vm_desc *vm_desc_struct(val obj) return coerce(struct vm_desc *, cobj_handle(obj, vm_desc_s)); } -val vm_make_desc(val nlevels, val nregs, val bytecode, val datavec) +val vm_make_desc(val nlevels, val nregs, val bytecode, + val datavec, val funvec) { val self = lit("sys:vm-make-desc"); int nlvl = c_int(nlevels, self), nreg = c_int(nregs, self); @@ -120,14 +128,20 @@ val vm_make_desc(val nlevels, val nregs, val bytecode, val datavec) { mem_t *code = buf_get(bytecode, self); val dvl = length_vec(datavec); + cnum fvl = c_num(length_vec(funvec)); loc data_loc = if3(dvl != zero, vecref_l(datavec, zero), nulloc); struct vm_desc *vd = coerce(struct vm_desc *, chk_malloc(sizeof *vd)); + struct vm_ftent *ftab = if3(fvl != 0, + coerce(struct vm_ftent *, + chk_calloc(fvl, sizeof *ftab)), 0); + cnum i; val desc; vd->nlvl = nlvl; vd->nreg = nreg; vd->code = coerce(vm_word_t *, code); vd->data = valptr(data_loc); + vd->ftab = ftab; vd->bytecode = nil; vd->datavec = nil; @@ -140,8 +154,15 @@ val vm_make_desc(val nlevels, val nregs, val bytecode, val datavec) vd->bytecode = bytecode; vd->datavec = datavec; + vd->funvec = funvec; vd->self = desc; + for (i = 0; i < fvl; i++) { + struct vm_ftent *fe = &ftab[i]; + fe->fb = lookup_fun(nil, vecref(funvec, num_fast(i))); + fe->fbloc = cdr_l(fe->fb); + } + return desc; } } @@ -158,11 +179,30 @@ static val vm_desc_datavec(val desc) return vd->datavec; } +static val vm_desc_funvec(val desc) +{ + struct vm_desc *vd = vm_desc_struct(desc); + return vd->funvec; +} + +static void vm_desc_destroy(val obj) +{ + struct vm_desc *vd = coerce(struct vm_desc *, obj->co.handle); + free(vd->ftab); + free(vd); +} + static void vm_desc_mark(val obj) { struct vm_desc *vd = coerce(struct vm_desc *, obj->co.handle); + cnum i, fvl = c_num(length_vec(vd->funvec)); + gc_mark(vd->bytecode); gc_mark(vd->datavec); + gc_mark(vd->funvec); + + for (i = 0; i < fvl; i++) + gc_mark(vd->ftab[i].fb); } static val vm_make_closure(struct vm *vm, int frsz) @@ -378,6 +418,65 @@ static void vm_apply(struct vm *vm, vm_word_t insn) vm_set(vm->dspl, dest, result); } +static void vm_gcall(struct vm *vm, vm_word_t insn) +{ + unsigned nargs = vm_insn_extra(insn); + unsigned dest = vm_insn_operand(insn); + vm_word_t argw = vm->code[vm->ip++]; + unsigned fun = vm_arg_operand_lo(argw); + val result; + args_decl (args, nargs < ARGS_MIN ? ARGS_MIN : nargs); + + if (nargs--) { + args_add(args, vm_get(vm->dspl, vm_arg_operand_hi(argw))); + + while (nargs >= 2) { + nargs -= 2; + argw = vm->code[vm->ip++]; + args_add(args, vm_get(vm->dspl, vm_arg_operand_lo(argw))); + args_add(args, vm_get(vm->dspl, vm_arg_operand_hi(argw))); + } + + if (nargs) { + argw = vm->code[vm->ip++]; + args_add(args, vm_get(vm->dspl, vm_arg_operand_lo(argw))); + } + } + + result = generic_funcall(deref(vm->vd->ftab[fun].fbloc), args); + vm_set(vm->dspl, dest, result); +} + +static void vm_gapply(struct vm *vm, vm_word_t insn) +{ + unsigned nargs = vm_insn_extra(insn); + unsigned dest = vm_insn_operand(insn); + vm_word_t argw = vm->code[vm->ip++]; + unsigned fun = vm_arg_operand_lo(argw); + val result; + args_decl (args, nargs < ARGS_MIN ? ARGS_MIN : nargs); + + if (nargs--) { + args_add(args, vm_get(vm->dspl, vm_arg_operand_hi(argw))); + + while (nargs >= 2) { + nargs -= 2; + argw = vm->code[vm->ip++]; + args_add(args, vm_get(vm->dspl, vm_arg_operand_lo(argw))); + args_add(args, vm_get(vm->dspl, vm_arg_operand_hi(argw))); + } + + if (nargs) { + argw = vm->code[vm->ip++]; + args_add(args, vm_get(vm->dspl, vm_arg_operand_lo(argw))); + } + } + + result = apply_intrinsic(deref(vm->vd->ftab[fun].fbloc), + args_get_list(args)); + vm_set(vm->dspl, dest, result); +} + static void vm_movrs(struct vm *vm, vm_word_t insn) { val datum = vm_get(vm->dspl, vm_insn_extra(insn)); @@ -672,6 +771,12 @@ static val vm_execute(struct vm *vm) case APPLY: vm_apply(vm, insn); break; + case GCALL: + vm_gcall(vm, insn); + break; + case GAPPLY: + vm_gapply(vm, insn); + break; case MOVRS: vm_movrs(vm, insn); break; @@ -850,7 +955,7 @@ val vm_execute_closure(val fun, struct args *args) static_def(struct cobj_ops vm_desc_ops = cobj_ops_init(eq, cobj_print_op, - cobj_destroy_free_op, + vm_desc_destroy, vm_desc_mark, cobj_eq_hash_op)); @@ -865,8 +970,9 @@ void vm_init(void) { vm_desc_s = intern(lit("vm-desc"), system_package); vm_closure_s = intern(lit("vm-closure"), system_package); - reg_fun(intern(lit("vm-make-desc"), system_package), func_n4(vm_make_desc)); + reg_fun(intern(lit("vm-make-desc"), system_package), func_n5(vm_make_desc)); reg_fun(intern(lit("vm-desc-bytecode"), system_package), func_n1(vm_desc_bytecode)); reg_fun(intern(lit("vm-desc-datavec"), system_package), func_n1(vm_desc_datavec)); + reg_fun(intern(lit("vm-desc-funvec"), system_package), func_n1(vm_desc_funvec)); reg_fun(intern(lit("vm-execute-toplevel"), system_package), func_n1(vm_execute_toplevel)); } @@ -25,7 +25,8 @@ * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -val vm_make_desc(val nlevels, val nregs, val bytecode, val datavec); +val vm_make_desc(val nlevels, val nregs, val bytecode, + val datavec, val funvec); val vm_execute_toplevel(val desc); val vm_execute_closure(val fun, struct args *); void vm_init(void); @@ -34,31 +34,33 @@ typedef enum vm_op { FIN = 5, CALL = 6, APPLY = 7, - MOVRS = 8, - MOVSR = 9, - MOVRR = 10, - MOVRSI = 11, - MOVSMI = 12, - MOVRBI = 13, - JMP = 14, - IF = 15, - IFQ = 16, - IFQL = 17, - UWPROT = 18, - BLOCK = 19, - RETSR = 20, - RETRS = 21, - RETRR = 22, - CATCH = 23, - HANDLE = 24, - GETV = 25, - GETF = 26, - GETL1 = 27, - GETVB = 28, - GETFB = 29, - GETL1B = 30, - SETV = 31, - SETL1 = 32, - BINDV = 33, - CLOSE = 34, + GCALL = 8, + GAPPLY = 9, + MOVRS = 10, + MOVSR = 11, + MOVRR = 12, + MOVRSI = 13, + MOVSMI = 14, + MOVRBI = 15, + JMP = 16, + IF = 17, + IFQ = 18, + IFQL = 19, + UWPROT = 20, + BLOCK = 21, + RETSR = 22, + RETRS = 23, + RETRR = 24, + CATCH = 25, + HANDLE = 26, + GETV = 27, + GETF = 28, + GETL1 = 29, + GETVB = 30, + GETFB = 31, + GETL1B = 32, + SETV = 33, + SETL1 = 34, + BINDV = 35, + CLOSE = 36, } vm_op_t; |