diff options
-rw-r--r-- | libguile/instructions.c | 12 | ||||
-rw-r--r-- | libguile/vm-engine.c | 746 | ||||
-rw-r--r-- | libguile/vm.c | 9 | ||||
-rw-r--r-- | module/Makefile.am | 3 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 40 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 17 | ||||
-rw-r--r-- | test-suite/tests/rtl.test | 65 |
7 files changed, 353 insertions, 539 deletions
diff --git a/libguile/instructions.c b/libguile/instructions.c index 9e7e5193c..43937d76a 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -67,7 +67,9 @@ SCM_SYMBOL (sym_bang, "!"); M(X8_U12_U12) \ M(X8_L24) \ M(B1_X7_L24) \ - M(B1_U7_L24) + M(B1_U7_L24) \ + M(B1_X7_U24) \ + M(B1_X31) #define TYPE_WIDTH 5 @@ -105,6 +107,8 @@ static SCM word_type_symbols[] = (OP (0, type0) | OP (1, type1) | OP (2, type2)) #define OP4(type0, type1, type2, type3) \ (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3)) +#define OP5(type0, type1, type2, type3, type4) \ + (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3) | OP (4, type4)) #define OP_DST (1 << (TYPE_WIDTH * 5)) @@ -254,7 +258,9 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0, /* Format: (name opcode word0 word1 ...) */ - if (WORD_TYPE (3, meta)) + if (WORD_TYPE (4, meta)) + len = 5; + else if (WORD_TYPE (3, meta)) len = 4; else if (WORD_TYPE (2, meta)) len = 3; @@ -267,6 +273,8 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0, switch (len) { + case 5: + tail = scm_cons (word_type_symbols[WORD_TYPE (4, meta)], tail); case 4: tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail); case 3: diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 613c638e4..369bb793a 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -641,9 +641,14 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \ VM_HANDLE_INTERRUPTS; \ ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \ - vp->sp = sp; \ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \ - *sp = val; \ + /* Clear frame. */ \ + sp[0] = SCM_BOOL_F; \ + sp[1] = SCM_BOOL_F; \ + sp[2] = SCM_BOOL_F; \ + /* Leave proc. */ \ + sp[4] = val; \ + vp->sp = sp + 4; \ POP_CONTINUATION_HOOK (sp, 1); \ NEXT (0); \ } while (0) @@ -715,7 +720,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) { \ scm_t_signed_bits x_bits = SCM_UNPACK (x); \ scm_t_signed_bits y_bits = SCM_UNPACK (y); \ - if (x_bits crel y_bits) \ + if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ @@ -727,8 +732,10 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) } \ else \ { \ + SCM res; \ SYNC_IP (); \ - if (scm_is_true (srel (x, y))) \ + res = srel (x, y); \ + if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ @@ -877,13 +884,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) base[2] = SCM_PACK (ip); /* ra */ base[3] = rtl_boot_continuation; fp = &base[4]; - ip = rtl_boot_single_value_continuation_code; - if (ip - 1 != rtl_boot_multiple_value_continuation_code) - abort(); + ip = (scm_t_uint32 *) rtl_boot_continuation_code; /* MV-call frame, function & arguments */ base[4] = SCM_PACK (fp); /* dynamic link */ - base[5] = SCM_PACK (ip - 1); /* in RTL programs, MVRA precedes RA by one */ + base[5] = SCM_PACK (ip); /* in RTL programs, MVRA same as RA */ base[6] = SCM_PACK (ip); /* ra */ base[7] = program; fp = vp->fp = &base[8]; @@ -945,87 +950,64 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) /* halt _:24 * - * Bring the VM to a halt, returning the single value from slot 1. + * Bring the VM to a halt, returning all the values from the stack. */ VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24)) { - SCM ret = LOCAL_REF (1); - - vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); - vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; - vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); - - return ret; - } - - /* halt/values _:24 - * - * Bring the VM to a halt, returning all the values from the MV stack. - */ - VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24)) - { - scm_t_ptrdiff n; - SCM ret = SCM_EOL; + scm_t_uint32 nvals = FRAME_LOCALS_COUNT() - 5; + SCM ret; - SYNC_BEFORE_GC(); + /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */ - /* Boot closure in r0, empty stack from r1 to r4, values from r5. */ - for (n = FRAME_LOCALS_COUNT () - 1; n >= 5; n--) - ret = scm_cons (LOCAL_REF (n), ret); + if (nvals == 1) + ret = LOCAL_REF (5); + else + { + scm_t_uint32 n; + ret = SCM_EOL; + SYNC_BEFORE_GC(); + for (n = nvals; n > 0; n--) + ret = scm_cons (LOCAL_REF (5 + n), ret); + ret = scm_values (ret); + } vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); - return scm_values (ret); - } - - /* push-frame from:24 _:8 nargs:24 - * - * Push a frame for a new procedure call starting at FROM. - * Reserve stack space for NARGS values in the new frame, including - * the procedure. - */ - VM_DEFINE_OP (2, push_frame, "push-frame", OP2 (U8_U24, X8_U24)) - { - scm_t_uint32 from, nargs, new_size, n; - - SCM_UNPACK_RTL_24 (op, from); - SCM_UNPACK_RTL_24 (ip[1], nargs); - - new_size = from + 3 + nargs; - ALLOC_FRAME (new_size); - - /* FIXME: Elide this initialization? */ - for (n = from; n < new_size; n++) - LOCAL_SET (n, SCM_UNDEFINED); - - NEXT (2); + return ret; } - /* call from:24 + /* call proc:24 _:8 nlocals:24 * - * Call a procedure. Links a call frame at FROM, saving the return - * address and the fp. + * Call a procedure. PROC is the local corresponding to a procedure. + * The three values below PROC will be overwritten by the saved call + * frame data. The new frame will have space for NLOCALS locals: one + * for the procedure, and the rest for the arguments which should + * already have been pushed on. * - * The MVRA of the new frame is set to point to the next instruction - * after the end of the `call' instruction. The word following that - * is the RA. + * When the call returns, execution proceeds with the next + * instruction. There may be any number of values on the return + * stack; the precise number can be had by subtracting the address of + * PROC from the post-call SP. */ - VM_DEFINE_OP (3, call, "call", OP1 (U8_U24)) + VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24)) { - scm_t_uint32 from; + scm_t_uint32 proc, nlocals; SCM *old_fp = fp; - SCM_UNPACK_RTL_24 (op, from); + SCM_UNPACK_RTL_24 (op, proc); + SCM_UNPACK_RTL_24 (ip[1], nlocals); VM_HANDLE_INTERRUPTS; - fp = vp->fp = old_fp + from + 3; + fp = vp->fp = old_fp + proc; SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 1); + SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2); SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 2); + RESET_FRAME (nlocals); + PUSH_CONTINUATION_HOOK (); APPLY_HOOK (); @@ -1036,32 +1018,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (0); } - /* call/values from:24 _:8 proc:24 - * - * Call a procedure, with the values already pushed above a call frame - * at FROM. This instruction is used to handle MV returns in the case - * that we can't inline the handler. + /* tail-call nlocals:24 * - * As with `call', the next instruction after the call/values will be - * the MVRA, and the word after that instruction is the RA. + * Tail-call a procedure. Requires that the procedure and all of the + * arguments have already been shuffled into position. */ - VM_DEFINE_OP (4, call_values, "call/values", OP2 (U8_U24, X8_U24)) + VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24)) { - scm_t_uint32 from, proc; - SCM *old_fp = fp; - - SCM_UNPACK_RTL_24 (op, from); - SCM_UNPACK_RTL_24 (ip[1], proc); + scm_t_uint32 nlocals; + + SCM_UNPACK_RTL_24 (op, nlocals); VM_HANDLE_INTERRUPTS; - fp = vp->fp = old_fp + from + 4; - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2); - SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3); - fp[-1] = old_fp[proc - 1]; - - PUSH_CONTINUATION_HOOK (); + RESET_FRAME (nlocals); APPLY_HOOK (); if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) @@ -1071,39 +1041,46 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (0); } - /* tail-call nargs:24 _:8 proc:24 + /* receive dst:12 proc:12 _:8 nlocals:24 * - * Tail-call a procedure. Requires that all of the arguments have - * already been shuffled into position. + * Receive a single return value from a call whose procedure was in + * PROC, asserting that the call actually returned at least one + * value. Afterwards, resets the frame to NLOCALS locals. */ - VM_DEFINE_OP (5, tail_call, "tail-call", OP2 (U8_U24, X8_U24)) + VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST) { - scm_t_uint32 nargs, proc; - - SCM_UNPACK_RTL_24 (op, nargs); - SCM_UNPACK_RTL_24 (ip[1], proc); - - VM_HANDLE_INTERRUPTS; - - fp[-1] = LOCAL_REF (proc); - /* No need to check for overflow, as the compiler has already - ensured that this frame has enough space. */ - RESET_FRAME (nargs + 1); - - APPLY_HOOK (); - - if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) - goto apply; + scm_t_uint16 dst, proc; + scm_t_uint32 nlocals; + SCM_UNPACK_RTL_12_12 (op, dst, proc); + SCM_UNPACK_RTL_24 (ip[1], nlocals); + VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ()); + LOCAL_SET (dst, LOCAL_REF (proc + 1)); + RESET_FRAME (nlocals); + NEXT (2); + } - ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp)); - NEXT (0); + /* receive-values proc:24 _:8 nvalues:24 + * + * Receive a return of multiple values from a call whose procedure was + * in PROC. If fewer than NVALUES values were returned, signal an + * error. After receive-values has run, the values can be copied down + * via `mov'. + */ + VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, X8_U24)) + { + scm_t_uint32 proc, nvalues; + SCM_UNPACK_RTL_24 (op, proc); + SCM_UNPACK_RTL_24 (ip[1], nvalues); + VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues, + vm_error_not_enough_values ()); + NEXT (2); } /* return src:24 * * Return a value. */ - VM_DEFINE_OP (6, return, "return", OP1 (U8_U24)) + VM_DEFINE_OP (5, return, "return", OP1 (U8_U24)) { scm_t_uint32 src; SCM_UNPACK_RTL_24 (op, src); @@ -1114,16 +1091,30 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Return a number of values from a call frame. This opcode * corresponds to an application of `values' in tail position. As - * with tail calls, we expect that the NVALUES values have already - * been shuffled down to a contiguous array starting at slot 0. + * with tail calls, we expect that the values have already been + * shuffled down to a contiguous array starting at slot 1. */ - VM_DEFINE_OP (7, return_values, "return/values", OP1 (U8_U24)) + VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_U24)) { - scm_t_uint32 nargs; - SCM_UNPACK_RTL_24 (op, nargs); - RESET_FRAME (nargs + 1); - fp[-1] = rtl_values; - goto op_values; + scm_t_uint32 nvalues; + SCM *base = fp; + + SCM_UNPACK_RTL_24 (op, nvalues); + + RESET_FRAME (nvalues + 1); + + VM_HANDLE_INTERRUPTS; + ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp); + fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); + + /* Clear stack frame. */ + base[-2] = SCM_BOOL_F; + base[-3] = SCM_BOOL_F; + base[-4] = SCM_BOOL_F; + + POP_CONTINUATION_HOOK (base, nvalues); + + NEXT (0); } @@ -1140,7 +1131,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * calling frame. This instruction is part of the trampolines * created in gsubr.c, and is not generated by the compiler. */ - VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24)) + VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24)) { scm_t_uint32 ptr_idx; SCM pointer, ret; @@ -1210,7 +1201,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * part of the trampolines created by the FFI, and is not generated by * the compiler. */ - VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12)) + VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12)) { scm_t_uint16 cif_idx, ptr_idx; SCM closure, cif, pointer, ret; @@ -1244,7 +1235,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * the implementation of undelimited continuations, and is not * generated by the compiler. */ - VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24)) + VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24)) { SCM contregs; scm_t_uint32 contregs_idx; @@ -1273,7 +1264,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * instruction is part of the implementation of partial continuations, * and is not generated by the compiler. */ - VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24)) + VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24)) { SCM vmcont; scm_t_uint32 cont_idx; @@ -1297,7 +1288,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * arguments. This instruction is part of the implementation of * `apply', and is not generated by the compiler. */ - VM_DEFINE_OP (12, apply, "apply", OP1 (U8_X24)) + VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24)) { int i, list_idx, list_len, nargs; SCM list; @@ -1341,7 +1332,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * local slot 0 to it. This instruction is part of the implementation * of `call/cc', and is not generated by the compiler. */ - VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24)) + VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24)) #if 0 { SCM vm_cont, cont; @@ -1376,37 +1367,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) abort(); #endif - /* values _:24 - * - * Return all values on the stack to the current continuation. - * This instruction is part of the implementation of - * `values', and is not generated by the compiler. - */ - VM_DEFINE_OP (14, values, "values", OP1 (U8_X24)) - { - SCM *base = fp; -#if VM_USE_HOOKS - int nargs = FRAME_LOCALS_COUNT () - 1; -#endif - - /* We don't do much; it's the caller that's responsible for - shuffling values and resetting the stack. */ - - VM_HANDLE_INTERRUPTS; - ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp); - fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); - - /* Clear stack frame. */ - base[-1] = SCM_BOOL_F; - base[-2] = SCM_BOOL_F; - base[-3] = SCM_BOOL_F; - base[-4] = SCM_BOOL_F; - - POP_CONTINUATION_HOOK (base, nargs); - - NEXT (0); - } - @@ -1422,15 +1382,15 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to * the current instruction pointer. */ - VM_DEFINE_OP (15, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24)) { BR_NARGS (!=); } - VM_DEFINE_OP (16, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24)) { BR_NARGS (<); } - VM_DEFINE_OP (17, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24)) { BR_NARGS (>); } @@ -1442,7 +1402,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the number of actual arguments is not ==, >=, or <= EXPECTED, * respectively, signal an error. */ - VM_DEFINE_OP (18, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24)) + VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24)) { scm_t_uint32 expected; SCM_UNPACK_RTL_24 (op, expected); @@ -1450,7 +1410,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } - VM_DEFINE_OP (19, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24)) + VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24)) { scm_t_uint32 expected; SCM_UNPACK_RTL_24 (op, expected); @@ -1458,7 +1418,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } - VM_DEFINE_OP (20, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24)) + VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24)) { scm_t_uint32 expected; SCM_UNPACK_RTL_24 (op, expected); @@ -1467,13 +1427,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* reserve-locals nlocals:24 + /* alloc-frame nlocals:24 * * Ensure that there is space on the stack for NLOCALS local variables, * setting them all to SCM_UNDEFINED, except those nargs values that * were passed as arguments and procedure. */ - VM_DEFINE_OP (21, reserve_locals, "reserve-locals", OP1 (U8_U24)) + VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24)) { scm_t_uint32 nlocals, nargs; SCM_UNPACK_RTL_24 (op, nlocals); @@ -1486,12 +1446,26 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } + /* reset-frame nlocals:24 + * + * Like alloc-frame, but doesn't check that the stack is big enough. + * Used to reset the frame size to something less than the size that + * was previously set via alloc-frame. + */ + VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24)) + { + scm_t_uint32 nlocals; + SCM_UNPACK_RTL_24 (op, nlocals); + RESET_FRAME (nlocals); + NEXT (1); + } + /* assert-nargs-ee/locals expected:12 nlocals:12 * * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The * number of locals reserved is EXPECTED + NLOCALS. */ - VM_DEFINE_OP (22, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12)) + VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12)) { scm_t_uint16 expected, nlocals; SCM_UNPACK_RTL_12_12 (op, expected, nlocals); @@ -1516,7 +1490,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * A macro-mega-instruction. */ - VM_DEFINE_OP (23, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32)) + VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32)) { scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs; scm_t_int32 kw_offset; @@ -1602,7 +1576,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Collect any arguments at or above DST into a list, and store that * list at DST. */ - VM_DEFINE_OP (24, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) { scm_t_uint32 dst, nargs; SCM rest = SCM_EOL; @@ -1623,22 +1597,6 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* drop-values nlocals:24 - * - * Reset the stack pointer to only have space for NLOCALS values. - * Used after extracting values from an MV return. - */ - VM_DEFINE_OP (25, drop_values, "drop-values", OP1 (U8_U24)) - { - scm_t_bits nlocals; - - SCM_UNPACK_RTL_24 (op, nlocals); - - RESET_FRAME (nlocals); - - NEXT (1); - } - @@ -1651,7 +1609,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Add OFFSET, a signed 24-bit number, to the current instruction * pointer. */ - VM_DEFINE_OP (26, br, "br", OP1 (U8_L24)) + VM_DEFINE_OP (24, br, "br", OP1 (U8_L24)) { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ @@ -1663,7 +1621,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is true for the purposes of Scheme, add * OFFSET, a signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (27, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_true (x)); } @@ -1673,7 +1631,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a * signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (28, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_null (x)); } @@ -1683,7 +1641,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (29, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_lisp_false (x)); } @@ -1693,7 +1651,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is a pair, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (30, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, scm_is_pair (x)); } @@ -1703,7 +1661,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is a struct, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (31, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_STRUCTP (x)); } @@ -1713,7 +1671,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST is a char, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (32, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) { BR_UNARY (x, SCM_CHARP (x)); } @@ -1723,7 +1681,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in TEST has the TC7 given in the second word, add * OFFSET, a signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (33, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) + VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) { BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f)); } @@ -1733,7 +1691,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in A is eq? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (34, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y)); } @@ -1743,7 +1701,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in A is eqv? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (35, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1751,13 +1709,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) && scm_is_true (scm_eqv_p (x, y)))); } + // FIXME: remove, have compiler inline eqv test instead /* br-if-equal a:12 b:12 invert:1 _:7 offset:24 * * If the value in A is equal? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ // FIXME: should sync_ip before calling out? - VM_DEFINE_OP (36, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1765,12 +1724,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) && scm_is_true (scm_equal_p (x, y)))); } - /* br-if-= a:12 b:12 _:8 offset:24 + /* br-if-= a:12 b:12 invert:1 _:7 offset:24 * * If the value in A is = to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (37, br_if_ee, "br-if-=", OP2 (U8_U12_U12, X8_L24)) + VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (==, scm_num_eq_p); } @@ -1780,7 +1739,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in A is < to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (38, br_if_lt, "br-if-<", OP2 (U8_U12_U12, X8_L24)) + VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<, scm_less_p); } @@ -1790,31 +1749,11 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * If the value in A is <= to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (39, br_if_le, "br-if-<=", OP2 (U8_U12_U12, X8_L24)) + VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) { BR_ARITHMETIC (<=, scm_leq_p); } - /* br-if-> a:12 b:12 _:8 offset:24 - * - * If the value in A is > to the value in B, add OFFSET, a signed - * 24-bit number, to the current instruction pointer. - */ - VM_DEFINE_OP (40, br_if_gt, "br-if->", OP2 (U8_U12_U12, X8_L24)) - { - BR_ARITHMETIC (>, scm_gr_p); - } - - /* br-if->= a:12 b:12 _:8 offset:24 - * - * If the value in A is >= to the value in B, add OFFSET, a signed - * 24-bit number, to the current instruction pointer. - */ - VM_DEFINE_OP (41, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24)) - { - BR_ARITHMETIC (>=, scm_geq_p); - } - @@ -1826,7 +1765,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst; scm_t_uint16 src; @@ -1841,7 +1780,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) + VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 src; @@ -1857,7 +1796,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Create a new variable holding SRC, and place it in DST. */ - VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); @@ -1865,40 +1804,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* empty-box dst:24 - * - * Create a new unbound variable, and place it in DST. Used in the - * general implementation of `letrec', in those cases that fix-letrec - * fails to fix. - */ - VM_DEFINE_OP (45, empty_box, "empty-box", OP1 (U8_U24) | OP_DST) - { - scm_t_uint32 dst; - SCM_UNPACK_RTL_24 (op, dst); - LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); - NEXT (1); - } - /* box-ref dst:12 src:12 * * Unpack the variable at SRC into DST, asserting that the variable is * actually bound. */ - VM_DEFINE_OP (46, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM var; SCM_UNPACK_RTL_12_12 (op, dst, src); var = LOCAL_REF (src); VM_ASSERT (SCM_VARIABLEP (var), abort ()); - if (SCM_UNLIKELY (!VARIABLE_BOUNDP (var))) - { - SCM var_name; - /* Attempt to provide the variable name in the error message. */ - SYNC_IP (); - var_name = scm_module_reverse_lookup (scm_current_module (), var); - vm_error_unbound (SCM_FRAME_PROGRAM (fp), scm_is_true (var_name) ? var_name : var); - } + VM_ASSERT (VARIABLE_BOUNDP (var), + vm_error_unbound (SCM_FRAME_PROGRAM (fp), var)); LOCAL_SET (dst, VARIABLE_REF (var)); NEXT (1); } @@ -1907,7 +1826,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the contents of the variable at DST to SET. */ - VM_DEFINE_OP (47, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM var; @@ -1925,7 +1844,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * signed 32-bit integer. Space for NFREE free variables will be * allocated. */ - VM_DEFINE_OP (48, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) + VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) { scm_t_uint32 dst, nfree, n; scm_t_int32 offset; @@ -1949,7 +1868,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Load free variable IDX from the closure SRC into local slot DST. */ - VM_DEFINE_OP (49, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1964,7 +1883,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set free variable IDX from the closure DST to SRC. */ - VM_DEFINE_OP (50, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) + VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1987,7 +1906,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ - VM_DEFINE_OP (51, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST) + VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST) { scm_t_uint8 dst; scm_t_bits val; @@ -2002,7 +1921,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ - VM_DEFINE_OP (52, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32)) + VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32)) { scm_t_uint8 dst; scm_t_bits val; @@ -2017,7 +1936,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Make an immediate with HIGH-BITS and LOW-BITS. */ - VM_DEFINE_OP (53, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST) + VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST) { scm_t_uint8 dst; scm_t_bits val; @@ -2048,7 +1967,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Whether the object is mutable or immutable depends on where it was * allocated by the compiler, and loaded by the loader. */ - VM_DEFINE_OP (54, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST) + VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST) { scm_t_uint32 dst; scm_t_int32 offset; @@ -2077,7 +1996,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * that the compiler is unable to statically allocate, like symbols. * These values would be initialized when the object file loads. */ - VM_DEFINE_OP (55, static_ref, "static-ref", OP2 (U8_U24, S32)) + VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32)) { scm_t_uint32 dst; scm_t_int32 offset; @@ -2100,7 +2019,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Store a SCM value into memory, OFFSET 32-bit words away from the * current instruction pointer. OFFSET is a signed value. */ - VM_DEFINE_OP (56, static_set, "static-set!", OP2 (U8_U24, LO32)) + VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32)) { scm_t_uint32 src; scm_t_int32 offset; @@ -2122,7 +2041,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * words away from the current instruction pointer. OFFSET is a * signed value. */ - VM_DEFINE_OP (57, link_procedure, "link-procedure!", OP2 (U8_U24, L32)) + VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32)) { scm_t_uint32 src; scm_t_int32 offset; @@ -2164,26 +2083,20 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) (lambda () (if (foo) a b)) - Although one can use resolve and box-ref, the toplevel-ref and - toplevel-set! instructions are better for references. + The toplevel-box instruction is equivalent to "resolve", but + caches the resulting variable in statically allocated memory. 3. A reference to an identifier with respect to a particular module. This can happen for primitive references, and - references residualized by macro expansions. These can be - cached or not, depending on whether they are in a lambda or not. - - (@ (foo bar) a) - (@@ (foo bar) a) - - For these, one can use resolve-module, resolve, and the box - interface, though there is also module-ref as a shortcut. + references residualized by macro expansions. These can always + be cached. Use module-box for these. */ /* current-module dst:24 * * Store the current module in DST. */ - VM_DEFINE_OP (58, current_module, "current-module", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST) { scm_t_uint32 dst; @@ -2195,42 +2108,28 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* resolve dst:8 mod:8 sym:8 + /* resolve dst:24 bound?:1 _:7 sym:24 * - * Resolve SYM in MOD, and place the resulting variable in DST. - */ - VM_DEFINE_OP (59, resolve, "resolve", OP1 (U8_U8_U8_U8) | OP_DST) - { - scm_t_uint8 dst, mod, sym; - - SCM_UNPACK_RTL_8_8_8 (op, dst, mod, sym); - - SYNC_IP (); - LOCAL_SET (dst, scm_module_lookup (LOCAL_REF (mod), LOCAL_REF (sym))); - - NEXT (1); - } - - /* resolve-module dst:8 name:8 public:8 - * - * Resolve a module with name NAME, placing it in DST. If PUBLIC is - * nonzero, resolve the public interface, otherwise use the private - * interface. + * Resolve SYM in the current module, and place the resulting variable + * in DST. */ - VM_DEFINE_OP (60, resolve_module, "resolve-module", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) { - scm_t_uint8 dst, name, public; - SCM mod; + scm_t_uint32 dst; + scm_t_uint32 sym; + SCM var; - SCM_UNPACK_RTL_8_8_8 (op, dst, name, public); + SCM_UNPACK_RTL_24 (op, dst); + SCM_UNPACK_RTL_24 (ip[1], sym); SYNC_IP (); - mod = scm_resolve_module (LOCAL_REF (name)); - if (public) - mod = scm_module_public_interface (mod); - LOCAL_SET (dst, mod); + var = scm_lookup (LOCAL_REF (sym)); + if (ip[1] & 0x1) + VM_ASSERT (VARIABLE_BOUNDP (var), + vm_error_unbound (fp[-1], LOCAL_REF (sym))); + LOCAL_SET (dst, var); - NEXT (1); + NEXT (2); } /* define sym:12 val:12 @@ -2238,7 +2137,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (61, define, "define", OP1 (U8_U12_U12)) + VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12)) { scm_t_uint16 sym, val; SCM_UNPACK_RTL_12_12 (op, sym, val); @@ -2247,26 +2146,26 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* toplevel-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32 + /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31 * * Load a SCM value. The SCM value will be fetched from memory, * VAR-OFFSET 32-bit words away from the current instruction pointer. - * VAR-OFFSET is a signed value. Up to here, toplevel-ref is like + * VAR-OFFSET is a signed value. Up to here, toplevel-box is like * static-ref. * - * Then, if the loaded value is a variable, the value of the variable - * is placed in DST, and control flow continues. + * Then, if the loaded value is a variable, it is placed in DST, and control + * flow continues. * * Otherwise, we have to resolve the variable. In that case we load * the module from MOD-OFFSET, just as we loaded the variable. * Usually the module gets set when the closure is created. The name * is an offset to a symbol. * - * We use the module and the string to resolve the variable, raising - * an error if it is unbound, unbox it into DST, and cache the - * resolved variable so that we will hit the cache next time. + * We use the module and the symbol to resolve the variable, placing it in + * DST, and caching the resolved variable so that we will hit the cache next + * time. */ - VM_DEFINE_OP (62, toplevel_ref, "toplevel-ref", OP4 (U8_U24, S32, S32, N32) | OP_DST) + VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2298,66 +2197,22 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) sym = *((SCM *) sym_loc); var = scm_module_lookup (mod, sym); - VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym)); + if (ip[4] & 0x1) + VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym)); *var_loc = var; } - LOCAL_SET (dst, VARIABLE_REF (var)); - NEXT (4); + LOCAL_SET (dst, var); + NEXT (5); } - /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32 + /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31 * - * Set a top-level variable from a variable cache cell. The variable - * is resolved as in toplevel-ref. - */ - VM_DEFINE_OP (63, toplevel_set, "toplevel-set!", OP4 (U8_U24, S32, S32, N32)) - { - scm_t_uint32 src; - scm_t_int32 var_offset; - scm_t_uint32* var_loc_u32; - SCM *var_loc; - SCM var; - - SCM_UNPACK_RTL_24 (op, src); - var_offset = ip[1]; - var_loc_u32 = ip + var_offset; - VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort()); - var_loc = (SCM *) var_loc_u32; - var = *var_loc; - - if (SCM_UNLIKELY (!SCM_VARIABLEP (var))) - { - SCM mod, sym; - scm_t_int32 mod_offset = ip[2]; /* signed */ - scm_t_int32 sym_offset = ip[3]; /* signed */ - scm_t_uint32 *mod_loc = ip + mod_offset; - scm_t_uint32 *sym_loc = ip + sym_offset; - - SYNC_IP (); - - VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort()); - VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort()); - - mod = *((SCM *) mod_loc); - sym = *((SCM *) sym_loc); - - var = scm_module_lookup (mod, sym); - - *var_loc = var; - } - - VARIABLE_SET (var, LOCAL_REF (src)); - NEXT (4); - } - - /* module-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32 - * - * Like toplevel-ref, except MOD-OFFSET points at the name of a module + * Like toplevel-box, except MOD-OFFSET points at the name of a module * instead of the module itself. */ - VM_DEFINE_OP (64, module_ref, "module-ref", OP4 (U8_U24, S32, N32, N32) | OP_DST) + VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2393,61 +2248,14 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) else var = scm_private_lookup (SCM_CDR (modname), sym); - VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym)); - - *var_loc = var; - } - - LOCAL_SET (dst, VARIABLE_REF (var)); - NEXT (4); - } - - /* module-set! src:24 var-offset:32 mod-offset:32 sym-offset:32 - * - * Like toplevel-set!, except MOD-OFFSET points at the name of a module - * instead of the module itself. - */ - VM_DEFINE_OP (65, module_set, "module-set!", OP4 (U8_U24, S32, N32, N32)) - { - scm_t_uint32 src; - scm_t_int32 var_offset; - scm_t_uint32* var_loc_u32; - SCM *var_loc; - SCM var; - - SCM_UNPACK_RTL_24 (op, src); - var_offset = ip[1]; - var_loc_u32 = ip + var_offset; - VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort()); - var_loc = (SCM *) var_loc_u32; - var = *var_loc; - - if (SCM_UNLIKELY (!SCM_VARIABLEP (var))) - { - SCM modname, sym; - scm_t_int32 modname_offset = ip[2]; /* signed */ - scm_t_int32 sym_offset = ip[3]; /* signed */ - scm_t_uint32 *modname_words = ip + modname_offset; - scm_t_uint32 *sym_loc = ip + sym_offset; - - SYNC_IP (); - - VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort()); - VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort()); - - modname = SCM_PACK ((scm_t_bits) modname_words); - sym = *((SCM *) sym_loc); - - if (scm_is_true (SCM_CAR (modname))) - var = scm_public_lookup (SCM_CDR (modname), sym); - else - var = scm_private_lookup (SCM_CDR (modname), sym); + if (ip[4] & 0x1) + VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym)); *var_loc = var; } - VARIABLE_SET (var, LOCAL_REF (src)); - NEXT (4); + LOCAL_SET (dst, var); + NEXT (5); } @@ -2462,7 +2270,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * handler at HANDLER-OFFSET words from the current IP. The handler * will expect a multiple-value return. */ - VM_DEFINE_OP (66, prompt, "prompt", OP2 (U8_U24, U8_L24)) + VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24)) #if 0 { scm_t_uint32 tag; @@ -2494,7 +2302,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * the compiler should have inserted checks that they wind and unwind * procs are thunks, if it could not prove that to be the case. */ - VM_DEFINE_OP (67, wind, "wind", OP1 (U8_U12_U12)) + VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12)) { scm_t_uint16 winder, unwinder; SCM_UNPACK_RTL_12_12 (op, winder, unwinder); @@ -2503,12 +2311,12 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); } - /* abort tag:24 _:8 from:24 + /* abort tag:24 _:8 proc:24 * * Return a number of values to a prompt handler. The values are - * expected in a frame pushed on at FROM. + * expected in a frame pushed on at PROC. */ - VM_DEFINE_OP (68, abort, "abort", OP2 (U8_U24, X8_U24)) + VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24)) #if 0 { scm_t_uint32 tag, from, nvalues; @@ -2534,7 +2342,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * A normal exit from the dynamic extent of an expression. Pop the top * entry off of the dynamic stack. */ - VM_DEFINE_OP (69, unwind, "unwind", OP1 (U8_X24)) + VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24)) { scm_dynstack_pop (¤t_thread->dynstack); NEXT (1); @@ -2546,7 +2354,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * allocated in a continguous range on the stack, starting from * FLUID-BASE. The values do not have this restriction. */ - VM_DEFINE_OP (70, push_fluid, "push-fluid", OP1 (U8_U12_U12)) + VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12)) { scm_t_uint32 fluid, value; @@ -2563,7 +2371,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Leave the dynamic extent of a with-fluids expression, restoring the * fluids to their previous values. */ - VM_DEFINE_OP (71, pop_fluid, "pop-fluid", OP1 (U8_X24)) + VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24)) { /* This function must not allocate. */ scm_dynstack_unwind_fluid (¤t_thread->dynstack, @@ -2575,7 +2383,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Reference the fluid in SRC, and place the value in DST. */ - VM_DEFINE_OP (72, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; size_t num; @@ -2608,7 +2416,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the value of the fluid in DST to the value in SRC. */ - VM_DEFINE_OP (73, fluid_set, "fluid-set", OP1 (U8_U12_U12)) + VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; size_t num; @@ -2641,7 +2449,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the length of the string in SRC in DST. */ - VM_DEFINE_OP (74, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) @@ -2658,7 +2466,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Fetch the character at position IDX in the string in SRC, and store * it in DST. */ - VM_DEFINE_OP (75, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (str, idx); @@ -2680,7 +2488,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Parse a string in SRC to a number, and store in DST. */ - VM_DEFINE_OP (76, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2696,7 +2504,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Parse a string in SRC to a symbol, and store in DST. */ - VM_DEFINE_OP (77, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; @@ -2710,7 +2518,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Make a keyword from the symbol in SRC, and store it in DST. */ - VM_DEFINE_OP (78, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); @@ -2729,7 +2537,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Cons CAR and CDR, and store the result in DST. */ - VM_DEFINE_OP (79, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); RETURN (scm_cons (x, y)); @@ -2739,7 +2547,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the car of SRC in DST. */ - VM_DEFINE_OP (80, car, "car", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "car"); @@ -2750,7 +2558,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the cdr of SRC in DST. */ - VM_DEFINE_OP (81, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "cdr"); @@ -2761,7 +2569,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the car of DST to SRC. */ - VM_DEFINE_OP (82, set_car, "set-car!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2777,7 +2585,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Set the cdr of DST to SRC. */ - VM_DEFINE_OP (83, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) { scm_t_uint16 a, b; SCM x, y; @@ -2800,7 +2608,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Add A to B, and place the result in DST. */ - VM_DEFINE_OP (84, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (+, scm_sum); } @@ -2809,7 +2617,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Add 1 to the value in SRC, and place the result in DST. */ - VM_DEFINE_OP (85, add1, "add1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2834,7 +2642,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Subtract B from A, and place the result in DST. */ - VM_DEFINE_OP (86, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) { BINARY_INTEGER_OP (-, scm_difference); } @@ -2843,7 +2651,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Subtract 1 from SRC, and place the result in DST. */ - VM_DEFINE_OP (87, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (x); @@ -2868,7 +2676,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Multiply A and B, and place the result in DST. */ - VM_DEFINE_OP (88, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2879,7 +2687,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Divide A by B, and place the result in DST. */ - VM_DEFINE_OP (89, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2890,7 +2698,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Divide A by B, and place the quotient in DST. */ - VM_DEFINE_OP (90, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2901,7 +2709,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Divide A by B, and place the remainder in DST. */ - VM_DEFINE_OP (91, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2912,7 +2720,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the modulo of A by B in DST. */ - VM_DEFINE_OP (92, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); SYNC_IP (); @@ -2923,7 +2731,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Shift A arithmetically by B bits, and place the result in DST. */ - VM_DEFINE_OP (93, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2959,7 +2767,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the bitwise AND of A and B into DST. */ - VM_DEFINE_OP (94, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2973,7 +2781,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the bitwise inclusive OR of A with B in DST. */ - VM_DEFINE_OP (95, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2987,7 +2795,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Place the bitwise exclusive OR of A with B in DST. */ - VM_DEFINE_OP (96, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -3000,7 +2808,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the length of the vector in SRC in DST. */ - VM_DEFINE_OP (97, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) @@ -3017,7 +2825,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Fetch the item at position IDX in the vector in SRC, and store it * in DST. */ - VM_DEFINE_OP (98, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -3038,7 +2846,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Fill DST with the item IDX elements into the vector at SRC. Useful * for building data types using vectors. */ - VM_DEFINE_OP (99, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM v; @@ -3057,7 +2865,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store SRC into the vector DST at index IDX. */ - VM_DEFINE_OP (100, vector_set, "vector-set", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; @@ -3092,7 +2900,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); @@ -3105,7 +2913,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * will be constructed with space for NFIELDS fields, which should * correspond to the field count of the VTABLE. */ - VM_DEFINE_OP (102, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, vtable, nfields; SCM ret; @@ -3124,7 +2932,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Fetch the item at slot IDX in the struct in SRC, and store it * in DST. */ - VM_DEFINE_OP (103, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) { ARGS2 (obj, pos); @@ -3158,7 +2966,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store SRC into the struct DST at slot IDX. */ - VM_DEFINE_OP (104, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM obj, pos, val; @@ -3199,7 +3007,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -3214,7 +3022,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an * index into the stack. */ - VM_DEFINE_OP (106, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); @@ -3228,7 +3036,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * Store SRC into slot IDX of the struct in DST. Unlike struct-set!, * IDX is an 8-bit immediate value, not an index into the stack. */ - VM_DEFINE_OP (107, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8)) { scm_t_uint8 dst, idx, src; SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); @@ -3249,7 +3057,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * from the instruction pointer, and store into DST. LEN is a byte * length. OFFSET is signed. */ - VM_DEFINE_OP (108, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) + VM_DEFINE_OP (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) { scm_t_uint8 dst, type, shape; scm_t_int32 offset; @@ -3269,7 +3077,7 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) * * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST. */ - VM_DEFINE_OP (109, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) + VM_DEFINE_OP (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST) { scm_t_uint16 dst, type, fill, bounds; SCM_UNPACK_RTL_12_12 (op, dst, type); @@ -3367,42 +3175,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ } while (0) - VM_DEFINE_OP (110, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (u8, u8, uint8, 1); - VM_DEFINE_OP (111, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (s8, s8, int8, 1); - VM_DEFINE_OP (112, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); - VM_DEFINE_OP (113, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); - VM_DEFINE_OP (114, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); #else BV_INT_REF (u32, uint32, 4); #endif - VM_DEFINE_OP (115, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); #else BV_INT_REF (s32, int32, 4); #endif - VM_DEFINE_OP (116, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (u64, uint64, 8); - VM_DEFINE_OP (117, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_INT_REF (s64, int64, 8); - VM_DEFINE_OP (118, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FLOAT_REF (f32, ieee_single, float, 4); - VM_DEFINE_OP (119, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) BV_FLOAT_REF (f64, ieee_double, double, 8); /* bv-u8-set! dst:8 idx:8 src:8 @@ -3506,42 +3314,42 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_) NEXT (1); \ } while (0) - VM_DEFINE_OP (120, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); - VM_DEFINE_OP (121, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); - VM_DEFINE_OP (122, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); - VM_DEFINE_OP (123, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); - VM_DEFINE_OP (124, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); #else BV_INT_SET (u32, uint32, 4); #endif - VM_DEFINE_OP (125, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); #else BV_INT_SET (s32, int32, 4); #endif - VM_DEFINE_OP (126, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (u64, uint64, 8); - VM_DEFINE_OP (127, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) BV_INT_SET (s64, int64, 8); - VM_DEFINE_OP (128, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) BV_FLOAT_SET (f32, ieee_single, float, 4); - VM_DEFINE_OP (129, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) BV_FLOAT_SET (f64, ieee_double, double, 8); END_DISPATCH_SWITCH; diff --git a/libguile/vm.c b/libguile/vm.c index e87420b61..ad41180f1 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -599,22 +599,15 @@ static SCM rtl_apply; static SCM rtl_values; static const scm_t_uint32 rtl_boot_continuation_code[] = { - SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0), SCM_PACK_RTL_24 (scm_rtl_op_halt, 0) }; -static scm_t_uint32* rtl_boot_multiple_value_continuation_code = - (scm_t_uint32 *) rtl_boot_continuation_code; - -static scm_t_uint32* rtl_boot_single_value_continuation_code = - (scm_t_uint32 *) rtl_boot_continuation_code + 1; - static const scm_t_uint32 rtl_apply_code[] = { SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set */ }; static const scm_t_uint32 rtl_values_code[] = { - SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r1 */ + SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */ }; diff --git a/module/Makefile.am b/module/Makefile.am index 495d228af..6d3b31f2d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -32,6 +32,9 @@ nobase_ccache_DATA += ice-9/eval.go EXTRA_DIST += ice-9/eval.scm ETAGS_ARGS += ice-9/eval.scm +VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go +$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h + ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm # We can compile these in any order, but it's fastest if we compile diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 1eea3c05d..2c46c3b69 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -410,7 +410,11 @@ later by the linker." (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) ((B1_U7_L24 a b label) (record-label-reference asm label) - (emit asm (pack-u1-u7-u24 (if a 1 0) b 0))))) + (emit asm (pack-u1-u7-u24 (if a 1 0) b 0))) + ((B1_X31 a) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) + ((B1_X7_U24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))))) (syntax-case x () ((_ name opcode word0 word* ...) @@ -675,12 +679,12 @@ returned instead." (cond (alternate (emit-br-if-nargs-ne asm nreq alternate) - (emit-reserve-locals asm nlocals)) + (emit-alloc-frame asm nlocals)) ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12))) (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) (else (emit-assert-nargs-ee asm nreq) - (emit-reserve-locals asm nlocals)))) + (emit-alloc-frame asm nlocals)))) (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) (if alternate @@ -693,7 +697,7 @@ returned instead." (emit-br-if-nargs-gt asm (+ nreq nopt) alternate)) (else (emit-assert-nargs-le asm (+ nreq nopt)))) - (emit-reserve-locals asm nlocals)) + (emit-alloc-frame asm nlocals)) (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? nlocals alternate) @@ -711,41 +715,27 @@ returned instead." (+ nreq nopt) ntotal kw-indices) - (emit-reserve-locals asm nlocals))) + (emit-alloc-frame asm nlocals))) (define-macro-assembler (label asm sym) (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm)))) -(define-macro-assembler (cache-current-module! asm tmp scope) +(define-macro-assembler (cache-current-module! asm module scope) (let ((mod-label (intern-module-cache-cell asm scope))) - (emit-current-module asm tmp) - (emit-static-set! asm tmp mod-label 0))) - -(define-macro-assembler (cached-toplevel-ref asm dst scope sym) - (let ((sym-label (intern-non-immediate asm sym)) - (mod-label (intern-module-cache-cell asm scope)) - (cell-label (intern-cache-cell asm scope sym))) - (emit-toplevel-ref asm dst cell-label mod-label sym-label))) + (emit-static-set! asm module mod-label 0))) -(define-macro-assembler (cached-toplevel-set! asm src scope sym) +(define-macro-assembler (cached-toplevel-box asm dst scope sym bound?) (let ((sym-label (intern-non-immediate asm sym)) (mod-label (intern-module-cache-cell asm scope)) (cell-label (intern-cache-cell asm scope sym))) - (emit-toplevel-set! asm src cell-label mod-label sym-label))) + (emit-toplevel-box asm dst cell-label mod-label sym-label bound?))) -(define-macro-assembler (cached-module-ref asm dst module-name public? sym) +(define-macro-assembler (cached-module-box asm dst module-name sym public? bound?) (let* ((sym-label (intern-non-immediate asm sym)) (key (cons public? module-name)) (mod-name-label (intern-constant asm key)) (cell-label (intern-cache-cell asm key sym))) - (emit-module-ref asm dst cell-label mod-name-label sym-label))) - -(define-macro-assembler (cached-module-set! asm src module-name public? sym) - (let* ((sym-label (intern-non-immediate asm sym)) - (key (cons public? module-name)) - (mod-name-label (intern-non-immediate asm key)) - (cell-label (intern-cache-cell asm key sym))) - (emit-module-set! asm src cell-label mod-name-label sym-label))) + (emit-module-box asm dst cell-label mod-name-label sym-label bound?))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 3b95f196b..b339b5cbe 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -145,6 +145,11 @@ #'((not (zero? (logand word #x1))) (logand (ash word -1) #x7f) (unpack-s24 (ash word -8)))) + ((B1_X31) + #'((not (zero? (logand word #x1))))) + ((B1_X7_U24) + #'((not (zero? (logand word #x1))) + (ash word -8))) (else (error "bad kind" type))))) @@ -244,12 +249,14 @@ address of that offset." addr))) (('resolve-module dst name public) (list "~a" (if (zero? public) "private" "public"))) - (((or 'toplevel-ref 'toplevel-set!) _ var-offset mod-offset sym-offset) - (list "`~A'" (dereference-scm sym-offset))) - (((or 'module-ref 'module-set!) _ var-offset mod-name-offset sym-offset) + (('toplevel-box _ var-offset mod-offset sym-offset bound?) + (list "`~A'~A" (dereference-scm sym-offset) + (if bound? "" " (maybe unbound)"))) + (('module-box _ var-offset mod-name-offset sym-offset bound?) (let ((mod-name (reference-scm mod-name-offset))) - (list "`(~A ~A ~A)'" (if (car mod-name) '@ '@@) (cdr mod-name) - (dereference-scm sym-offset)))) + (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name) + (dereference-scm sym-offset) + (if bound? "" " (maybe unbound)")))) (('load-typed-array dst type shape target len) (let ((addr (u32-offset->addr (+ offset target) context))) (list "~a bytes from #x~X" len addr))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index ce0a0c2c9..6f61f375f 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -92,7 +92,7 @@ (begin-standard-arity (x) 4 #f) (br fix-body) (label loop-head) - (br-if-= 2 1 out) + (br-if-= 2 1 #f out) (add 3 2 3) (add1 2 2) (br loop-head) @@ -144,12 +144,11 @@ (assemble-program '((begin-program call ((name . call))) - (begin-standard-arity (f) 2 #f) - (push-frame 2 1) + (begin-standard-arity (f) 7 #f) (mov 5 1) - (call 2) - (return 2) ;; MVRA from call - (return 2) ;; RA from call + (call 5 1) + (receive 2 5 7) + (return 2) (end-arity) (end-program))))) (call (lambda () 42)))) @@ -159,13 +158,12 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (begin-standard-arity (f) 3 #f) - (push-frame 2 2) + (begin-standard-arity (f) 7 #f) (mov 5 1) (load-constant 6 3) - (call 2) - (return 2) ;; MVRA from call - (return 2) ;; RA from call + (call 5 2) + (receive 2 5 7) + (return 2) (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -177,7 +175,8 @@ '((begin-program call ((name . call))) (begin-standard-arity (f) 2 #f) - (tail-call 0 1) + (mov 0 1) + (tail-call 1) (end-arity) (end-program))))) (call (lambda () 3)))) @@ -187,10 +186,10 @@ (assemble-program '((begin-program call-with-3 ((name . call-with-3))) - (begin-standard-arity (f) 3 #f) - (mov 2 1) ;; R1 <- R0 - (load-constant 1 3) ;; R0 <- 3 - (tail-call 1 2) + (begin-standard-arity (f) 2 #f) + (mov 0 1) ;; R0 <- R1 + (load-constant 1 3) ;; R1 <- 3 + (tail-call 2) (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -202,6 +201,7 @@ '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) (begin-standard-arity () 2 #f) + (current-module 1) (cache-current-module! 1 sqrt-scope) (load-static-procedure 1 sqrt-trampoline) (return 1) @@ -211,8 +211,9 @@ (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (cached-toplevel-ref 2 sqrt-scope sqrt) - (tail-call 1 2) + (cached-toplevel-box 2 sqrt-scope sqrt #t) + (box-ref 0 2) + (tail-call 2) (end-arity) (end-program))))) ((get-sqrt-trampoline) 25.0)))) @@ -227,6 +228,7 @@ '((begin-program make-top-incrementor ((name . make-top-incrementor))) (begin-standard-arity () 2 #f) + (current-module 1) (cache-current-module! 1 top-incrementor) (load-static-procedure 1 top-incrementor) (return 1) @@ -235,11 +237,12 @@ (begin-program top-incrementor ((name . top-incrementor))) - (begin-standard-arity () 2 #f) - (cached-toplevel-ref 1 top-incrementor *top-val*) - (add1 1 1) - (cached-toplevel-set! 1 top-incrementor *top-val*) - (return/values 1) + (begin-standard-arity () 3 #f) + (cached-toplevel-box 1 top-incrementor *top-val* #t) + (box-ref 2 1) + (add1 2 2) + (box-set! 1 2) + (return-values 0) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -260,8 +263,9 @@ (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (cached-module-ref 2 (guile) #t sqrt) - (tail-call 1 2) + (cached-module-box 2 (guile) sqrt #t #t) + (box-ref 0 2) + (tail-call 2) (end-arity) (end-program))))) ((get-sqrt-trampoline) 25.0)))) @@ -281,11 +285,12 @@ (begin-program top-incrementor ((name . top-incrementor))) - (begin-standard-arity () 2 #f) - (cached-module-ref 1 (tests rtl) #f *top-val*) - (add1 1 1) - (cached-module-set! 1 (tests rtl) #f *top-val*) - (return 1) + (begin-standard-arity () 3 #f) + (cached-module-box 1 (tests rtl) *top-val* #f #t) + (box-ref 2 1) + (add1 2 2) + (box-set! 1 2) + (return 2) (end-arity) (end-program))))) ((make-top-incrementor)) |