/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of * the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA * 02110-1301 USA */ /* This file is included in vm.c multiple times */ #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE) #define VM_USE_HOOKS 0 /* Various hooks */ #define VM_CHECK_OBJECT 0 /* Check object table */ #define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */ #define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */ #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE) #define VM_USE_HOOKS 1 #define VM_CHECK_OBJECT 0 #define VM_CHECK_FREE_VARIABLES 0 #define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */ #else #error unknown debug engine VM_ENGINE #endif /* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ] Some compilers underestimate the use of the local variables representing the abstract machine registers, and don't put them in hardware registers, which slows down the interpreter considerably. For GCC, I have hand-assigned hardware registers for several architectures. */ #ifdef __GNUC__ #ifdef __mips__ #define IP_REG asm("$16") #define SP_REG asm("$17") #define FP_REG asm("$18") #endif #ifdef __sparc__ #define IP_REG asm("%l0") #define SP_REG asm("%l1") #define FP_REG asm("%l2") #endif #ifdef __alpha__ #ifdef __CRAY__ #define IP_REG asm("r9") #define SP_REG asm("r10") #define FP_REG asm("r11") #else #define IP_REG asm("$9") #define SP_REG asm("$10") #define FP_REG asm("$11") #endif #endif #ifdef __i386__ /* too few registers! because of register allocation errors with various gcs, just punt on explicit assignments on i386, hoping that the "register" declaration will be sufficient. */ #elif defined __x86_64__ /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works well. Tell it to keep the jump table in a r12, which is callee-saved. */ #define JT_REG asm ("r12") #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define IP_REG asm("26") #define SP_REG asm("27") #define FP_REG asm("28") #endif #ifdef __hppa__ #define IP_REG asm("%r18") #define SP_REG asm("%r17") #define FP_REG asm("%r16") #endif #ifdef __mc68000__ #define IP_REG asm("a5") #define SP_REG asm("a4") #define FP_REG #endif #ifdef __arm__ #define IP_REG asm("r9") #define SP_REG asm("r8") #define FP_REG asm("r7") #endif #endif #ifndef IP_REG #define IP_REG #endif #ifndef SP_REG #define SP_REG #endif #ifndef FP_REG #define FP_REG #endif #ifndef JT_REG #define JT_REG #endif /* * Cache/Sync */ #define VM_ASSERT(condition, handler) \ do { if (SCM_UNLIKELY (!(condition))) { SYNC_ALL(); handler; } } while (0) #ifdef VM_ENABLE_ASSERTIONS # define ASSERT(condition) VM_ASSERT (condition, abort()) #else # define ASSERT(condition) #endif /* Cache the VM's instruction, stack, and frame pointer in local variables. */ #define CACHE_REGISTER() \ { \ ip = vp->ip; \ sp = vp->sp; \ fp = vp->fp; \ } /* Update the registers in VP, a pointer to the current VM. This must be done at least before any GC invocation so that `vp->sp' is up-to-date and the whole stack gets marked. */ #define SYNC_REGISTER() \ { \ vp->ip = ip; \ vp->sp = sp; \ vp->fp = fp; \ } /* FIXME */ #define ASSERT_VARIABLE(x) \ VM_ASSERT (SCM_VARIABLEP (x), abort()) #define ASSERT_BOUND_VARIABLE(x) \ VM_ASSERT (SCM_VARIABLEP (x) \ && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \ abort()) #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) #define ASSERT_ALIGNED_PROCEDURE() \ do { if ((scm_t_bits)bp % 8) abort (); } while (0) #define ASSERT_BOUND(x) \ VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort()) #else #define CHECK_IP() #define ASSERT_ALIGNED_PROCEDURE() #define ASSERT_BOUND(x) #endif #if VM_CHECK_OBJECT #define SET_OBJECT_COUNT(n) object_count = n #else #define SET_OBJECT_COUNT(n) /* nop */ #endif /* Cache the object table and free variables. */ #define CACHE_PROGRAM() \ { \ if (bp != SCM_PROGRAM_DATA (program)) { \ bp = SCM_PROGRAM_DATA (program); \ ASSERT_ALIGNED_PROCEDURE (); \ if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \ objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \ SET_OBJECT_COUNT (SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program))); \ } else { \ objects = NULL; \ SET_OBJECT_COUNT (0); \ } \ } \ } #define SYNC_BEFORE_GC() \ { \ SYNC_REGISTER (); \ } #define SYNC_ALL() \ { \ SYNC_REGISTER (); \ } /* * Error check */ /* Accesses to a program's object table. */ #if VM_CHECK_OBJECT #define CHECK_OBJECT(_num) \ VM_ASSERT ((_num) < object_count, vm_error_object ()) #else #define CHECK_OBJECT(_num) #endif #if VM_CHECK_FREE_VARIABLES #define CHECK_FREE_VARIABLE(_num) \ VM_ASSERT ((_num) < SCM_PROGRAM_NUM_FREE_VARIABLES (program), \ vm_error_free_variable ()) #else #define CHECK_FREE_VARIABLE(_num) #endif /* * Hooks */ #undef RUN_HOOK #undef RUN_HOOK1 #if VM_USE_HOOKS #define RUN_HOOK(h) \ { \ if (SCM_UNLIKELY (vp->trace_level > 0)) \ { \ SYNC_REGISTER (); \ vm_dispatch_hook (vm, h); \ } \ } #define RUN_HOOK1(h, x) \ { \ if (SCM_UNLIKELY (vp->trace_level > 0)) \ { \ PUSH (x); \ SYNC_REGISTER (); \ vm_dispatch_hook (vm, h); \ DROP(); \ } \ } #else #define RUN_HOOK(h) #define RUN_HOOK1(h, x) #endif #define APPLY_HOOK() \ RUN_HOOK (SCM_VM_APPLY_HOOK) #define PUSH_CONTINUATION_HOOK() \ RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK) #define POP_CONTINUATION_HOOK(n) \ RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n)) #define NEXT_HOOK() \ RUN_HOOK (SCM_VM_NEXT_HOOK) #define ABORT_CONTINUATION_HOOK() \ RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK) #define RESTORE_CONTINUATION_HOOK() \ RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK) #define VM_HANDLE_INTERRUPTS \ SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ()) /* * Stack operation */ #ifdef VM_ENABLE_STACK_NULLING # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]); # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1) # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; } /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for that continuation doesn't have a chance to run. It's not important on a semantic level, but it does mess up our stack nulling -- so this macro is to fix that. */ # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp); #else # define CHECK_STACK_LEAKN(_n) # define CHECK_STACK_LEAK() # define NULLSTACK(_n) # define NULLSTACK_FOR_NONLOCAL_EXIT() #endif /* For this check, we don't use VM_ASSERT, because that leads to a per-site SYNC_ALL, which is too much code growth. The real problem of course is having to check for overflow all the time... */ #define CHECK_OVERFLOW() \ do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0) #ifdef VM_CHECK_UNDERFLOW #define PRE_CHECK_UNDERFLOW(N) \ VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ()) #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0) #else #define PRE_CHECK_UNDERFLOW(N) /* nop */ #define CHECK_UNDERFLOW() /* nop */ #endif #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) #define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0) #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0) #define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0) #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0) #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0) /* A fast CONS. This has to be fast since its used, for instance, by POP_LIST when fetching a function's argument list. Note: `scm_cell' is an inlined function in Guile 1.7. Unfortunately, it calls `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the heap. XXX */ #define CONS(x,y,z) \ { \ SYNC_BEFORE_GC (); \ x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \ } /* Pop the N objects on top of the stack and push a list that contains them. */ #define POP_LIST(n) \ do \ { \ int i; \ SCM l = SCM_EOL, x; \ for (i = n; i; i--) \ { \ POP (x); \ CONS (l, x, l); \ } \ PUSH (l); \ } while (0) /* The opposite: push all of the elements in L onto the list. */ #define PUSH_LIST(l, NILP) \ do \ { \ for (; scm_is_pair (l); l = SCM_CDR (l)) \ PUSH (SCM_CAR (l)); \ VM_ASSERT (NILP (l), vm_error_improper_list (l)); \ } while (0) #define POP_LIST_MARK() \ do { \ SCM o; \ SCM l = SCM_EOL; \ POP (o); \ while (!SCM_UNBNDP (o)) \ { \ CONS (l, o, l); \ POP (o); \ } \ PUSH (l); \ } while (0) #define POP_CONS_MARK() \ do { \ SCM o, l; \ POP (l); \ POP (o); \ while (!SCM_UNBNDP (o)) \ { \ CONS (l, o, l); \ POP (o); \ } \ PUSH (l); \ } while (0) /* * Instruction operation */ #define FETCH() (*ip++) #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0) #undef NEXT_JUMP #ifdef HAVE_LABELS_AS_VALUES # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK] #else # define NEXT_JUMP() goto vm_start #endif #define NEXT \ { \ NEXT_HOOK (); \ CHECK_STACK_LEAK (); \ NEXT_JUMP (); \ } /* See frames.h for the layout of stack frames */ /* When this is called, bp points to the new program data, and the arguments are already on the stack */ #define DROP_FRAME() \ { \ sp -= 3; \ NULLSTACK (3); \ CHECK_UNDERFLOW (); \ } static SCM VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) { /* VM registers */ register scm_t_uint8 *ip IP_REG; /* instruction pointer */ register SCM *sp SP_REG; /* stack pointer */ register SCM *fp FP_REG; /* frame pointer */ struct scm_vm *vp = SCM_VM_DATA (vm); /* Cache variables */ struct scm_objcode *bp = NULL; /* program base pointer */ SCM *objects = NULL; /* constant objects */ #if VM_CHECK_OBJECT size_t object_count = 0; /* length of OBJECTS */ #endif SCM *stack_limit = vp->stack_limit; /* stack limit address */ scm_i_thread *current_thread = SCM_I_CURRENT_THREAD; /* Internal variables */ int nvalues = 0; scm_i_jmp_buf registers; /* used for prompts */ #ifdef HAVE_LABELS_AS_VALUES static const void **jump_table_pointer = NULL; #endif #ifdef HAVE_LABELS_AS_VALUES register const void **jump_table JT_REG; if (SCM_UNLIKELY (!jump_table_pointer)) { int i; jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) jump_table_pointer[i] = &&vm_error_bad_instruction; #define VM_INSTRUCTION_TO_LABEL 1 #define jump_table jump_table_pointer #include #include #include #include #undef jump_table #undef VM_INSTRUCTION_TO_LABEL } /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one load instruction at each instruction dispatch. */ jump_table = jump_table_pointer; #endif if (SCM_I_SETJMP (registers)) { /* Non-local return. Cache the VM registers back from the vp, and go to the handler. Note, at this point, we must assume that any variable local to vm_engine that can be assigned *has* been assigned. So we need to pull all our state back from the ip/fp/sp. */ CACHE_REGISTER (); program = SCM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); /* The stack contains the values returned to this continuation, along with a number-of-values marker -- like an MV return. */ ABORT_CONTINUATION_HOOK (); NEXT; } /* Initialization */ { SCM prog = program; /* Boot program */ program = vm_make_boot_program (nargs); /* Initial frame */ CACHE_REGISTER (); PUSH (SCM_PACK (fp)); /* dynamic link */ PUSH (SCM_PACK (0)); /* mvra */ PUSH (SCM_PACK (ip)); /* ra */ CACHE_PROGRAM (); PUSH (program); fp = sp + 1; ip = SCM_C_OBJCODE_BASE (bp); /* MV-call frame, function & arguments */ PUSH (SCM_PACK (0)); /* dynamic link */ PUSH (SCM_PACK (0)); /* mvra */ PUSH (SCM_PACK (0)); /* ra */ PUSH (prog); VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs)); while (nargs--) PUSH (*argv++); } /* Let's go! */ NEXT; #ifndef HAVE_LABELS_AS_VALUES vm_start: switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) { #endif #include "vm-expand.h" #include "vm-i-system.c" #include "vm-i-scheme.c" #include "vm-i-loader.c" #ifndef HAVE_LABELS_AS_VALUES default: goto vm_error_bad_instruction; } #endif abort (); /* never reached */ vm_error_bad_instruction: vm_error_bad_instruction (ip[-1]); abort (); /* never reached */ handle_overflow: SYNC_ALL (); vm_error_stack_overflow (vp); abort (); /* never reached */ } #if 0 #define SCM_FRAME_RETURN_LOC(fp) \ ((scm_t_uint32) SCM_FRAME_MV_RETURN_ADDRESS (fp)) #define SCM_FRAME_SET_RETURN_LOC(fp, loc) \ SCM_SET_FRAME_MV_RETURN_ADDRESS (fp, (void*)loc) #define UNUSED_RETURN_LOC 0 /* return_loc:24 nreq:7 rest:1 */ #define PACK_MV_RETURN_LOC(reg, nreq, has_rest) (((reg) << 8) | (nreq << 1) | has_rest) /* Interestingly, a truncating MV return loc with 0 required args and no rest arg is the same as ignoring the return value: the bottom 8 bits are 0. */ #define PACK_RETURN_LOC(reg) PACK_MV_RETURN_LOC (reg, 1, 0) #undef NEXT #undef CHECK_OVERFLOW #undef SYNC_BEFORE_GC #undef SYNC_ALL /* The VM has two state bits: the instruction pointer (IP) and the frame pointer (FP). We cache both of these in machine registers, local to the VM. Since the FP changes infrequently, relative to the IP, we keep vp->fp in sync with the local FP. This would be a big lose for the IP, though, so instead of updating vp->ip all the time, we call SYNC_IP whenever we would need to know the IP of the top frame. In practice, we need to SYNC_IP whenever we call out of the VM to a function that would like to walk the stack, perhaps as the result of an exception. */ #define SYNC_IP() \ vp->ip = ip #define SYNC_REGISTER() \ SYNC_IP() #define SYNC_BEFORE_GC() /* Only FP needed to trace GC */ #define SYNC_ALL() \ /* FP already saved */ SYNC_IP() #define CHECK_OVERFLOW(n) \ VM_ASSERT (fp + n < stack_limit, vm_error_stack_overflow (vp)) #ifdef HAVE_LABELS_AS_VALUES # define BEGIN_DISPATCH_SWITCH /* */ # define END_DISPATCH_SWITCH /* */ # define NEXT(n) \ do \ { \ ip += n; \ NEXT_HOOK (); \ op = *ip; \ goto *jump_table[op & 0xff]; \ } \ while (0) # define VM_DEFINE_OP(opcode, tag, name) \ op_##tag: #else # define BEGIN_DISPATCH_SWITCH \ vm_start: \ NEXT_HOOK (); \ op = *ip; \ switch (op & 0xff) \ { # define END_DISPATCH_SWITCH \ default: \ goto vm_error_bad_instruction; \ } # define NEXT(n) \ do \ { \ ip += n; \ goto vm_start; \ } \ while (0) # define VM_DEFINE_OP(opcode, tag, name) \ case opcode: #endif static SCM scm_i_paste(rtl_,VM_NAME) (SCM vm, SCM program, SCM *argv, int nargs_) { /* Instruction pointer: A pointer to the opcode that is currently running. */ register scm_t_uint32 *ip IP_REG; /* Frame pointer: A pointer into the stack, off of which we index arguments and local variables. Pushed at function calls, popped on returns. */ register SCM *fp FP_REG; /* Current opcode: A cache of *ip. */ register scm_t_uint32 op; /* Number of arguments passed to a function. When we get native compilation, this will be part of a the calling convention. */ scm_t_uint32 nargs = 0; /* Cached variables. */ struct scm_vm *vp = SCM_VM_DATA (vm); SCM *stack_limit = vp->stack_limit; /* stack limit address */ scm_i_thread *current_thread = SCM_I_CURRENT_THREAD; scm_i_jmp_buf registers; /* used for prompts */ #ifdef HAVE_LABELS_AS_VALUES static const void **jump_table_pointer = NULL; register const void **jump_table JT_REG; if (SCM_UNLIKELY (!jump_table_pointer)) { int i; jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) jump_table_pointer[i] = &&vm_error_bad_instruction; #define INIT(opcode, tag, name) jump_table_pointer[opcode] = &&op_##tag; FOR_EACH_VM_OPERATION(INIT_JUMP_TABLE); #undef INIT } /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one load instruction at each instruction dispatch. */ jump_table = jump_table_pointer; #endif if (SCM_I_SETJMP (registers)) { /* Non-local return. Cache the VM registers back from the vp, and go to the handler. Note, at this point, we must assume that any variable local to vm_engine that can be assigned *has* been assigned. So we need to pull all our state back from the ip/fp/sp. */ CACHE_REGISTER (); ABORT_CONTINUATION_HOOK (); NEXT (0); } /* Load previous VM registers. */ CACHE_REGISTER (); VM_HANDLE_INTERRUPTS; /* Initialization */ { SCM *base; /* Check that we have enough space: 4 words for the boot continuation, and 4 + nargs for the procedure application. */ base = sp; nargs = nargs_; CHECK_OVERFLOW (4 + 4 + nargs); /* Initial frame, saving previous fp and ip, with the boot continuation. */ base[0] = SCM_PACK (fp); /* dynamic link */ base[1] = SCM_PACK (UNUSED_RETURN_LOC); /* the boot continuation does not return to scheme */ base[2] = SCM_PACK (ip); /* ra */ base[3] = rtl_boot_continuation; fp = &base[4]; ip = RTL_PROGRAM_ENTRY (rtl_boot_continuation); /* MV-call frame, function & arguments */ base[4] = SCM_PACK (fp); /* dynamic link */ base[5] = SCM_PACK (PACK_MV_RETURN_LOC (0, 0, 1)); /* collect all return values into a list, store in local 0 */ base[6] = SCM_PACK (ip); /* ra */ base[7] = program; fp = &base[8]; { int i; for (i = 0; i < nargs; i++) fp[i] = argv[i]; } } apply: while (!RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))) { SCM proc = SCM_FRAME_PROGRAM (fp); if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) { fp[-1] = SCM_STRUCT_PROCEDURE (proc); continue; } if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) { scm_t_uint32 n = nargs; /* Shuffle args up, place smob in local 0. */ while (n--) LOCAL_SET (n + 1, LOCAL_REF (n)); LOCAL_SET (0, proc); nargs++; fp[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline; continue; } SYNC_IP(); vm_error_wrong_type_apply (proc); } /* Let's go! */ ip = RTL_PROGRAM_ENTRY (SCM_FRAME_PROGRAM (fp)); NEXT (0); BEGIN_DISPATCH_SWITCH; /* * Basic operations */ #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o /* halt src:24 * * Bring the VM to a halt, returning the single value from register * SRC. */ VM_DEFINE_OP (0, halt, "halt") { scm_t_uint32 src; SCM ret; SCM_UNPACK_RTL_24 (op, src); ret = LOCAL_REF (src); /* Restore registers */ vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; /* Setting the ip here doesn't actually affect control flow, as the calling code will restore its own registers, but it does help when walking the stack */ vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); return ret; } /* halt/values src:24 * * Bring the VM to a halt, returning the values collected in the list in * SRC. */ VM_DEFINE_OP (1, halt_values, "halt/values") { scm_t_uint32 src; SCM ret; SCM_UNPACK_RTL_24 (op, src); ret = scm_values (LOCAL_REF (src)); /* Restore registers */ vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; /* Setting the ip here doesn't actually affect control flow, as the calling code will restore its own registers, but it does help when walking the stack */ vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); return ret; } /* mov dst:12 src:12 * * Copy a value from one local slot to another. */ VM_DEFINE_OP (2, mov, "mov") { scm_t_uint16 dst; scm_t_uint16 src; SCM_UNPACK_RTL_12_12 (op, dst, src); LOCAL_SET (dst, LOCAL_REF (src)); NEXT (1); } /* long-mov dst:24 _:8 src:24 * * Copy a value from one local slot to another. */ VM_DEFINE_OP (3, long_mov, "long-mov") { scm_t_uint32 dst; scm_t_uint32 src; SCM_UNPACK_RTL_24 (op, dst); SCM_UNPACK_RTL_24 (ip[1], src); LOCAL_SET (dst, LOCAL_REF (src)); NEXT (2); } /* make-short-immediate dst:8 low-bits:16 * * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ VM_DEFINE_OP (4, make_short_immediate, "make-short-immediate") { scm_t_uint8 dst; scm_t_bits val; SCM_UNPACK_RTL_8_16 (op, dst, val); LOCAL_SET (dst, SCM_PACK (val)); NEXT (1); } /* make-long-immediate dst:24 low-bits:32 * * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ VM_DEFINE_OP (5, make_long_immediate, "make-long-immediate") { scm_t_uint8 dst; scm_t_bits val; SCM_UNPACK_RTL_24 (op, dst); val = ip[1]; LOCAL_SET (dst, SCM_PACK (val)); NEXT (2); } /* make-long-long-immediate dst:24 high-bits:32 low-bits:32 * * Make an immediate with HIGH-BITS and LOW-BITS. */ VM_DEFINE_OP (6, make_long_long_immediate, "make-long-long-immediate") { scm_t_uint8 dst; scm_t_bits val; SCM_UNPACK_RTL_24 (op, dst); val = (ip[1] << 32) | ip[2]; LOCAL_SET (dst, SCM_PACK (val)); NEXT (3); } /* For the variable operations, we _must_ obviously avoid function calls to `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do nothing more than the corresponding macros. */ #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) #define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (SCM_FRAME_PROGRAM (fp), i) /* ref */ /* make-non-immediate dst:24 offset:32 * * Load a pointer to statically allocated memory into DST. The * object's memory is will be found OFFSET 32-bit words away from the * current instruction pointer. OFFSET is a signed value. The * intention here is that the compiler would produce an object file * containing the words of a non-immediate object, and this * instruction creates a pointer to that memory, effectively * resurrecting that object. * * Whether the object is mutable or immutable depends on where it was * allocated by the compiler, and loaded by the loader. */ VM_DEFINE_OP (7, make_non_immediate, "make-non-immediate") { scm_t_uint32 dst; scm_t_int32 offset; scm_t_uint32* loc; scm_t_bits unpacked; SCM_UNPACK_RTL_24 (op, dst); offset = ip[1]; loc = ip + offset; unpacked = loc; VM_ASSERT (!(unpacked & 0x7), abort()); LOCAL_SET (dst, SCM_PACK (unpacked)); NEXT (2); } /* static-ref dst:24 offset:32 * * Load a SCM value into DST. The SCM value will be fetched from * memory, OFFSET 32-bit words away from the current instruction * pointer. OFFSET is a signed value. * * The intention is for this instruction to be used to load constants * that the compiler is unable to statically allocate, like symbols. * These values would be initialized when the object file loads. */ VM_DEFINE_OP (8, static_ref, "static-ref") { scm_t_uint32 dst; scm_t_int32 offset; scm_t_uint32* loc; scm_t_uintptr loc_bits; SCM_UNPACK_RTL_24 (op, dst); offset = ip[1]; loc = ip + offset; loc_bits = loc; VM_ASSERT (!(loc_bits & (alignof_type (SCM) - 1)), abort()); LOCAL_SET (dst, *((SCM *) loc_bits)); NEXT (2); } /* static-set! src:24 offset:32 * * Store a SCM value into memory, OFFSET 32-bit words away from the * current instruction pointer. OFFSET is a signed value. */ VM_DEFINE_OP (9, static_set, "static-set!") { scm_t_uint32 src; scm_t_int32 offset; scm_t_uint32* loc; scm_t_uintptr loc_bits; SCM_UNPACK_RTL_24 (op, src); offset = ip[1]; loc = ip + offset; loc_bits = loc; VM_ASSERT (!(loc_bits & (alignof_type (SCM) - 1)), abort()); *((SCM *) loc_bits) = LOCAL_REF (src); NEXT (2); } /* initialize-scm src:24 offset:32 * * Store a SCM value into DST. The SCM value will be fetched from * memory, OFFSET 32-bit words away from the current instruction * pointer. OFFSET is a signed value. */ VM_DEFINE_OP (10, load_scm, "load-scm") { scm_t_uint32 dst; scm_t_int32 offset; scm_t_uint32* loc; scm_t_uintptr loc_bits; SCM_UNPACK_RTL_24 (op, dst); offset = ip[1]; loc = ip + offset; loc_bits = loc; VM_ASSERT (!(loc_bits & (alignof_type (SCM) - 1)), abort()); LOCAL_SET (dst, *((SCM *) loc_bits)); NEXT (2); } /* box-ref dst:12 src:12 * * Unpack the variable at SRC into DST, asserting that the variable is * actually bound. */ VM_DEFINE_OP (11, box_ref, "box-ref") { 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); } LOCAL_SET (dst, VARIABLE_REF (var)); NEXT (1); } /* toplevel-ref dst:8 src:8 idx:8 * * Retrieve the item IDX elements into the vector at SRC. If it is a * variable, unbox it and put the result in DST. Otherwise it is a * symbol: look up the corresponding variable, update the vector, and * unbox it into DST. */ VM_DEFINE_OP (12, toplevel_ref, "toplevel-ref") { scm_t_uint8 dst, src, idx; SCM vect; SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); what = SCM_SIMPLE_VECTOR_REF (LOCAL_REF (src), idx); if (SCM_UNLIKELY (!SCM_VARIABLEP (what))) { SYNC_IP (); resolved = resolve_variable (what, scm_program_module (SCM_FRAME_PROGRAM (fp))); VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (SCM_FRAME_PROGRAM (fp), what)); what = resolved; SCM_SIMPLE_VECTOR_SET (LOCAL_REF (src), idx, what); OBJECT_SET (objnum, what); } LOCAL_SET (dst, VARIABLE_REF (what)); NEXT (1); } /* box-set! dst:12 src:12 * * Set the contents of the variable at DST to SET. */ VM_DEFINE_OP (13, box_set, "box-set!") { scm_t_uint16 dst, src; SCM var; SCM_UNPACK_RTL_12_12 (op, dst, src); var = LOCAL_REF (dst); VM_ASSERT (SCM_VARIABLEP (var), abort ()); VARIABLE_SET (var, LOCAL_REF (src)); NEXT (1); } /* toplevel-set! dst:8 idx:8 src:8 * * Retrieve the item IDX elements into the vector at DST. If it is not * a variable, it is a symbol: look up the corresponding variable and * update the vector. Set the contents of the variable to SRC. */ VM_DEFINE_OP (14, toplevel_set, "toplevel-set!") { scm_t_uint8 dst, idx, src; SCM vect; SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); what = SCM_SIMPLE_VECTOR_REF (LOCAL_REF (dst), idx); if (SCM_UNLIKELY (!SCM_VARIABLEP (what))) { SYNC_IP (); resolved = resolve_variable (what, scm_program_module (SCM_FRAME_PROGRAM (fp))); what = resolved; SCM_SIMPLE_VECTOR_SET (LOCAL_REF (dst), idx, what); OBJECT_SET (objnum, what); } VARIABLE_SET (what, LOCAL_REF (src)); NEXT (1); } /* br offset:24 * * Add OFFSET, a signed 24-bit number, to the current instruction * pointer. */ VM_DEFINE_OP (15, br, "br") { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ NEXT (offset); } #define BR_UNARY(x, exp) \ scm_t_uint32 test; \ SCM x; \ SCM_UNPACK_RTL_24 (op, test); \ x = LOCAL_REF (test); \ if ((ip[1] & 0x1) ? !(exp) : (exp)) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ NEXT (offset); \ } \ NEXT (2) /* br-if-true test:24 invert:1 _:7 offset:24 * * 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 (16, br_if_true, "br-if-true") { BR_UNARY (x, scm_is_true (x)); } /* br-if-null test:24 invert:1 _:7 offset:24 * * 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 (17, br_if_null, "br-if-null") { BR_UNARY (x, scm_is_null (x)); } /* br-if-nil test:24 invert:1 _:7 offset:24 * * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ VM_DEFINE_OP (18, br_if_nil, "br-if-nil") { BR_UNARY (x, scm_is_lisp_false (x)); } /* br-if-pair test:24 invert:1 _:7 offset:24 * * If the value in TEST is a pair, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ VM_DEFINE_OP (19, br_if_pair, "br-if-pair") { BR_UNARY (x, scm_is_pair (x)); } /* br-if-struct test:24 invert:1 _:7 offset:24 * * If the value in TEST is a struct, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ VM_DEFINE_OP (20, br_if_struct, "br-if-struct") { BR_UNARY (x, SCM_STRUCTP (x)); } /* br-if-char test:24 invert:1 _:7 offset:24 * * If the value in TEST is a char, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ VM_DEFINE_OP (21, br_if_char, "br-if-char") { BR_UNARY (x, SCM_CHARP (x)); } /* br-if-tc7 test:24 invert:1 tc7:7 offset:24 * * 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 (22, br_if_tc7, "br-if-tc7") { BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f)); } #define BR_BINARY(x, y, exp) \ scm_t_uint16 a, b; \ SCM x, y; \ SCM_UNPACK_RTL_12_12 (op, a, b); \ x = LOCAL_REF (a); \ y = LOCAL_REF (b); \ if ((ip[1] & 0x1) ? !(exp) : (exp)) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ NEXT (offset); \ } \ NEXT (2) /* br-if-eq a:12 b:12 invert:1 _:7 offset:24 * * 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 (23, br_if_eq, "br-if-eq") { BR_BINARY (x, y, scm_is_eq (x, y)); } /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24 * * 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 (24, br_if_eqv, "br-if-eqv") { BR_BINARY (x, y, scm_is_eq (x, y) || (SCM_NIMP (x) && SCM_NIMP (y) && scm_is_true (scm_eqv_p (x, y)))); } /* 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 (25, br_if_equal, "br-if-equal") { BR_BINARY (x, y, scm_is_eq (x, y) || (SCM_NIMP (x) && SCM_NIMP (y) && scm_is_true (scm_equal_p (x, y)))); } #undef REL #define REL(crel,srel) \ { \ scm_t_uint16 a, b; \ SCM x, y; \ SCM_UNPACK_RTL_12_12 (op, a, b); \ x = LOCAL_REF (a); \ y = LOCAL_REF (b); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ { \ scm_t_signed_bits x_bits = SCM_UNPACK (x); \ scm_t_signed_bits y_bits = SCM_UNPACK (y); \ if (x_bits crel y_bits) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ NEXT (offset); \ } \ NEXT (2); \ } \ else \ { \ SYNC_IP (); \ if (scm_is_true (srel (x, y))) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ NEXT (offset); \ } \ NEXT (2); \ } \ } /* 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 (26, br_if_ee, "br-if-=") { REL (==, scm_num_eq_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 (27, br_if_lt, "br-if-<") { REL (<, scm_less_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 (28, br_if_le, "br-if-<=") { REL (<=, 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 (29, br_if_gt, "br-if->") { REL (>, 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 (30, br_if_ge, "br-if->=") { REL (>=, scm_geq_p); } /* * Subprogram call */ #define BR_NARGS(rel) \ scm_t_uint16 expected; \ SCM_UNPACK_RTL_24 (op, expected); \ if (nargs rel expected) \ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ NEXT (offset); \ } \ NEXT (2) /* br-if-nargs-ne expected:24 _:8 offset:24 * br-if-nargs-lt expected:24 _:8 offset:24 * br-if-nargs-gt expected:24 _:8 offset:24 * * If the number of actual arguments is not equal, less than, or greater * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to * the current instruction pointer. */ VM_DEFINE_OP (31, br_if_nargs_ne, "br-if-nargs-ne") { BR_NARGS (!=); } VM_DEFINE_OP (32, br_if_nargs_lt, "br-if-nargs-lt") { BR_NARGS (<); } VM_DEFINE_OP (33, br_if_nargs_gt, "br-if-nargs-gt") { BR_NARGS (>); } /* assert-nargs-ee expected:24 * assert-nargs-ge expected:24 * * If the number of actual arguments is not == or >= to EXPECTED, * respectively, signal an error. */ VM_DEFINE_OP (34, assert_nargs_ee, "assert-nargs-ee") { scm_t_uint32 expected; SCM_UNPACK_RTL_24 (op, expected); VM_ASSERT (nargs == expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } VM_DEFINE_OP (35, assert_nargs_ge, "assert-nargs-ge") { scm_t_uint32 expected; SCM_UNPACK_RTL_24 (op, expected); VM_ASSERT (nargs >= expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); NEXT (1); } /* reserve-locals 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. */ VM_DEFINE_OP (36, reserve_locals, "reserve-locals") { scm_t_uint32 nlocals; SCM_UNPACK_RTL_24 (op, nlocals); // FIXME: extend the stack! VM_ASSERT (fp + nlocals > stack_limit, abort()); while (nlocals-- > nargs) LOCAL_SET (nlocals, SCM_UNDEFINED); 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 (37, assert_nargs_ee_locals, "assert-nargs-ee/locals") { scm_t_uint16 expected, locals; SCM_UNPACK_RTL_12 (op, expected, locals); VM_ASSERT (nargs == expected, vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp))); // FIXME: extend the stack! VM_ASSERT (fp + expected + nlocals > stack_limit, abort()); while (nlocals--) LOCAL_SET (expected + nlocals, SCM_UNDEFINED); NEXT (1); } /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24 * _:8 ntotal:24 kw-offset:32 * * Find the last positional argument, and shuffle all the rest above * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then * load the constant at KW-OFFSET words from the current IP, and use it * to bind keyword arguments. If HAS-REST, collect all shuffled * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear * the arguments that we shuffled up. * * A macro-mega-instruction. */ VM_DEFINE_OP (38, bind_kwargs, "bind-kwargs") { scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n; scm_t_int32 kw_offset; scm_t_bits kw_bits; SCM kw; char allow_other_keys, has_rest; SCM_RTL_UNPACK_24 (op, nreq); allow_other_keys = ip[1] & 0x1; has_rest = ip[1] & 0x2; SCM_RTL_UNPACK_24 (ip[1], nreq_and_opt); SCM_RTL_UNPACK_24 (ip[2], ntotal); kw_offset = ip[3]; kw_bits = ip + kw_offset; VM_ASSERT (!(kw_bits & 0x7), abort()); kw = SCM_PACK (kw_bits); /* look in optionals for first keyword or last positional */ /* starting after the last required positional arg */ npositional = nreq; while (/* while we have args */ npositional < nargs /* and we still have positionals to fill */ && npositional < nreq_and_opt /* and we haven't reached a keyword yet */ && !scm_is_keyword (LOCAL_REF (npositional))) /* bind this optional arg (by leaving it in place) */ npositional++; nkw = nargs - npositional; /* shuffle non-positional arguments above ntotal */ /* FIXME check overflow */ n = nkw; while (n--) LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n)); /* and fill optionals & keyword args with SCM_UNDEFINED */ n = npositional; while (n < ntotal) LOCAL_SET (n++, SCM_UNDEFINED); VM_ASSERT (has_rest || (nkw % 2) == 0, vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp))); /* Now bind keywords, in the order given. */ for (n = 0; n < nkw; n++) if (scm_is_keyword (LOCAL_REF (ntotal + n))) { SCM walk; for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n))) { SCM si = SCM_CDAR (walk); LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si), LOCAL_REF[ntotal + n + 1]); break; } VM_ASSERT (scm_is_pair (walk) || allow_other_keys, vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp))); n++; } else VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp))); if (has_rest) { SCM rest = SCM_EOL; n = nkw; while (n--) rest = scm_cons (LOCAL_REF (ntotal + n), rest); LOCAL_SET (nreq_and_opt, rest); } for (n = 0, n < nkw; n++) LOCAL_SET (ntotal + n, SCM_UNDEFINED); NEXT (4); } /* bind-rest dst:24 * * Collect any arguments at or above DST into a list, and store that * list at DST. */ VM_DEFINE_OP (39, bind_rest, "bind-rest") { scm_t_uint32 dst; SCM rest = SCM_EOL; SCM_UNPACK_RTL_24 (op, dst); while (nargs-- > dst) { rest = scm_cons (LOCAL_REF (nargs), rest); LOCAL_SET (nargs, SCM_UNDEFINED); } LOCAL_SET (dst, rest); NEXT (1); } /* call from:24 return-loc:32 0:8 nargs:24 proc:24 0:8 arg0:24 0:8 ... * * Call a procedure. Push a call frame on at FROM, saving the return * address and the fp, and arranging for the result to be placed in * RETURN-LOC, which itself is an encoding of a destination register and * the expected number of returned values. Parse out NARGS, and push * the procedure and arguments. All arguments except for RETURN-LOC are * 24-bit values. FROM and NARGS are in the upper 24 bits of the words. * PROC and the ARGN... are in the lower 24 bits, with the upper 8 bits * being 0. */ VM_DEFINE_OP (40, call, "call") { scm_t_uint32 from, return_loc, n; SCM *old_fp = fp; SCM_UNPACK_RTL_24 (op, from); return_loc = ip[1]; SCM_UNPACK_RTL_24 (ip[2], nargs); VM_HANDLE_INTERRUPTS; fp = vp->fp = old_fp + from + 4; SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 5 + nargs); SCM_FRAME_SET_RETURN_LOC (fp, return_loc); fp[-1] = old_fp[ip[3]]; for (n = 0; n < nargs; n++) LOCAL_SET (n, old_fp[ip[4 + n]]); PUSH_CONTINUATION_HOOK (); APPLY_HOOK (); if (SCM_UNLIKELY (!RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) goto apply; ip = RTL_PROGRAM_ENTRY (SCM_FRAME_PROGRAM (fp)); NEXT (0); } /* tail-call nargs:24 _:8 proc:24 * * Tail-call a procedure. Requires that all of the arguments have * already been shuffled into position. */ VM_DEFINE_OP (41, tail_call, "tail-call") { scm_t_uint32 proc; SCM_UNPACK_RTL_24 (op, nargs); SCM_UNPACK_RTL_24 (ip[1], proc); VM_HANDLE_INTERRUPTS; fp[-1] = LOCAL_REF (proc); APPLY_HOOK (); if (SCM_UNLIKELY (!RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) goto apply; ip = RTL_PROGRAM_ENTRY (SCM_FRAME_PROGRAM (fp)); NEXT (0); } #define RETURN_ONE_VALUE(ret) \ { \ SCM *new_fp = SCM_FRAME_DYNAMIC_LINK (fp); \ scm_t_uint32 ret_loc = SCM_FRAME_RETURN_LOC (fp) ; \ VM_HANDLE_INTERRUPTS; \ if (ret_loc & 0xff) \ new_fp[ret_loc >> 8] = ret; \ /* Restore registers */ \ ip = SCM_FRAME_RETURN_ADDRESS (fp); \ fp = vp->fp = new_fp; \ POP_CONTINUATION_HOOK (1); \ NEXT (0); \ } #define RETURN_VALUE_LIST(tail_) \ { \ SCM *new_fp = SCM_FRAME_DYNAMIC_LINK (fp); \ scm_t_uint32 ret_loc = SCM_FRAME_RETURN_LOC (fp) ; \ scm_t_uint32 idx = ret_loc >> 8; \ scm_t_uint8 nreq = (ret_loc & 0xff) >> 1; \ scm_t_uint8 has_rest = ret_loc & 0x1; \ VM_HANDLE_INTERRUPTS; \ if (nreq) \ { \ SCM tail = tail_; \ VM_ASSERT (scm_ilength (tail) >= nreq, \ vm_error_not_enough_values ()); \ while (nreq--) \ { \ new_fp[idx++] = SCM_CAR (tail); \ tail = SCM_CDR (tail); \ } \ if (has_rest) \ new_fp[idx] = tail; \ } \ else if (has_rest) \ new_fp[idx] = tail_; \ /* Restore registers */ \ ip = SCM_FRAME_RETURN_ADDRESS (fp); \ if (has_rest || nreq != 1) \ ip--; \ fp = vp->fp = new_fp; \ POP_CONTINUATION_HOOK (1); \ NEXT (0); \ } /* return src:24 * * Return a value. */ VM_DEFINE_OP (42, return, "return") { scm_t_uint32 src; SCM_UNPACK_RTL_24 (op, src); RETURN_ONE_VALUE (LOCAL_REF (src)); } /* subr-call nargs:12 ptr-idx:12 * * Call a subr. Fetch the foreign pointer from PTR-IDX, a free * variable. Return from the calling frame. We assume that the * arguments are on the stack from slot 0 to NARGS-1. This instruction * is part of the trampolines created in gsubr.c, and is not generated * by the compiler. */ VM_DEFINE_OP (43, subr_call, "subr-call") { scm_t_uint16 ptr_idx; SCM pointer, ret; SCM (*subr)(); SCM_UNPACK_RTL_12_12 (op, nargs, free_idx); pointer = FREE_VARIABLE_REF (free_idx); subr = SCM_POINTER_VALUE (pointer); VM_HANDLE_INTERRUPTS; SYNC_IP (); switch (nargs) { case 0: ret = subr (); break; case 1: ret = subr (fp[0]); break; case 2: ret = subr (fp[0], fp[1]); break; case 3: ret = subr (fp[0], fp[1], fp[2]); break; case 4: ret = subr (fp[0], fp[1], fp[2], fp[3]); break; case 5: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]); break; case 6: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]); break; case 7: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]); break; case 8: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]); break; case 9: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]); break; case 10: ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]); break; default: abort (); } // NULLSTACK_FOR_NONLOCAL_EXIT (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); else RETURN_ONE_VALUE (ret); } /* foreign-call nargs:8 cif-idx:8 ptr-idx:8 * * Call a subr. Fetch the CIF and foreign pointer from CIF-IDX and * PTR-IDX, both free variables. Return from the calling frame. We * assume that the arguments are on the stack from slot 0 to NARGS-1. * This instruction is part of the trampolines created by the FFI, and * is not generated by the compiler. */ VM_DEFINE_OP (44, foreign_call, "foreign-call") { scm_t_uint8 cif_idx, ptr_idx; SCM cif, pointer, ret; SCM_UNPACK_RTL_8_8_8 (op, nargs, cif_idx, ptr_idx); cif = FREE_VARIABLE_REF (cif_idx); pointer = FREE_VARIABLE_REF (ptr_idx); SYNC_IP (); VM_HANDLE_INTERRUPTS; // FIXME: separate args ret = scm_i_foreign_call (scm_cons (cif, foreign), sp - nargs + 1); // NULLSTACK_FOR_NONLOCAL_EXIT (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); else RETURN_ONE_VALUE (ret); } /* continuation-call nargs:24 _:8 contregs:24 * * Return to a continuation, nonlocally. The NARGS values are taken * from the stack, from slots 0 to NARGS-1. CONTREGS is a free variable * containing the reified continuation. This instruction is part of the * implementation of undelimited continuations, and is not generated by * the compiler. */ VM_DEFINE_OP (45, continuation_call, "continuation-call") { SCM contregs; scm_t_uint32 contregs_idx; SCM_UNPACK_RTL_24 (op, nargs); SCM_UNPACK_RTL_24 (ip[1], contregs_idx); contregs = FREE_VARIABLE_REF (contregs_idx); SYNC_IP (); scm_i_check_continuation (contregs); vm_return_to_continuation (scm_i_contregs_vm (contregs), scm_i_contregs_vm_cont (contregs), nargs, fp); scm_i_reinstate_continuation (contregs); /* no NEXT */ abort (); } /* partial-cont nargs:24 _:8 cont:24 * * Compose a partial continution with the current continuation. The * NARGS values are taken from the stack, from slots 0 to NARGS-1. CONT * is a free variable containing the reified continuation. This * instruction is part of the implementation of partial continuations, * and is not generated by the compiler. */ VM_DEFINE_OP (46, partial_cont_call, "partial-cont-call") { SCM vmcont; scm_t_uint32 cont_idx; SCM_UNPACK_RTL_24 (op, nargs); SCM_UNPACK_RTL_24 (ip[1], cont_idx); SYNC_IP (); VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), vm_error_continuation_not_rewindable (vmcont)); vm_reinstate_partial_continuation (vm, vmcont, nargs, fp, ¤t_thread->dynstack, ®isters); CACHE_REGISTER (); NEXT (0); } /* apply _:24 * * Tail-apply the procedure in local slot 0 to the rest of the * arguments. This instruction is part of the implementation of * `apply', and is not generated by the compiler. */ VM_DEFINE_OP (47, apply, "apply") { int i, list_idx, list_len; SCM list; VM_HANDLE_INTERRUPTS; list_idx = nargs - 1; list = LOCAL_REF[list_idx]; list_len = scm_ilength (list); VM_ASSERT (len >= 0, vm_error_apply_to_non_list (ls)); for (i = 0; i < list_idx; i++) fp[i -1] = fp[i]; /* Null out these slots, just in case there are less than 2 elements in the list. */ fp[list_idx - 1] = SCM_UNDEFINED; fp[list_idx] = SCM_UNDEFINED; for (i = 0; i < list_len; i++, list = SCM_CDR (list)) fp[list_idx - 1 + i] = SCM_CAR (list); nargs = nargs - 2 + list_len; APPLY_HOOK (); if (SCM_UNLIKELY (!RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) goto apply; ip = RTL_PROGRAM_ENTRY (SCM_FRAME_PROGRAM (fp)); NEXT (0); } /* call/cc _:24 * * Capture the current continuation, and tail-apply the procedure in * 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 (48, call_cc, "call/cc") { int first; SCM proc, vm_cont, cont; scm_t_dynstack *dynstack; VM_HANDLE_INTERRUPTS; SYNC_IP (); dynstack = scm_dynstack_capture_all (¤t_thread->dynstack); vm_cont = scm_i_vm_capture_stack (vp->stack_base, SCM_FRAME_DYNAMIC_LINK (fp), SCM_FRAME_LOWER_ADDRESS (fp) - 1, SCM_FRAME_RETURN_ADDRESS (fp), SCM_FRAME_MV_RETURN_ADDRESS (fp), dynstack, 0); cont = scm_i_make_continuation (®isters, vm, vm_cont); fp[-1] = fp[0]; fp[0] = cont; nargs = 1; APPLY_HOOK (); if (SCM_UNLIKELY (!RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))) goto apply; ip = RTL_PROGRAM_ENTRY (SCM_FRAME_PROGRAM (fp)); NEXT (0); } /* return-values nvalues:24 val0:24 0:8 val1:24 0:8 ... * * Return a number of values from a call frame. This opcode corresponds * to an application of `values' in tail position. The values VAL0, * VAL1, etc are 24-bit values, in the lower 24 bits of their words. * The upper 8 bits are 0. */ VM_DEFINE_OP (49, return_values, "return/values") { scm_t_uint32 nvalues, n; SCM *new_fp = SCM_FRAME_DYNAMIC_LINK (fp); scm_t_uint32 ret_loc = SCM_FRAME_RETURN_LOC (fp) ; scm_t_uint32 idx = ret_loc >> 8; scm_t_uint8 nreq = (ret_loc & 0xff) >> 1; scm_t_uint8 has_rest = ret_loc & 0x1; SCM_UNPACK_RTL_24 (op, nvalues); VM_HANDLE_INTERRUPTS; VM_ASSERT (nvalues >= nreq, vm_error_not_enough_values ()); for (n = 0; n < nreq; n++) new_fp[idx + n] = fp[ip[n+1]]; if (has_rest) { SCM tail = SCM_EOL; for (n = nvalues; n > nreq; n--) tail = scm_cons (fp[ip[n]], tail); new_fp[idx + nreq] = tail; } /* Restore registers */ ip = SCM_FRAME_RETURN_ADDRESS (fp); if (has_rest || nreq != 1) ip--; fp = vp->fp = new_fp; POP_CONTINUATION_HOOK (has_rest ? nvalues : nreq); NEXT (0); } /* 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 (50, values, "values") { scm_t_uint32 nvalues, n; SCM *new_fp = SCM_FRAME_DYNAMIC_LINK (fp); scm_t_uint32 ret_loc = SCM_FRAME_RETURN_LOC (fp) ; scm_t_uint32 idx = ret_loc >> 8; scm_t_uint8 nreq = (ret_loc & 0xff) >> 1; scm_t_uint8 has_rest = ret_loc & 0x1; VM_HANDLE_INTERRUPTS; nvalues = nargs; VM_ASSERT (nvalues >= nreq, vm_error_not_enough_values ()); for (n = 0; n < nreq; n++) new_fp[idx + n] = fp[n]; if (has_rest) { SCM tail = SCM_EOL; for (n = nvalues; n > nreq; n--) tail = scm_cons (fp[n], tail); new_fp[idx + nreq] = tail; } /* Restore registers */ ip = SCM_FRAME_RETURN_ADDRESS (fp); if (has_rest || nreq != 1) ip--; fp = vp->fp = new_fp; POP_CONTINUATION_HOOK (has_rest ? nvalues : nreq); NEXT (0); } /* box dst:12 src:12 * * Create a new variable holding SRC, and place it in DST. */ VM_DEFINE_OP (51, box, "box") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src)))); 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 (52, empty_box, "empty-box") { scm_t_uint32 dst; SCM_UNPACK_RTL_24 (op, dst); LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); NEXT (1); } /* free-ref dst:12 src:12 * * Load free variable SRC into local slot DST. */ VM_DEFINE_OP (53, free_ref, "free-ref") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); CHECK_FREE_VARIABLE (src); LOCAL_SET (dst, FREE_VARIABLE_REF (src)); NEXT (1); } /* make-closure dst:24 offset:32 nfree:24 0:8 free0:24 0:8 ... * * Make a new closure, and write it to DST. The code for the closure * will be found at OFFSET words from the current IP. OFFSET is a * signed 32-bit integer. The registers for the NFREE free variables * follow. */ VM_DEFINE_OP (54, make_closure, "make-closure") { scm_t_uint32 dst, nfree, n; scm_t_int32 offset; SCM closure; SCM_UNPACK_RTL_24 (op, dst); offset = ip[1]; nfree = ip[2]; // FIXME: Assert range of nfree? closure = scm_words (scm_tc7_program | (nfree << 16), nfree + 2); SCM_SET_CELL_DATA_1 (closure, ip + offset); for (n = 0; n < nfree; n++) SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 3])); LOCAL_SET (dst, closure); NEXT (nfree + 3); } /* fix-closure dst:24 nfree:24 0:8 free0:24 0:8 ... * * "Fix" a closure. This is used for lambda expressions bound in a * , but which are not always called in tail position. In that * case we allocate the closures first, then destructively update their * free variables to point to each other. NFREE and the locals FREE0... * are as in make-closure. */ VM_DEFINE_OP (55, fix_closure, "fix-closure") { scm_t_uint32 dst, nfree, n; SCM closure; SCM_UNPACK_RTL_24 (op, dst); nfree = ip[1]; closure = LOCAL_REF (dst); for (n = 0; n < nfree; n++) SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 2])); NEXT (nfree + 2); } /* define sym:12 val:12 * * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ VM_DEFINE_OP (56, define, "define") { scm_t_uint16 sym, val; SCM_UNPACK_RTL_12_12 (op, sym, val); SYNC_IP (); VARIABLE_SET (scm_sym2var (LOCAL_REF (sym), scm_current_module_lookup_closure (), SCM_BOOL_T), LOCAL_REF (val)); NEXT (1); } /* make-keyword dst:12 src:12 * * Make a keyword from the symbol in SRC, and store it in DST. */ VM_DEFINE_OP (57, make_keyword, "make-keyword") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); SYNC_IP (); LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src))); NEXT (1); } /* make-symbol dst:12 src:12 * * Make a symbol from the string in SRC, and store it in DST. */ VM_DEFINE_OP (58, make_symbol, "make-symbol") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); SYNC_IP (); LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src))); NEXT (1); } /* prompt tag:24 return-loc:32 flags:8 handler-offset:24 * * Push a new prompt on the dynamic stack, with a tag from TAG and a * handler at HANDLER-OFFSET words from the current IP. The handler * will expect its arguments in RETURN-LOC, as in call and * return/values. If FLAGS is nonzero, mark the prompt as escape-only, * indicating that no continuation need be reified. */ VM_DEFINE_OP (59, prompt, "prompt") { scm_t_unt32 tag, return_loc; scm_t_int32 offset; scm_t_uint8 escape_only_p; SCM k; scm_t_dynstack_prompt_flags flags; SCM_UNPACK_RTL_24 (op, tag); return_loc = ip[1]; escape_only_p = ip[2] & 0xff; offset = ip[2]; offset >>= 8; /* Sign extension */ /* Push the prompt onto the dynamic stack. */ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; /* FIXME: return_loc */ scm_dynstack_push_prompt (¤t_thread->dynstack, flags, LOCAL_REF (tag), fp, sp, ip + offset, ®isters); NEXT (3); } /* wind winder:12 unwinder:12 * * Push wind and unwind procedures onto the dynamic stack. Note that * neither are actually called; the compiler should emit calls to wind * and unwind for the normal dynamic-wind control flow. Also note that * 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 (60, wind, "wind") { scm_t_uint16 winder, unwinder; SCM_UNPACK_RTL_12_12 (op, winder, unwinder); scm_dynstack_push_dynwind (¤t_thread->dynstack, LOCAL_REF (winder), LOCAL_REF (unwinder)); NEXT (1); } /* abort tag:24 _:8 nvalues:24 val0:24 0:8 val1:24 0:8 ... * * Return a number of values to a prompt handler. The values VAL0, * VAL1, etc are 24-bit values, in the lower 24 bits of their words. * The upper 8 bits are 0. */ VM_DEFINE_OP (61, abort, "abort") { scm_t_unt32 tag, nvalues; SCM_UNPACK_RTL_24 (op, tag); SCM_UNPACK_RTL_24 (ip[1], nvalues); SYNC_IP (); vm_abort (vm, LOCAL_REF (tag), nvalues, &ip[2], ®isters); /* vm_abort should not return */ abort (); } /* unwind _:24 * * A normal exit from the dynamic extent of an expression. Pop the top * entry off of the dynamic stack. */ VM_DEFINE_OP (62, unwind, "unwind") { scm_dynstack_pop (¤t_thread->dynstack); NEXT (1); } /* wind-fluids n:24 _:8 fluid-base:24 value0:24 0:8 ... * * Dynamically bind N fluids to values. The fluids are expected to be * allocated in a continguous range on the stack, starting from * FLUID-BASE. The values do not have this restriction. */ VM_DEFINE_OP (63, wind_fluids, "wind-fluids") { scm_t_unt32 n, fluid_base; SCM_UNPACK_RTL_24 (op, n); SCM_UNPACK_RTL_24 (ip[1], fluid_base); scm_dynstack_push_fluids_shuffled (¤t_thread->dynstack, n, &fp[fluid_base], fp, &ip[2], current_thread->dynamic_state); NEXT (n + 2); } /* unwind-fluids _:24 * * Leave the dynamic extent of a with-fluids expression, restoring the * fluids to their previous values. */ VM_DEFINE_OP (64, unwind_fluids, "unwind-fluids") { /* This function must not allocate. */ scm_dynstack_unwind_fluids (¤t_thread->dynstack, current_thread->dynamic_state); NEXT (1); } /* fluid-ref dst:12 src:12 * * Reference the fluid in SRC, and place the value in DST. */ VM_DEFINE_OP (65, fluid_ref, "fluid-ref") { scm_t_uint16 dst, src; size_t num; SCM fluid, fluids; SCM_UNPACK_RTL_12_12 (op, dst, src); fluid = LOCAL_REF (src); fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) { /* Punt dynstate expansion and error handling to the C proc. */ SYNC_IP (); LOCAL_SET (dst, scm_fluid_ref (fluid)); } else { SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); if (scm_is_eq (val, SCM_UNDEFINED)) val = SCM_I_FLUID_DEFAULT (fluid); VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), vm_error_unbound_fluid (program, fluid)); LOCAL_SET (dst, val); } NEXT (1); } /* fluid-set dst:12 src:12 * * Set the value of the fluid in DST to the value in SRC. */ VM_DEFINE_OP (66, fluid_set, "fluid-set") { scm_t_uint16 dst, src; size_t num; SCM fluid, fluids; SCM_UNPACK_RTL_12_12 (op, dst, src); fluid = LOCAL_REF (dst); fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) { /* Punt dynstate expansion and error handling to the C proc. */ SYNC_IP (); scm_fluid_set_x (fluid, LOCAL_REF (src)); } else SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (src)); NEXT (1); } /* string-to-number dst:12 src:12 * * Parse a string in SRC to a number, and store in DST. */ VM_DEFINE_OP (67, string_to_number, "string->number") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); SYNC_IP (); LOCAL_SET (dst, scm_string_to_number (LOCAL_REF (src), SCM_UNDEFINED /* radix = 10 */)); NEXT (1); } /* string-to-symbol dst:12 src:12 * * Parse a string in SRC to a symbol, and store in DST. */ VM_DEFINE_OP (68, string_to_symbol, "string->symbol") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); SYNC_IP (); LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src))); NEXT (1); } /* resolve dst:12 src:12 * * Resolve the symbol or (MODNAME SYMBOL PUBLIC?) form from SRC to a * variable, and store the variable in DST. */ VM_DEFINE_OP (69, resolve, "resolve") { scm_t_uint16 dst, src; SCM_UNPACK_RTL_12_12 (op, dst, src); SYNC_IP (); LOCAL_SET (dst, resolve (LOCAL_REF (src))); NEXT (1); } /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32 * * Load the contiguous typed array located at OFFSET 32-bit words away * from the instruction pointer, and store into DST. LEN is a byte * length. OFFSET is signed. */ VM_DEFINE_OP (70, load_typed_array, "load-typed-array") { scm_t_uint8 dst, type, shape; scm_t_int32 offset; scm_t_uint32 len; SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape); offset = ip[1]; len = ip[2]; SYNC_IP (); LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type), LOCAL_REF (shape), ip + offset, len)); NEXT (3); } /* constant-vector-ref dst:8 src:8 idx:8 * * Fill DST with the item IDX elements into the vector at SRC. Useful * for building data types using vectors. */ VM_DEFINE_OP (71, constant_vector_ref, "constant-vector-ref") { scm_t_uint8 dst, src, idx; SCM v; SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx); v = LOCAL_REF (src); if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v) && idx < SCM_I_VECTOR_LENGTH (v))) LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]); else LOCAL_SET (dst, scm_c_vector_ref (v, idx)); NEXT (1); } #define ARGS1(a1) \ scm_t_uint16 dst, src; \ SCM a1; \ SCM_PARSE_RTL_12_12 (op, dst, src); \ a1 = LOCAL_REF (src) #define ARGS2(a1, a2) \ scm_t_uint8 dst, src1, src2; \ SCM a1, a2; \ SCM_PARSE_RTL_8_8_8 (op, dst, src1, src2); \ a1 = LOCAL_REF (src1); \ a2 = LOCAL_REF (src2) #define RETURN(x) \ do { LOCAL_SET (dst, x); NEXT (1); } while (0) /* cons dst:8 car:8 cdr:8 * * Cons CAR and CDR, and store the result in DST. */ VM_DEFINE_OP (72, cons, "cons") { ARGS2 (x, y); RETURN (scm_cons (x, y)); } #define VM_VALIDATE_PAIR(x, proc) \ VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x)) /* car dst:12 src:12 * * Place the car of SRC in DST. */ VM_DEFINE_OP (73, car, "car") { ARGS1 (x); VM_VALIDATE_PAIR (x, "car"); RETURN (SCM_CAR (x)); } /* cdr dst:12 src:12 * * Place the cdr of SRC in DST. */ VM_DEFINE_OP (74, cdr, "cdr") { ARGS1 (x); VM_VALIDATE_PAIR (x, "cdr"); RETURN (SCM_CDR (x)); } /* set-car! dst:12 src:12 * * Set the car of DST to SRC. */ VM_DEFINE_OP (75, set_car, "set-car!") { scm_t_uint16 dst, src; SCM x, y; SCM_PARSE_RTL_12_12 (op, dst, src); x = LOCAL_REF (dst); y = LOCAL_REF (src); VM_VALIDATE_PAIR (x, "set-car!"); SCM_SETCAR (x, y); NEXT (1); } /* set-cdr! dst:12 src:12 * * Set the cdr of DST to SRC. */ VM_DEFINE_OP (76, set_cdr, "set-cdr!") { scm_t_uint16 dst, src; SCM x, y; SCM_PARSE_RTL_12_12 (op, dst, src); x = LOCAL_REF (dst); y = LOCAL_REF (src); VM_VALIDATE_PAIR (x, "set-car!"); SCM_SETCDR (x, y); NEXT (1); } /* The maximum/minimum tagged integers. */ #undef INUM_MAX #undef INUM_MIN #define INUM_MAX (INTPTR_MAX - 1) #define INUM_MIN (INTPTR_MIN + scm_tc2_int) #undef FUNC2 #define FUNC2(CFUNC,SFUNC) \ { \ ARGS2 (x, y); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ { \ scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \ if (SCM_FIXABLE (n)) \ RETURN (SCM_I_MAKINUM (n)); \ } \ SYNC_IP (); \ RETURN (SFUNC (x, y)); \ } /* add dst:8 a:8 b:8 * * Add A to B, and place the result in DST. */ VM_DEFINE_OP (77, add, "add") { FUNC2 (+, scm_sum); } /* add1 dst:12 src:12 * * Add 1 to the value in SRC, and place the result in DST. */ VM_DEFINE_OP (78, add1, "add1", 1) { ARGS1 (x); /* Check for overflow. */ if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX)) { SCM result; /* Add the integers without untagging. */ result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x) + (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1)) - scm_tc2_int); if (SCM_LIKELY (SCM_I_INUMP (result))) RETURN (result); } SYNC_IP (); RETURN (scm_sum (x, SCM_I_MAKINUM (1))); } /* sub dst:8 a:8 b:8 * * Subtract B from A, and place the result in DST. */ VM_DEFINE_OP (79, sub, "sub") { FUNC2 (-, scm_difference); } /* sub1 dst:12 src:12 * * Subtract 1 from SRC, and place the result in DST. */ VM_DEFINE_OP (80, sub1, "sub1") { ARGS1 (x); /* Check for underflow. */ if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN)) { SCM result; /* Substract the integers without untagging. */ result = SCM_PACK ((scm_t_intptr) SCM_UNPACK (x) - (scm_t_intptr) SCM_UNPACK (SCM_I_MAKINUM (1)) + scm_tc2_int); if (SCM_LIKELY (SCM_I_INUMP (result))) RETURN (result); } SYNC_IP (); RETURN (scm_difference (x, SCM_I_MAKINUM (1))); } /* mul dst:8 a:8 b:8 * * Multiply A and B, and place the result in DST. */ VM_DEFINE_OP (81, mul, "mul") { ARGS2 (x, y); SYNC_IP (); RETURN (scm_product (x, y)); } /* div dst:8 a:8 b:8 * * Divide A by B, and place the result in DST. */ VM_DEFINE_OP (82, div, "div") { ARGS2 (x, y); SYNC_IP (); RETURN (scm_divide (x, y)); } /* quo dst:8 a:8 b:8 * * Divide A by B, and place the quotient in DST. */ VM_DEFINE_OP (83, quo, "quo") { ARGS2 (x, y); SYNC_IP (); RETURN (scm_quotient (x, y)); } /* rem dst:8 a:8 b:8 * * Divide A by B, and place the remainder in DST. */ VM_DEFINE_OP (84, rem, "rem") { ARGS2 (x, y); SYNC_IP (); RETURN (scm_remainder (x, y)); } /* mod dst:8 a:8 b:8 * * Place the modulo of A by B in DST. */ VM_DEFINE_OP (85, mod, "mod") { ARGS2 (x, y); SYNC_IP (); RETURN (scm_modulo (x, y)); } /* ash dst:8 a:8 b:8 * * Shift A arithmetically by B bits, and place the result in DST. */ VM_DEFINE_OP (86, ash, "ash") { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) { if (SCM_I_INUM (y) < 0) /* Right shift, will be a fixnum. */ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y))); else /* Left shift. See comments in scm_ash. */ { scm_t_signed_bits nn, bits_to_shift; nn = SCM_I_INUM (x); bits_to_shift = SCM_I_INUM (y); if (bits_to_shift < SCM_I_FIXNUM_BIT-1 && ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1) <= 1)) RETURN (SCM_I_MAKINUM (nn << bits_to_shift)); /* fall through */ } /* fall through */ } SYNC_IP (); RETURN (scm_ash (x, y)); } /* logand dst:8 a:8 b:8 * * Place the bitwise AND of A and B into DST. */ VM_DEFINE_OP (87, logand, "logand") { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y))); SYNC_IP (); RETURN (scm_logand (x, y)); } /* logior dst:8 a:8 b:8 * * Place the bitwise inclusive OR of A with B in DST. */ VM_DEFINE_OP (88, logior, "logior") { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y))); SYNC_IP (); RETURN (scm_logior (x, y)); } /* logxor dst:8 a:8 b:8 * * Place the bitwise exclusive OR of A with B in DST. */ VM_DEFINE_OP (89, logxor, "logxor", 2) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y))); SYNC_IP (); RETURN (scm_logxor (x, y)); } /* string-length dst:12 src:12 * * Store the length of the string in SRC in DST. */ VM_DEFINE_OP (90, string_length, "string-length") { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) RETURN (SCM_I_MAKINUM (scm_i_string_length (str))); else { SYNC_IP (); RETURN (scm_string_length (str)); } } /* string-ref dst:8 src:8 idx:8 * * Fetch the character at position IDX in the string in SRC, and store * it in DST. */ VM_DEFINE_OP (91, string_ref, "string-ref", 2) { scm_t_signed_bits i = 0; ARGS2 (str, idx); if (SCM_LIKELY (scm_is_string (str) && SCM_I_INUMP (idx) && ((i = SCM_I_INUM (idx)) >= 0) && i < scm_i_string_length (str))) RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i))); else { SYNC_IP (); RETURN (scm_string_ref (str, idx)); } } /* No string-set! instruction, as there is no good fast path there. */ /* vector-length dst:12 src:12 * * Store the length of the vector in SRC in DST. */ VM_DEFINE_OP (92, vector_length, "vector-length") { ARGS1 (vect); if (SCM_LIKELY (SCM_I_IS_VECTOR (vect))) RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect))); else { SYNC_IP (); RETURN (scm_vector_length (vect)); } } /* vector-ref dst:8 src:8 idx:8 * * Fetch the item at position IDX in the vector in SRC, and store it * in DST. */ VM_DEFINE_OP (93, vector_ref, "vector-ref") { scm_t_signed_bits i = 0; ARGS2 (vect, idx); if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect) && SCM_I_INUMP (idx) && ((i = SCM_I_INUM (idx)) >= 0) && i < SCM_I_VECTOR_LENGTH (vect))) RETURN (SCM_I_VECTOR_ELTS (vect)[i]); else { SYNC_IP (); RETURN (scm_vector_ref (vect, idx)); } } /* vector-ref dst:8 idx:8 src:8 * * Store SRC into the vector DST at index IDX. */ VM_DEFINE_INSTRUCTION (94, vector_set, "vector-set") { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; scm_t_signed_bits i = 0; SCM_PARSE_RTL_8_8_8 (op, dst, var, src); vect = LOCAL_REF (dst); idx = LOCAL_REF (idx_var); val = LOCAL_REF (src); if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect) && SCM_I_INUMP (idx) && ((i = SCM_I_INUM (idx)) >= 0) && i < SCM_I_VECTOR_LENGTH (vect))) SCM_I_VECTOR_WELTS (vect)[i] = val; else { SYNC_IP (); scm_vector_set_x (vect, idx, val); } NEXT (1); } /* make-array dst:12 type:12 _:8 fill:12 bounds:12 * * Make a new array SRC into the vector DST at index IDX. */ VM_DEFINE_INSTRUCTION (95, make_array, "make-array") { scm_t_uint16 dst, type, fill, bounds; SCM_PARSE_RTL_12_12 (op, dst, type); SCM_PARSE_RTL_12_12 (ip[1], fill, bounds); SYNC_IP (); LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill), LOCAL_REF (bounds))); NEXT (2); } /* * Structs */ #define VM_VALIDATE_STRUCT(obj, proc) \ VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj)) /* struct-vtable dst:12 type:12 * * Store the vtable of SRC into DST. */ VM_DEFINE_OP (96, struct_vtable, "struct-vtable") { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); RETURN (SCM_STRUCT_VTABLE (obj)); } /* make-struct dst:12 vtable:12 n-init:24 0:8 init0:24 0:8 ... * * Make a new struct with VTABLE, and place it in DST. The struct * will be constructed with N-INIT initializers, which are located in the * locals given by INIT0.... The format of N-INIT and INIT0... is as in * the "call" opcode: unsigned 24-bit values, with 0 in the high byte. */ VM_DEFINE_INSTRUCTION (97, make_struct, "make-struct") { scm_t_uint16 dst, vtable_r; scm_t_uint32 n_init, n; SCM vtable, ret; SCM_PARSE_RTL_12_12 (op, dst, vtable_r); vtable = LOCAL_REF (vtable_r); n_init = ip[1]; SYNC_IP (); if (SCM_LIKELY (SCM_STRUCTP (vtable) && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE) && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == n_init) && !SCM_VTABLE_INSTANCE_FINALIZER (vtable))) { /* Verily, we are making a simple struct with the right number of initializers, and no finalizer. */ ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct, n_init + 2); SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2)); for (n = 0; n < n_init; n++) SCM_STRUCT_DATA (ret)[n] = LOCAL_REF (ip[n + 1]); } else ret = scm_c_make_structvs (vtable, fp, &ip[1], n_init); LOCAL_SET (dst, ret); NEXT (n_init + 1); } /* struct-ref dst:8 src:8 idx:8 * * Fetch the item at slot IDX in the struct in SRC, and store it * in DST. */ VM_DEFINE_OP (98, struct_ref, "struct-ref", 2) { ARGS2 (obj, pos); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE) && SCM_I_INUMP (pos))) { SCM vtable; scm_t_bits index, len; /* True, an inum is a signed value, but cast to unsigned it will certainly be more than the length, so we will fall through if index is negative. */ index = SCM_I_INUM (pos); vtable = SCM_STRUCT_VTABLE (obj); len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); if (SCM_LIKELY (index < len)) { scm_t_bits *data = SCM_STRUCT_DATA (obj); RETURN (SCM_PACK (data[index])); } } SYNC_IP (); RETURN (scm_struct_ref (obj, pos)); } /* struct-set dst:12 idx:12 _:8 src:24 * * Store SRC into the struct DST at slot IDX. */ VM_DEFINE_INSTRUCTION (99, make_array, "make-array") { scm_t_uint16 dst, idx; scm_t_uint32 src; SCM obj, pos, val; SCM_PARSE_RTL_12_12 (op, dst, type); SCM_PARSE_RTL_24 (ip[1], src); obj = LOCAL_REF (dst); pos = LOCAL_REF (idx); val = LOCAL_REF (src); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE_RW) && SCM_I_INUMP (pos))) { SCM vtable; scm_t_bits index, len; /* See above regarding index being >= 0. */ index = SCM_I_INUM (pos); vtable = SCM_STRUCT_VTABLE (obj); len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size); if (SCM_LIKELY (index < len)) { scm_t_bits *data = SCM_STRUCT_DATA (obj); data[index] = SCM_UNPACK (val); NEXT (2); } } SYNC_IP (); scm_struct_set_x (obj, pos, val); NEXT (2); } /* struct-vtable dst:12 type:12 * * Store the vtable of SRC into DST. */ VM_DEFINE_OP (100, class_of, "class-of") { ARGS1 (obj); if (SCM_INSTANCEP (obj)) RETURN (SCM_CLASS_OF (obj)); SYNC_IP (); RETURN (scm_class_of (obj)); } /* slot-ref dst:8 src:8 idx:8 * * Fetch the item at slot IDX in the struct in SRC, and store it in * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an * index into the stack. */ VM_DEFINE_OP (101, slot_ref, "slot-ref") { scm_t_uint8 dst, src, idx; SCM_PARSE_RTL_8_8_8 (op, dst, src, idx); LOCAL_SET (dst, SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx])); NEXT (1); } /* slot-set! dst:8 idx:8 src:8 * * Store SRC into slot IDX of the struct in SRC. Unlike struct-set!, * IDX is an 8-bit immediate value, not an index into the stack. */ VM_DEFINE_INSTRUCTION (102, slot_set, "slot-set!") { scm_t_uint8 dst, idx, src; SCM_PARSE_RTL_8_8_8 (op, dst, idx, src); SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src)); NEXT (1); } /* * Bytevectors */ #define VM_VALIDATE_BYTEVECTOR(x, proc) \ VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x)) #define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \ { \ SCM endianness; \ POP (endianness); \ if (scm_is_eq (endianness, scm_i_native_endianness)) \ goto VM_LABEL (bv_##stem##_native_ref); \ { \ ARGS2 (bv, idx); \ SYNC_IP (); \ RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \ } \ } /* Return true (non-zero) if PTR has suitable alignment for TYPE. */ #define ALIGNED_P(ptr, type) \ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0) VM_DEFINE_OP (103, bv_u16_ref, "bv-u16-ref", 3) BV_REF_WITH_ENDIANNESS (u16, u16) VM_DEFINE_OP (104, bv_s16_ref, "bv-s16-ref", 3) BV_REF_WITH_ENDIANNESS (s16, s16) VM_DEFINE_OP (105, bv_u32_ref, "bv-u32-ref", 3) BV_REF_WITH_ENDIANNESS (u32, u32) VM_DEFINE_OP (106, bv_s32_ref, "bv-s32-ref", 3) BV_REF_WITH_ENDIANNESS (s32, s32) VM_DEFINE_OP (107, bv_u64_ref, "bv-u64-ref", 3) BV_REF_WITH_ENDIANNESS (u64, u64) VM_DEFINE_OP (108, bv_s64_ref, "bv-s64-ref", 3) BV_REF_WITH_ENDIANNESS (s64, s64) VM_DEFINE_OP (109, bv_f32_ref, "bv-f32-ref", 3) BV_REF_WITH_ENDIANNESS (f32, ieee_single) VM_DEFINE_OP (110, bv_f64_ref, "bv-f64-ref", 3) BV_REF_WITH_ENDIANNESS (f64, ieee_double) #undef BV_REF_WITH_ENDIANNESS #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ { \ scm_t_signed_bits i; \ const scm_t_ ## type *int_ptr; \ ARGS2 (bv, idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ i = SCM_I_INUM (idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ RETURN (SCM_I_MAKINUM (*int_ptr)); \ else \ { \ SYNC_IP (); \ RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \ } \ } #define BV_INT_REF(stem, type, size) \ { \ scm_t_signed_bits i; \ const scm_t_ ## type *int_ptr; \ ARGS2 (bv, idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ i = SCM_I_INUM (idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ { \ scm_t_ ## type x = *int_ptr; \ if (SCM_FIXABLE (x)) \ RETURN (SCM_I_MAKINUM (x)); \ else \ { \ SYNC_IP (); \ RETURN (scm_from_ ## type (x)); \ } \ } \ else \ { \ SYNC_IP (); \ RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \ } \ } #define BV_FLOAT_REF(stem, fn_stem, type, size) \ { \ scm_t_signed_bits i; \ const type *float_ptr; \ ARGS2 (bv, idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ i = SCM_I_INUM (idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ SYNC_IP (); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ RETURN (scm_from_double (*float_ptr)); \ else \ RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ } VM_DEFINE_OP (111, bv_u8_ref, "bv-u8-ref", 2) BV_FIXABLE_INT_REF (u8, u8, uint8, 1) VM_DEFINE_OP (112, bv_s8_ref, "bv-s8-ref", 2) BV_FIXABLE_INT_REF (s8, s8, int8, 1) VM_DEFINE_OP (113, bv_u16_native_ref, "bv-u16-native-ref", 2) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2) VM_DEFINE_OP (114, bv_s16_native_ref, "bv-s16-native-ref", 2) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2) VM_DEFINE_OP (115, bv_u32_native_ref, "bv-u32-native-ref", 2) #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 (116, bv_s32_native_ref, "bv-s32-native-ref", 2) #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 (117, bv_u64_native_ref, "bv-u64-native-ref", 2) BV_INT_REF (u64, uint64, 8) VM_DEFINE_OP (118, bv_s64_native_ref, "bv-s64-native-ref", 2) BV_INT_REF (s64, int64, 8) VM_DEFINE_OP (119, bv_f32_native_ref, "bv-f32-native-ref", 2) BV_FLOAT_REF (f32, ieee_single, float, 4) VM_DEFINE_OP (120, bv_f64_native_ref, "bv-f64-native-ref", 2) BV_FLOAT_REF (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_REF #undef BV_INT_REF #undef BV_FLOAT_REF #define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \ { \ SCM endianness; \ POP (endianness); \ if (scm_is_eq (endianness, scm_i_native_endianness)) \ goto VM_LABEL (bv_##stem##_native_set); \ { \ SCM bv, idx, val; POP3 (val, idx, bv); \ SYNC_IP (); \ scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \ NEXT; \ } \ } VM_DEFINE_INSTRUCTION (121, bv_u16_set, "bv-u16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u16, u16) VM_DEFINE_INSTRUCTION (122, bv_s16_set, "bv-s16-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s16, s16) VM_DEFINE_INSTRUCTION (123, bv_u32_set, "bv-u32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u32, u32) VM_DEFINE_INSTRUCTION (124, bv_s32_set, "bv-s32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s32, s32) VM_DEFINE_INSTRUCTION (125, bv_u64_set, "bv-u64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (u64, u64) VM_DEFINE_INSTRUCTION (126, bv_s64_set, "bv-s64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (s64, s64) VM_DEFINE_INSTRUCTION (127, bv_f32_set, "bv-f32-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f32, ieee_single) VM_DEFINE_INSTRUCTION (128, bv_f64_set, "bv-f64-set", 0, 4, 0) BV_SET_WITH_ENDIANNESS (f64, ieee_double) #undef BV_SET_WITH_ENDIANNESS #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ { \ scm_t_signed_bits i, j = 0; \ SCM bv, idx, val; \ scm_t_ ## type *int_ptr; \ \ POP3 (val, idx, bv); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ i = SCM_I_INUM (idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (int_ptr, scm_t_ ## type)) \ && (SCM_I_INUMP (val)) \ && ((j = SCM_I_INUM (val)) >= min) \ && (j <= max))) \ *int_ptr = (scm_t_ ## type) j; \ else \ { \ SYNC_IP (); \ scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \ } \ NEXT; \ } #define BV_INT_SET(stem, type, size) \ { \ scm_t_signed_bits i = 0; \ SCM bv, idx, val; \ scm_t_ ## type *int_ptr; \ \ POP3 (val, idx, bv); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ i = SCM_I_INUM (idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ *int_ptr = scm_to_ ## type (val); \ else \ { \ SYNC_IP (); \ scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \ } \ NEXT; \ } #define BV_FLOAT_SET(stem, fn_stem, type, size) \ { \ scm_t_signed_bits i = 0; \ SCM bv, idx, val; \ type *float_ptr; \ \ POP3 (val, idx, bv); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \ i = SCM_I_INUM (idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ *float_ptr = scm_to_double (val); \ else \ { \ SYNC_IP (); \ scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \ } \ NEXT; \ } VM_DEFINE_INSTRUCTION (129, bv_u8_set, "bv-u8-set", 0, 3, 0) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1) VM_DEFINE_INSTRUCTION (130, bv_s8_set, "bv-s8-set", 0, 3, 0) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1) VM_DEFINE_INSTRUCTION (131, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2) VM_DEFINE_INSTRUCTION (132, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2) VM_DEFINE_INSTRUCTION (133, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0) #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_INSTRUCTION (134, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0) #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_INSTRUCTION (135, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0) BV_INT_SET (u64, uint64, 8) VM_DEFINE_INSTRUCTION (136, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0) BV_INT_SET (s64, int64, 8) VM_DEFINE_INSTRUCTION (137, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0) BV_FLOAT_SET (f32, ieee_single, float, 4) VM_DEFINE_INSTRUCTION (138, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0) BV_FLOAT_SET (f64, ieee_double, double, 8) #undef BV_FIXABLE_INT_SET #undef BV_INT_SET #undef BV_FLOAT_SET END_DISPATCH_SWITCH; vm_error_bad_instruction: vm_error_bad_instruction (ip[-1]); abort (); /* never reached */ } #undef RTL #endif #undef VM_USE_HOOKS #undef VM_CHECK_OBJECT #undef VM_CHECK_FREE_VARIABLE #undef VM_CHECK_UNDERFLOW /* FIXME: inline scm_cons to scm_cell */ /* (defun renumber-ops () "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" (interactive "") (save-excursion (let ((counter -1)) (goto-char (point-min)) (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) (replace-match (number-to-string (setq counter (1+ counter))) t t nil 1))))) (renumber-ops) */ /* Local Variables: c-file-style: "gnu" End: */