diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | eval.c | 2 | ||||
| -rw-r--r-- | eval.h | 1 | ||||
| -rw-r--r-- | genvmop.txr | 18 | ||||
| -rw-r--r-- | lib.c | 88 | ||||
| -rw-r--r-- | lib.h | 3 | ||||
| -rw-r--r-- | lisplib.c | 34 | ||||
| -rw-r--r-- | share/txr/stdlib/asm.tl | 564 | ||||
| -rw-r--r-- | vm.c | 818 | ||||
| -rw-r--r-- | vm.h | 31 | ||||
| -rw-r--r-- | vmop.h | 61 |
11 files changed, 1585 insertions, 37 deletions
@@ -50,7 +50,7 @@ EXTRA_OBJS-y := OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o OBJS += args.o lisplib.o cadr.o struct.o itypes.o buf.o jmp.o protsym.o ffi.o -OBJS += strudel.o +OBJS += strudel.o vm.o OBJS-$(debug_support) += debug.o OBJS-$(have_syslog) += syslog.o OBJS-$(have_glob) += glob.o @@ -431,7 +431,7 @@ val lookup_var(val env, val sym) return lookup_global_var(sym); } -static val lookup_sym_lisp1(val env, val sym) +val lookup_sym_lisp1(val env, val sym) { uses_or2; @@ -51,6 +51,7 @@ val lookup_global_var(val sym); loc lookup_var_l(val env, val sym); loc lookup_global_var_l(val sym); val lookup_fun(val env, val sym); +val lookup_sym_lisp1(val env, val sym); val set_dyn_env(val de); val funcall_interp(val interp_fun, struct args *); val boundp(val sym); diff --git a/genvmop.txr b/genvmop.txr new file mode 100644 index 00000000..31c6062a --- /dev/null +++ b/genvmop.txr @@ -0,0 +1,18 @@ +@(include "asm") +@(in-package :sys) +@(bind oc @(keep-if .code %oc-list%)) +@(next "vm.h") +@(collect) +@{copyright} +@(until) + +@(end) +@(output "vmop.h") +@{copyright "\n"} + +typedef enum vm_op { +@ (repeat :vars (oc)) + @{oc.symbol :filter :upcase} = @{oc.code}, +@ (end) +} vm_op_t; +@(end) @@ -59,6 +59,7 @@ #include "utf8.h" #include "filter.h" #include "eval.h" +#include "vm.h" #include "sysif.h" #include "regex.h" #include "parser.h" @@ -6001,6 +6002,19 @@ val func_interp(val env, val form) return obj; } +val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic) +{ + val obj = make_obj(); + obj->f.type = FUN; + obj->f.functype = FVM; + obj->f.env = closure; + obj->f.f.vm_desc = desc; + obj->f.fixparam = reqargs; + obj->f.optargs = fixparam - reqargs; + obj->f.variadic = variadic; + return obj; +} + val func_get_form(val fun) { type_check(fun, FUN); @@ -6188,6 +6202,8 @@ val generic_funcall(val fun, struct args *args_in) return fun->f.f.n7(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6])); case N8: return fun->f.f.n8(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6]), z(arg[7])); + case FVM: + return vm_execute_closure(fun, args); case FINTERP: internal_error("unsupported function type"); } @@ -6206,42 +6222,47 @@ val generic_funcall(val fun, struct args *args_in) if (args->fill < reqargs) callerror(fun, lit("missing required arguments")); - { - args_decl(args_copy, max(args->fill - fixparam, ARGS_MIN)); - args = args_cat_zap_from(args_copy, args, fixparam); - } - switch (fun->f.functype) { case FINTERP: return funcall_interp(fun, args); - case F0: - return fun->f.f.f0v(fun->f.env, args); - case F1: - return fun->f.f.f1v(fun->f.env, z(arg[0]), args); - case F2: - return fun->f.f.f2v(fun->f.env, z(arg[0]), z(arg[1]), args); - case F3: - return fun->f.f.f3v(fun->f.env, z(arg[0]), z(arg[1]), z(arg[2]), args); - case F4: - return fun->f.f.f4v(fun->f.env, z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), args); - case N0: - return fun->f.f.n0v(args); - case N1: - return fun->f.f.n1v(z(arg[0]), args); - case N2: - return fun->f.f.n2v(z(arg[0]), z(arg[1]), args); - case N3: - return fun->f.f.n3v(z(arg[0]), z(arg[1]), z(arg[2]), args); - case N4: - return fun->f.f.n4v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), args); - case N5: - return fun->f.f.n5v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), args); - case N6: - return fun->f.f.n6v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), args); - case N7: - return fun->f.f.n7v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6]), args); - case N8: - return fun->f.f.n8v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6]), z(arg[7]), args); + case FVM: + return vm_execute_closure(fun, args); + default: + { + args_decl(args_copy, max(args->fill - fixparam, ARGS_MIN)); + args = args_cat_zap_from(args_copy, args, fixparam); + } + + switch (fun->f.functype) { + case F0: + return fun->f.f.f0v(fun->f.env, args); + case F1: + return fun->f.f.f1v(fun->f.env, z(arg[0]), args); + case F2: + return fun->f.f.f2v(fun->f.env, z(arg[0]), z(arg[1]), args); + case F3: + return fun->f.f.f3v(fun->f.env, z(arg[0]), z(arg[1]), z(arg[2]), args); + case F4: + return fun->f.f.f4v(fun->f.env, z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), args); + case N0: + return fun->f.f.n0v(args); + case N1: + return fun->f.f.n1v(z(arg[0]), args); + case N2: + return fun->f.f.n2v(z(arg[0]), z(arg[1]), args); + case N3: + return fun->f.f.n3v(z(arg[0]), z(arg[1]), z(arg[2]), args); + case N4: + return fun->f.f.n4v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), args); + case N5: + return fun->f.f.n5v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), args); + case N6: + return fun->f.f.n6v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), args); + case N7: + return fun->f.f.n7v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6]), args); + case N8: + return fun->f.f.n8v(z(arg[0]), z(arg[1]), z(arg[2]), z(arg[3]), z(arg[4]), z(arg[5]), z(arg[6]), z(arg[7]), args); + } } } @@ -11802,6 +11823,7 @@ void init(val *stack_bottom) rand_init(); stream_init(); strudel_init(); + vm_init(); #if HAVE_POSIX_SIGS sig_init(); #endif @@ -70,6 +70,7 @@ typedef enum type { typedef enum functype { FINTERP, /* Interpreted function. */ + FVM, /* VM function. */ F0, F1, F2, F3, F4, /* Intrinsic functions with env. */ N0, N1, N2, N3, N4, N5, N6, N7, N8 /* No-env intrinsics. */ } functype_t; @@ -148,6 +149,7 @@ struct func { val env; union { val interp_fun; + val vm_desc; val (*f0)(val); val (*f1)(val, val); val (*f2)(val, val, val); @@ -890,6 +892,7 @@ val func_n1ov(val (*fun)(val, varg), int reqargs); val func_n2ov(val (*fun)(val, val, varg), int reqargs); val func_n3ov(val (*fun)(val, val, val, varg), int reqargs); val func_interp(val env, val form); +val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic); val func_get_form(val fun); val func_get_env(val fun); val func_set_env(val fun, val env); @@ -46,10 +46,10 @@ val dl_table; int opt_dbg_autoload; val trace_loaded; -void set_dlt_entries(val dlt, val *name, val fun) +static void set_dlt_entries_impl(val dlt, val *name, val fun, val package) { for (; *name; name++) { - val sym = intern(*name, user_package); + val sym = intern(*name, package); if (fun) sethash(dlt, sym, fun); @@ -58,6 +58,16 @@ void set_dlt_entries(val dlt, val *name, val fun) } } +void set_dlt_entries(val dlt, val *name, val fun) +{ + set_dlt_entries_impl(dlt, name, fun, user_package); +} + +static void set_dlt_entries_sys(val dlt, val *name, val fun) +{ + set_dlt_entries_impl(dlt, name, fun, system_package); +} + static void intern_only(val *name) { for (; *name; name++) @@ -611,6 +621,25 @@ static val stream_wrap_instantiate(val set_fun) return nil; } +static val asm_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~aasm.tl"), stdlib_path, nao)); + return nil; +} + +static val asm_set_entries(val dlt, val fun) +{ + val name[] = { + lit("assembler"), + nil + }; + + set_dlt_entries_sys(dlt, name, fun); + return nil; +} + + static val op_set_entries(val dlt, val fun) { val name[] = { @@ -670,6 +699,7 @@ void lisplib_init(void) dlt_register(dl_table, ffi_instantiate, ffi_set_entries); dlt_register(dl_table, doloop_instantiate, doloop_set_entries); dlt_register(dl_table, stream_wrap_instantiate, stream_wrap_set_entries); + dlt_register(dl_table, asm_instantiate, asm_set_entries); if (!opt_compat || opt_compat >= 185) dlt_register(dl_table, op_instantiate, op_set_entries); diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl new file mode 100644 index 00000000..c6a7efc9 --- /dev/null +++ b/share/txr/stdlib/asm.tl @@ -0,0 +1,564 @@ +(in-package :sys) + +(defstruct oc-base nil + (:method synerr (me fmt . args) + (error `opcode @{me.symbol}: @fmt` . args)) + + (:method chk-arg-count (me n syntax) + (when (neq (length (rest syntax)) n) + me.(synerr "~s arguments required; ~s is invalid" + n syntax))) + + (:method chk-arg-count-min (me n syntax) + (when (< (length (rest syntax)) n) + me.(synerr "~s arguments required; ~s is invalid" + n syntax))) + + (:method backpatch (me asm at offs) + (error `assembler: @{me.symbol} doesn't backpatch`))) + +(defstruct assembler nil + buf + (bstr (make-buf-stream)) + (labdef (hash)) + (labref (hash)) + (:static imm-width (relate '(si mi bi) '(10 16 32))) + (:static sign-bits (relate '(fixnum bignum chr) '(1 1 0))) + (:static operand-name (relate '(si mi bi l r rs d ds n o) + '("small immediate" + "medium immediate" + "big immediate" + "label" + "register operand" + "register small operand" + "register destination operand" + "register small destination operand" + "integer" + "any object"))) + + (:postinit (me) + (set me.buf (get-buf-from-stream me.bstr))) + + (:method cur-pos (me) + (seek-stream me.bstr 0 :from-current)) + + (:method set-pos (me pos) + (seek-stream me.bstr pos :from-start)) + + (:method lookup-label (me sym oc) + (condlet + (((n [me.labdef sym])) n) + (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym]) + 0))) + + (:method define-label (me sym) + (let* ((pos me.(cur-pos)) + (ins (trunc pos 4))) + (set [me.labdef sym] ins) + (each ((entry (del [me.labref sym]))) + (tree-bind (oc . offs) entry + me.(set-pos (* 4 offs)) + oc.(backpatch me (* 4 offs) ins))) + me.(set-pos pos) + ins)) + + (:method read-buf (me bytes) + (let ((buf (make-buf bytes))) + (when (neql (fill-buf buf 0 me.bstr) bytes) + (error "assembler: read past instruction block")) + buf)) + + (:method put-word (me word) + (let* ((buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + + (:method put-insn (me code extension operand) + (let ((word (logior (ash code 26) (ash extension 16) operand)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + + (:method put-pair (me op1 op2) + (let ((word (logior (ash op1 16) op2)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + + (:method get-word (me) + (let* ((buf me.(read-buf (sizeof uint32)))) + (buf-get-u32 buf 0))) + + (:method get-insn (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -26) + (logtrunc (ash word -16) 10) + (logtrunc word 16)))) + + (:method get-pair (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -16) (logtrunc word 16)))) + + (:method immediate-fits-type (me arg operand-type) + (and (member (typeof arg) + '(fixnum bignum chr)) + (<= (+ (width arg) + [me.sign-bits (typeof arg)] + 2) + [me.imm-width operand-type]))) + + (:method parse-args (me oc syntax pattern) + (mapcar (lambda (type arg n) + (let ((parg (caseql type + ((si mi bi) + (when me.(immediate-fits-type arg type) + arg)) + (l (cond + ((keywordp arg) me.(lookup-label arg oc)) + ((integerp arg) arg))) + (n (if (integerp arg) arg)) + (o arg) + ((r rs d ds) + (cond + ((null arg) 0) + ((symbolp arg) + (parse-operand (symbol-name arg))))) + (t (error "assembler: invalid arg type spec"))))) + (unless (or parg (eq type 'o)) + 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))) + oc.(synerr "argument ~a of ~s cannot be destination" + n syntax)) + (when (and (member type '(rs ds)) + (not (< parg 1024))) + oc.(synerr "argument ~a of ~s isn't a small register" + n syntax)) + parg)) + pattern (rest syntax) (range 1))) + + (:method asm-one (me syntax) + (let ((oc (cond + ((keywordp syntax) [%oc-hash% 'label]) + ((consp syntax) [%oc-hash% (car syntax)])))) + (unless oc + (error "assembler: invalid instruction ~s" syntax)) + oc.(asm me syntax))) + + (:method asm (me insns) + (each ((i insns)) + me.(asm-one i)) + (unless (empty me.labref) + (error "assembler: dangling label references")) + (whenlet ((n (cdr [find-max me.labdef : cdr]))) + (unless (< 0 n (len me.buf)) + (error "assembler: labels outside of code")))) + + (:method dis-one (me) + (tree-bind (code extension operand) me.(get-insn) + (let ((oc [%oc-hash% code])) + oc.(dis me extension operand)))) + + (:method dis (me) + me.(set-pos 0) + (build + (while (< me.(cur-pos) (len me.buf)) + (add me.(dis-one))))) + + (:method dis-listing (me : (stream *stdout*)) + (let ((p 0) + (l (len me.buf))) + me.(set-pos p) + (while (< p l) + (let* ((dis me.(dis-one)) + (dis-txt (cat-str [mapcar tostring dis] " ")) + (q me.(cur-pos))) + me.(set-pos p) + (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt) + (while (< (inc p 4) q) + (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word))) + me.(set-pos q) + (set p q)))))) + +(defvarl %oc-list-builder% (new list-builder)) + +(defsymacro %oc-list% %oc-list-builder%.(get)) + +(defvarl %oc-hash% (hash)) + +(defvarl %oc-code% 0) + +(defun register-opcode (oc) + %oc-list-builder%.(add oc) + (set [%oc-hash% oc.symbol] oc) + (set [%oc-hash% oc.code] oc)) + +(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))) + ((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))))) + +(defun operand-to-sym (val) + (let ((xn (ash val -8)) + (yn (logtrunc val 8))) + (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)))))) + +(defun bits-to-obj (bits width) + (let ((tag (logtrunc bits 2)) + (val (ash bits -2))) + (caseq tag + (1 (sign-extend val (- width 2))) + (2 (chr-int val)) + (t (error "assembler: bad immediate operand: ~s" bits))))) + +(defmacro defopcode (class symbol code . slot-defs) + ^(symacrolet ((auto (pinc %oc-code%))) + (defstruct ,class oc-base + (:static symbol ',symbol) + (:static code ,code) + ,*slot-defs) + (register-opcode (new ,class)))) + +(defmacro defopcode-derived (class symbol code orig-class) + ^(symacrolet ((auto (pinc %oc-code%))) + (defstruct ,class ,orig-class + (:static symbol ',symbol) + (:static code ,code)) + (register-opcode (new ,class)))) + +(defopcode op-label label nil + (:method asm (me asm syntax) + (unless (keywordp syntax) + asm.(synerr "label must be keyword")) + asm.(define-label syntax)) + + (:method dis (me asm extension operand))) + +(defopcode op-noop noop auto + (:method asm (me asm syntax) + me.(chk-arg-count 0 syntax) + asm.(put-insn me.code 0 0)) + + (:method dis (me asm extension operand) + ^(,me.symbol))) + +(defopcode op-frame frame auto + (: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")) + asm.(put-insn me.code lev size))) + (:method dis (me asm lev size) + ^(,me.symbol ,lev ,size))) + +(defopcode-derived op-dframe dframe auto op-frame) + +(defopcode op-end end auto + (:method asm (me asm syntax) + me.(chk-arg-count 1 syntax) + (let ((res (car asm.(parse-args me syntax '(r))))) + asm.(put-insn me.code 0 res))) + (:method dis (me asm extension res) + ^(,me.symbol ,(operand-to-sym res)))) + +(defopcode-derived op-fin fin auto op-end) + +(defopcode op-call call auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 2 syntax) + (let* ((nargs (pred (len syntax))) + (syn-pat (repeat '(r) (succ 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) + (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 (operand-to-sym x)) + (unless (minusp funargs) + (add (operand-to-sym y)))))))) + +(defopcode-derived op-apply apply auto op-call) + +(defopcode op-movrs movrs auto + (: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))) + + (:method dis (me asm src dst) + ^(,me.symbol ,(operand-to-sym dst) ,(operand-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))) + + (:method dis (me asm dst src) + ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src)))) + +(defopcode op-movrr movrr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(d r)) + asm.(put-insn me.code 0 dst) + asm.(put-pair 0 src))) + + (:method dis (me asm extension dst) + (let ((src (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src))))) + +(defopcode op-mov-pseudo mov nil + (: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) + (t 'movrr))])) + real.(asm asm syntax))))) + +(defopcode op-movrsi movrsi auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst imm) asm.(parse-args me syntax '(d si)) + asm.(put-insn me.code (logtrunc (sys:bits imm) 10) dst))) + + (:method dis (me asm imm dst) + ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 10)))) + +(defopcode op-movsmi movsmi auto + (: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)))) + + (:method dis (me asm dst imm ) + ^(,me.symbol ,(operand-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)) + asm.(put-insn me.code 0 dst) + asm.(put-word (logtrunc (sys:bits imm) 32)))) + + (:method dis (me asm extension dst) + (let ((imm asm.(get-word))) + ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 32))))) + +(defopcode op-movi-pseudo movi nil + (:method asm (me asm syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(d bi)) + (let ((real [%oc-hash% (cond + (asm.(immediate-fits-type src 'si) 'movrsi) + ((and asm.(immediate-fits-type src 'si) + (< dst 1024)) 'movsmi) + (t 'movrbi))])) + real.(asm asm syntax))))) + +(defopcode op-jmp jmp auto + (:method asm (me asm syntax) + me.(chk-arg-count 1 syntax) + (let ((dst (car asm.(parse-args me syntax '(l))))) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + ^(,me.symbol ,(logior (ash high16 16) low16)))) + +(defopcode op-if if auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg dst) asm.(parse-args me syntax '(r l)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair 0 reg))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16)) + (reg (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym reg) ,dst)))) + +(defopcode-derived op-uwprot uwprot auto op-jmp) + +(defopcode op-block block auto + (:method asm (me asm syntax) + me.(chk-arg-count 3 syntax) + (tree-bind (outreg blname exitpt) asm.(parse-args me syntax '(r r l)) + asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16)) + asm.(put-pair outreg blname))) + + (:method backpatch (me asm at exitpt) + asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16))) + + (:method dis (me asm high16 low16) + (let ((exitpt (logior (ash high16 16) low16))) + (tree-bind (outreg blname) asm.(get-pair) + ^(,me.symbol ,(operand-to-sym outreg) ,(operand-to-sym blname) + ,exitpt))))) + +(defopcode op-retsr retsr auto + (: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))) + + (:method dis (me asm name reg) + ^(,me.symbol ,(operand-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))) + + (:method dis (me asm reg name) + ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg)))) + +(defopcode op-retrr retrr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (name reg) asm.(parse-args me syntax '(r r)) + asm.(put-insn me.code 0 reg) + asm.(put-pair 0 name))) + + (:method dis (me asm extension reg) + (let ((name (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg))))) + +(defopcode op-ret-pseudo ret nil + (:method asm (me asm syntax) + 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) + (t 'retrr))])) + real.(asm asm syntax))))) + +(defopcode op-catch catch auto + (:method asm (me asm syntax) + me.(chk-arg-count 4 syntax) + (tree-bind (sym args catch-syms dst) asm.(parse-args me syntax '(r r r l)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair sym args) + asm.(put-pair 0 catch-syms))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16))) + (tree-bind (sym args) asm.(get-pair) + (let ((catch-syms (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args) + ,(operand-to-sym catch-syms) ,dst)))))) + +(defopcode op-handle handle auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (fun handle-syms) asm.(parse-args me syntax '(r r)) + asm.(put-insn me.code 0 fun) + asm.(put-pair fun handle-syms))) + + (:method dis (me asm extension fun) + (let ((handle-syms (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms))))) + +(defopcode op-getv getv auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg name) asm.(parse-args me syntax '(ds r)) + asm.(put-insn me.code reg name))) + (:method dis (me asm reg name) + ^(,me.symbol ,(operand-to-sym reg) ,(operand-to-sym name)))) + +(defopcode-derived op-getf getf auto op-getv) + +(defopcode-derived op-getl1 getl1 auto op-getv) + +(defopcode-derived op-getvb getvb auto op-getv) + +(defopcode-derived op-getfb getfb auto op-getv) + +(defopcode-derived op-getl1b getl1b auto op-getv) + +(defopcode op-setv setv auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg name) asm.(parse-args me syntax '(s r)) + asm.(put-insn me.code reg name))) + (:method dis (me asm reg name) + ^(,me.symbol ,(operand-to-sym reg) ,(operand-to-sym name)))) + +(defopcode-derived op-setl1 setl1 auto op-setv) + +(defopcode-derived op-bindv bindv auto op-setv) + +(defopcode op-close close auto + (: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)) + (unless (<= 0 frsize 255) + me.(synerr "frame size must be 0 to 255")) + 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 req fix) + (while regs + (let ((x (pop regs)) + (y (or (pop regs) 0))) + asm.(put-pair y x)))))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (: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))) + (tree-bind (req fix) asm.(get-pair) + (build + (add me.symbol (operand-to-sym reg) (logtrunc vari-frsize 8) + 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)))))))))))) @@ -0,0 +1,818 @@ +/* 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. + */ + +#include <stddef.h> +#include <stdio.h> +#include <string.h> +#include <dirent.h> +#include <stdarg.h> +#include <stdlib.h> +#include <limits.h> +#include <signal.h> +#include <assert.h> +#include "config.h" +#include ALLOCA_H +#include "lib.h" +#include "hash.h" +#include "eval.h" +#include "signal.h" +#include "unwind.h" +#include "gc.h" +#include "args.h" +#include "itypes.h" +#include "buf.h" +#include "vmop.h" +#include "vm.h" + +typedef u32_t vm_word_t; + +#if HAVE_LITTLE_ENDIAN +#define vm_opcode(vw) ((vw) >> 26) +#define vm_oparg(vw) (((vw) >> 16) & 0x3FF) +#else +#define vm_opcode(vw) ((vw) >> 26) +#define vm_oparg(vw) (((vw) >> 16) & 0x3FF) +#endif + +#define zalloca(size) memset(alloca(size), 0, size) + +struct vm_desc { + val self; + int nlvl; + int nreg; + int frsz; + val bytecode; + val datavec; + vm_word_t *code; + val *data; +}; + +struct vm_env { + val *mem; + val vec; +}; + +struct vm { + struct vm_desc *vd; + int nlvl; + int lev; + unsigned ip; + vm_word_t *code; + struct vm_env *dspl; +}; + +struct vm_closure { + struct vm_desc *vd; + int frsz; + int nlvl; + unsigned ip; + struct vm_env *dspl; +}; + +val vm_desc_s, vm_closure_s; + +static_forward(struct cobj_ops vm_desc_ops); + +static_forward(struct cobj_ops vm_closure_ops); + +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 self = lit("sys:vm-make-desc"); + int nlvl = c_int(nlevels, self), nreg = c_int(nregs, self); + + if (nlvl < 2 || nlvl > 256) + uw_throwf(error_s, lit("~a: nlevels must be 2 to 256; ~s given"), + self, nlevels, nao); + + if (nreg < 1 || nreg > 256) + uw_throwf(error_s, lit("~a: nregs must be 1 to 256; ~s given"), + self, nregs, nao); + + { + mem_t *code = buf_get(bytecode, self); + loc data_loc = vecref_l(datavec, zero); + struct vm_desc *vd = coerce(struct vm_desc *, chk_malloc(sizeof *vd)); + val desc; + + vd->nlvl = nlvl; + vd->nreg = nreg; + vd->code = coerce(vm_word_t *, code); + vd->data = valptr(data_loc); + + vd->bytecode = nil; + vd->datavec = nil; + + vd->frsz = nlvl * 2 + nreg; + + vd->self = nil; + + desc = cobj(coerce(mem_t *, vd), vm_desc_s, &vm_desc_ops); + + vd->bytecode = bytecode; + vd->datavec = datavec; + vd->self = desc; + + return desc; + } +} + +static val vm_desc_bytecode(val desc) +{ + struct vm_desc *vd = vm_desc_struct(desc); + return vd->bytecode; +} + +static void vm_desc_mark(val obj) +{ + struct vm_desc *vd = coerce(struct vm_desc *, obj->co.handle); + gc_mark(vd->bytecode); + gc_mark(vd->datavec); +} + +static val vm_make_closure(struct vm *vm, int frsz) +{ + struct vm_env *dspl = coerce(struct vm_env *, + chk_calloc(vm->nlvl, sizeof *dspl)); + struct vm_closure *vc = coerce(struct vm_closure *, chk_malloc(sizeof *vc)); + val closure; + int i, j; + + vc->frsz = frsz; + vc->ip = vm->ip; + vc->nlvl = vm->lev + 1; + vc->vd = vm->vd; + vc->dspl = dspl; + + closure = cobj(coerce(mem_t *, vc), vm_closure_s, &vm_closure_ops); + + for (i = 2; i < vc->nlvl; i++) { + struct vm_env *sdi = &vm->dspl[i]; + struct vm_env *cdi = &dspl[i]; + val vec = sdi->vec; + val *mem = sdi->mem; + + switch (type(vec)) { + case NIL: + cdi->vec = nil; + cdi->mem = 0; + break; + case NUM: + { + int n = c_num(vec); + val heap_vec = vector(vec, nil); + cdi->vec = heap_vec; + cdi->mem = heap_vec->v.vec; + for (j = 0; j < n; j++) + heap_vec->v.vec[j] = mem[j]; + mut(closure); + *sdi = *cdi; + break; + } + case VEC: + cdi->vec = vec; + cdi->mem = mem; + break; + default: + internal_error("bad vector in vm display"); + } + } + + return closure; +} + +static void vm_closure_mark(val obj) +{ + struct vm_closure *vc = coerce(struct vm_closure *, obj->co.handle); + int i; + + gc_mark(vc->vd->self); + + for (i = 2; i < vc->nlvl; i++) + gc_mark(vc->dspl[i].vec); +} + +static void vm_reset(struct vm *vm, struct vm_desc *vd, + struct vm_env *dspl, + int start_lev, unsigned start_ip) +{ + vm->vd = vd; + vm->nlvl = vd->nlvl; + vm->lev = start_lev; + vm->ip = start_ip; + vm->code = vd->code; + vm->dspl = dspl; +} + +#define vm_insn_opcode(insn) coerce(vm_op_t, ((insn) >> 26)) +#define vm_insn_operand(insn) ((insn) & 0xFFFFU) +#define vm_insn_extra(insn) (((insn) >> 16) & 0x3FF) +#define vm_insn_bigop(insn) (((insn) & 0x3FFFFFFU)) +#define vm_arg_operand_lo(arg) ((arg) & 0xFFFFU) +#define vm_arg_operand_hi(arg) ((arg) >> 16) + +static val vm_execute(struct vm *vm); + +INLINE val vm_get(struct vm_env *dspl, unsigned ref) +{ + return dspl[ref >> 8].mem[ref & 0xFF]; +} + +INLINE void vm_set(struct vm_env *dspl, unsigned ref, val newval) +{ + unsigned d = ref >> 8; + unsigned i = ref & 0xFF; + 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); +} + +static void vm_frame(struct vm *vm, vm_word_t insn) +{ + int lev = vm_insn_extra(insn); + int size = vm_insn_operand(insn); + + if (lev != vm->lev + 1) + uw_throwf(error_s, lit("frame level mismatch"), nao); + + vm->lev = lev; + vm->dspl[lev].mem = coerce(val *, zalloca(size * sizeof (val *))); + vm->dspl[lev].vec = num_fast(size); + vm_execute(vm); + vm->lev = lev - 1; +} + +static void vm_dframe(struct vm *vm, vm_word_t insn) +{ + val saved_dyn_env = dyn_env; + dyn_env = make_env(nil, nil, dyn_env); + vm_frame(vm, insn); + dyn_env = saved_dyn_env; +} + +static val vm_end(struct vm *vm, vm_word_t insn) +{ + return vm_get(vm->dspl, vm_insn_operand(insn)); +} + +static val vm_fin(struct vm *vm, vm_word_t insn) +{ + vm->ip--; + return vm_get(vm->dspl, vm_insn_operand(insn)); +} + +static void vm_call(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(vm_get(vm->dspl, fun), args); + vm_set(vm->dspl, dest, result); +} + +static void vm_apply(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(vm_get(vm->dspl, fun), 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)); + 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); +} + +static void vm_movrr(struct vm *vm, vm_word_t insn) +{ + vm_word_t arg = vm->code[vm->ip++]; + val datum = vm_get(vm->dspl, vm_arg_operand_lo(arg)); + vm_set(vm->dspl, vm_insn_operand(insn), datum); +} + +static void vm_movrsi(struct vm *vm, vm_word_t insn) +{ + unsigned dst = vm_insn_operand(insn); + ucnum negmask = ~convert(ucnum, 0x3FF); + ucnum imm = vm_insn_extra(insn); + + if ((imm & TAG_MASK) == NUM && (imm & 0x200)) + imm |= negmask; + + vm_set(vm->dspl, dst, coerce(val, imm)); +} + +static void vm_movsmi(struct vm *vm, vm_word_t insn) +{ + unsigned dst = vm_insn_extra(insn); + ucnum negmask = ~convert(ucnum, 0xFFFF); + ucnum imm = vm_insn_operand(insn); + + if ((imm & TAG_MASK) == NUM && (imm & 0x8000)) + imm |= negmask; + + vm_set(vm->dspl, dst, coerce(val, imm)); +} + +static void vm_movrbi(struct vm *vm, vm_word_t insn) +{ + unsigned dst = vm_insn_operand(insn); + ucnum negmask = ~convert(ucnum, 0xFFFFFFFF); + ucnum imm = vm->code[vm->ip++]; + + if ((imm & TAG_MASK) == NUM && (imm & 0x80000000)) + imm |= negmask; + + vm_set(vm->dspl, dst, coerce(val, imm)); +} + +static void vm_jmp(struct vm *vm, vm_word_t insn) +{ + vm->ip = vm_insn_bigop(insn); +} + +static void vm_if(struct vm *vm, vm_word_t insn) +{ + unsigned ip = vm_insn_bigop(insn); + vm_word_t arg = vm->code[vm->ip++]; + val test = vm_get(vm->dspl, vm_arg_operand_lo(arg)); + + if (!test) + vm->ip = vm_insn_bigop(ip); +} + +static void vm_uwprot(struct vm *vm, vm_word_t insn) +{ + int saved_lev = vm->lev; + unsigned cleanup_ip = vm_insn_bigop(insn); + + uw_simple_catch_begin; + + vm_execute(vm); + + uw_unwind { + vm->lev = saved_lev; + vm->ip = cleanup_ip; + vm_execute(vm); + } + + uw_catch_end; +} + +static void vm_block(struct vm *vm, vm_word_t insn) +{ + unsigned exitpt = vm_insn_bigop(insn); + vm_word_t arg = vm->code[vm->ip++]; + unsigned outreg = vm_arg_operand_hi(arg); + unsigned blname = vm_arg_operand_lo(arg); + int saved_lev = vm->lev; + + uw_block_begin (vm_get(vm->dspl, blname), result); + result = vm_execute(vm); + uw_block_end; + + vm_set(vm->dspl, outreg, result); + vm->ip = exitpt; + vm->lev = saved_lev; +} + + +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)); + + uw_block_return(tag, res); +} + +static void vm_retrs(struct vm *vm, vm_word_t insn) +{ + val res = vm_get(vm->dspl, vm_insn_extra(insn)); + val tag = vm_get(vm->dspl, vm_insn_operand(insn)); + + uw_block_return(tag, res); +} + +static void vm_retrr(struct vm *vm, vm_word_t insn) +{ + vm_word_t arg = vm->code[vm->ip++]; + val res = vm_get(vm->dspl, vm_insn_operand(insn)); + val tag = vm_get(vm->dspl, vm_arg_operand_lo(arg)); + + uw_block_return(tag, res); +} + +static void vm_catch(struct vm *vm, vm_word_t insn) +{ + unsigned catch_ip = vm_insn_bigop(insn); + vm_word_t arg1 = vm->code[vm->ip++]; + vm_word_t arg2 = vm->code[vm->ip++]; + unsigned sym_reg = vm_arg_operand_hi(arg1); + unsigned args_reg = vm_arg_operand_lo(arg1); + val catch_syms = vm_get(vm->dspl, vm_arg_operand_lo(arg2)); + int saved_lev = vm->lev; + + uw_catch_begin (catch_syms, exsym, exvals); + + vm_execute(vm); + + uw_catch(exsym, exvals) { + vm_set(vm->dspl, sym_reg, exsym); + vm_set(vm->dspl, args_reg, exvals); + + vm->ip = catch_ip; + vm->lev = saved_lev; + + vm_execute(vm); + } + + uw_unwind; + + uw_catch_end; +} + +static void vm_handle(struct vm *vm, vm_word_t insn) +{ + val fun = vm_get(vm->dspl, vm_insn_operand(insn)); + vm_word_t arg1 = vm->code[vm->ip++]; + val handle_syms = vm_get(vm->dspl, vm_arg_operand_lo(arg1)); + uw_frame_t uw_handler; + + uw_push_handler(&uw_handler, handle_syms, fun); + + vm_execute(vm); + + uw_pop_frame(&uw_handler); +} + +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_operand(insn)); + val binding = lookup_fn(nil, sym); + + if (nilp(binding)) + eval_error(vm->vd->bytecode, lit("unbound ~a ~s"), kind_str, sym, nao); + + return binding; +} + +static void vm_getsym(struct vm *vm, vm_word_t insn, + val (*lookup_fn)(val env, val sym), + val kind_str) +{ + val binding = vm_get_binding(vm, insn, lookup_fn, kind_str); + int dst = vm_insn_extra(insn); + vm_set(vm->dspl, dst, cdr(binding)); +} + +static void vm_getbind(struct vm *vm, vm_word_t insn, + val (*lookup_fn)(val env, val sym), + val kind_str) +{ + val binding = vm_get_binding(vm, insn, lookup_fn, kind_str); + int dst = vm_insn_extra(insn); + vm_set(vm->dspl, dst, binding); +} + +static void vm_setsym(struct vm *vm, vm_word_t insn, + val (*lookup_fn)(val env, val sym), + val kind_str) +{ + val binding = vm_get_binding(vm, insn, lookup_fn, kind_str); + int src = vm_insn_extra(insn); + rplacd(binding, vm_get(vm->dspl, src)); +} + +static void vm_bindv(struct vm *vm, vm_word_t insn) +{ + val sym = vm_get(vm->dspl, vm_insn_operand(insn)); + int src = vm_insn_extra(insn); + + if (nilp(dyn_env)) + eval_error(vm->vd->bytecode, + lit("no environment for dynamic binding"), nao); + + env_vbind(dyn_env, sym, vm_get(vm->dspl, src)); +} + +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++]; + unsigned vari_fr = vm_arg_operand_hi(arg1); + int variadic = vari_fr & 0x100; + int frsz = vari_fr & 0xFF; + 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); + val vf = func_vm(closure, vm->vd->self, fixparam, reqargs, variadic); + + vm_set(vm->dspl, reg, vf); + vm->ip = dst; +} + +static val vm_execute(struct vm *vm) +{ + for (;;) { + vm_word_t insn = vm->code[vm->ip++]; + vm_op_t opcode = vm_insn_opcode(insn); + + switch (opcode) { + case NOOP: + break; + case FRAME: + vm_frame(vm, insn); + break; + case DFRAME: + vm_dframe(vm, insn); + break; + case END: + return vm_end(vm, insn); + case FIN: + return vm_fin(vm, insn); + case CALL: + vm_call(vm, insn); + break; + case APPLY: + vm_apply(vm, insn); + break; + case MOVRS: + vm_movrs(vm, insn); + break; + case MOVSR: + vm_movsr(vm, insn); + break; + case MOVRR: + vm_movrr(vm, insn); + break; + case MOVRSI: + vm_movrsi(vm, insn); + break; + case MOVSMI: + vm_movsmi(vm, insn); + break; + case MOVRBI: + vm_movrbi(vm, insn); + break; + case JMP: + vm_jmp(vm, insn); + break; + case IF: + vm_if(vm, insn); + break; + case UWPROT: + vm_uwprot(vm, insn); + break; + case BLOCK: + vm_block(vm, insn); + break; + case RETSR: + vm_retsr(vm, insn); + break; + case RETRS: + vm_retrs(vm, insn); + break; + case RETRR: + vm_retrr(vm, insn); + break; + case CATCH: + vm_catch(vm, insn); + break; + case HANDLE: + vm_handle(vm, insn); + break; + case GETV: + vm_getsym(vm, insn, lookup_var, lit("variable")); + break; + case GETF: + vm_getsym(vm, insn, lookup_fun, lit("function")); + break; + case GETL1: + vm_getsym(vm, insn, lookup_sym_lisp1, lit("variable/function")); + break; + case GETVB: + vm_getbind(vm, insn, lookup_var, lit("variable")); + break; + case GETFB: + vm_getbind(vm, insn, lookup_fun, lit("function")); + break; + case GETL1B: + vm_getbind(vm, insn, lookup_sym_lisp1, lit("variable/function")); + break; + case SETV: + vm_setsym(vm, insn, lookup_var, lit("variable")); + break; + case SETL1: + vm_setsym(vm, insn, lookup_sym_lisp1, lit("variable/function")); + break; + case BINDV: + vm_bindv(vm, insn); + break; + case CLOSE: + vm_close(vm, insn); + break; + default: + uw_throwf(error_s, lit("invalid opcode ~s"), num_fast(opcode), nao); + } + } +} + +val vm_execute_toplevel(val desc) +{ + struct vm_desc *vd = vm_desc_struct(desc); + struct vm vm; + val *frame = coerce(val *, alloca(sizeof *frame * vd->frsz)); + struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg); + + vm_reset(&vm, vd, dspl, 1, 0); + + vm.dspl = coerce(struct vm_env *, frame + vd->nreg); + + frame[0] = nil; + + vm.dspl[0].mem = frame; + vm.dspl[0].vec = nil; + + vm.dspl[1].mem = vd->data; + vm.dspl[0].vec = vd->datavec; + + return vm_execute(&vm); +} + +val vm_execute_closure(val fun, struct args *args) +{ + val closure = fun->f.env; + val desc = fun->f.f.vm_desc; + int fixparam = fun->f.fixparam; + int variadic = fun->f.variadic; + int nargs = fixparam + variadic; + struct vm_desc *vd = vm_desc_struct(desc); + struct vm_closure *vc = coerce(struct vm_closure *, closure->co.handle); + struct vm vm; + val *frame = coerce(val *, alloca(sizeof *frame * vd->frsz)); + struct vm_env *dspl = coerce(struct vm_env *, frame + vd->nreg); + val vargs = if3(variadic, args_get_rest(args, nargs), 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); + + frame[0] = nil; + + vm.dspl[0].mem = frame; + vm.dspl[0].vec = nil; + + vm.dspl[1].mem = vd->data; + vm.dspl[1].vec = vd->datavec; + + memcpy(vm.dspl + 2, vc->dspl + 2, (vc->nlvl - 2) * sizeof *vm.dspl); + + if (vc->frsz != 0) { + vm.lev++; + vm.dspl[vm.lev].mem = coerce(val *, zalloca(vc->frsz * sizeof (val *))); + vm.dspl[vm.lev].vec = num_fast(vc->frsz); + } + + while (nargs >= 2) { + nargs -= 2; + argw = vm.code[vm.ip++]; + unsigned xreg = vm_arg_operand_lo(argw); + unsigned yreg = vm_arg_operand_hi(argw); + vm_set(dspl, xreg, args_get(args, &ix)); + vm_set(dspl, yreg, args_get(args, &ix)); + } + + if (nargs) { + argw = vm.code[vm.ip++]; + unsigned xreg = vm_arg_operand_lo(argw); + vm_set(dspl, xreg, args_get(args, &ix)); + } + + if (variadic) { + unsigned vreg; + if (!nargs) { + argw = vm.code[vm.ip++]; + vreg = vm_arg_operand_lo(argw); + } else { + vreg = vm_arg_operand_hi(argw); + } + + vm_set(dspl, vreg, vargs); + } + + return vm_execute(&vm); +} + +static_def(struct cobj_ops vm_desc_ops = + cobj_ops_init(eq, + cobj_print_op, + cobj_destroy_free_op, + vm_desc_mark, + cobj_eq_hash_op)); + +static_def(struct cobj_ops vm_closure_ops = + cobj_ops_init(eq, + cobj_print_op, + cobj_destroy_free_op, + vm_closure_mark, + cobj_eq_hash_op)); + +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-desc-bytecode"), system_package), func_n1(vm_desc_bytecode)); + reg_fun(intern(lit("vm-interpret-toplevel"), system_package), func_n1(vm_execute_toplevel)); +} @@ -0,0 +1,31 @@ +/* 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. + */ + +val vm_make_desc(val nlevels, val nregs, val bytecode, val datavec); +val vm_execute_toplevel(val desc); +val vm_execute_closure(val fun, struct args *); +void vm_init(void); @@ -0,0 +1,61 @@ +/* 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. + */ + +typedef enum vm_op { + NOOP = 0, + FRAME = 1, + DFRAME = 2, + END = 3, + FIN = 4, + CALL = 5, + APPLY = 6, + MOVRS = 7, + MOVSR = 8, + MOVRR = 9, + MOVRSI = 10, + MOVSMI = 11, + MOVRBI = 12, + JMP = 13, + IF = 14, + UWPROT = 15, + BLOCK = 16, + RETSR = 17, + RETRS = 18, + RETRR = 19, + CATCH = 20, + HANDLE = 21, + GETV = 22, + GETF = 23, + GETL1 = 24, + GETVB = 25, + GETFB = 26, + GETL1B = 27, + SETV = 28, + SETL1 = 29, + BINDV = 30, + CLOSE = 31, +} vm_op_t; |