/* This file is included in vm.c multiple times. */
-/* Virtual Machine
-
- This file contains two virtual machines. First, the old one -- the
- one that is currently used, and corresponds to Guile 2.0. It's a
- stack machine, meaning that most instructions pop their operands from
- the top of the stack, and push results there too.
-
- Following it is the new virtual machine. It's a register machine,
- meaning that intructions address their operands by index, and store
- results in indexed slots as well. Those slots are on the stack.
- It's somewhat confusing to call it a register machine, given that the
- values are on the stack. Perhaps it needs a new name.
+#define UNPACK_8_8_8(op,a,b,c) \
+ do \
+ { \
+ a = (op >> 8) & 0xff; \
+ b = (op >> 16) & 0xff; \
+ c = op >> 24; \
+ } \
+ while (0)
- Anyway, things are in a transitional state. We're going to try to
- avoid munging the old VM very much while we flesh out the new one.
- We're also going to try to make them interoperable, as much as
- possible -- to have the old VM be able to call procedures for the new
- VM, and vice versa. This should ease the bootstrapping process. */
+#define UNPACK_8_16(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xff; \
+ b = op >> 16; \
+ } \
+ while (0)
+#define UNPACK_16_8(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xffff; \
+ b = op >> 24; \
+ } \
+ while (0)
-/* The old VM. */
-static SCM VM_NAME (SCM, SCM, SCM*, int);
-/* The new VM. */
-static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
+#define UNPACK_12_12(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xfff; \
+ b = op >> 20; \
+ } \
+ while (0)
+#define UNPACK_24(op,a) \
+ do \
+ { \
+ a = op >> 8; \
+ } \
+ while (0)
-#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
-# define VM_USE_HOOKS 0 /* Various hooks */
-#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
-# define VM_USE_HOOKS 1
-#else
-# error unknown debug engine VM_ENGINE
-#endif
/* Assign some registers by hand. There used to be a bigger list here,
but it was never tested, and in the case of x86-32, was a source of
#ifndef IP_REG
# define IP_REG
#endif
-#ifndef SP_REG
-# define SP_REG
-#endif
#ifndef FP_REG
# define FP_REG
#endif
#endif
#if VM_USE_HOOKS
-#define RUN_HOOK(h, args, n) \
+#define RUN_HOOK(exp) \
do { \
if (SCM_UNLIKELY (vp->trace_level > 0)) \
{ \
SYNC_REGISTER (); \
- vm_dispatch_hook (vm, h, args, n); \
+ exp; \
} \
} while (0)
#else
-#define RUN_HOOK(h, args, n)
+#define RUN_HOOK(exp)
#endif
-#define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
+#define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vm))
+#define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vm, arg))
#define APPLY_HOOK() \
- RUN_HOOK0 (SCM_VM_APPLY_HOOK)
+ RUN_HOOK0 (apply)
#define PUSH_CONTINUATION_HOOK() \
- RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK)
-#define POP_CONTINUATION_HOOK(vals, n) \
- RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n)
+ RUN_HOOK0 (push_continuation)
+#define POP_CONTINUATION_HOOK(old_fp) \
+ RUN_HOOK1 (pop_continuation, old_fp)
#define NEXT_HOOK() \
- RUN_HOOK0 (SCM_VM_NEXT_HOOK)
-#define ABORT_CONTINUATION_HOOK(vals, n) \
- RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n)
-#define RESTORE_CONTINUATION_HOOK() \
- RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
+ RUN_HOOK0 (next)
+#define ABORT_CONTINUATION_HOOK() \
+ RUN_HOOK0 (abort)
+#define RESTORE_CONTINUATION_HOOK() \
+ RUN_HOOK0 (restore_continuation)
#define VM_HANDLE_INTERRUPTS \
SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
-\f
-
-/* 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
-
-/* 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)); \
- } else { \
- objects = NULL; \
- } \
- } \
-}
-
-#define SYNC_BEFORE_GC() \
-{ \
- SYNC_REGISTER (); \
-}
-
-#define SYNC_ALL() \
-{ \
- SYNC_REGISTER (); \
-}
-
-\f
-/*
- * Error check
- */
-
-/* Accesses to a program's object table. */
-#define CHECK_OBJECT(_num)
-#define CHECK_FREE_VARIABLE(_num)
-
-\f
-/*
- * 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)
-
-/* 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; \
- SYNC_BEFORE_GC (); \
- for (i = n; i; i--) \
- { \
- POP (x); \
- l = scm_cons (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)
-
-\f
-/*
- * 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 (); \
-}
-
-\f
-/* 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 */
- 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 <libguile/vm-expand.h>
-#include <libguile/vm-i-system.i>
-#include <libguile/vm-i-scheme.i>
-#include <libguile/vm-i-loader.i>
-#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 (sp - SCM_I_INUM (*sp), SCM_I_INUM (*sp));
- NEXT;
- }
-
- CACHE_REGISTER ();
-
- /* Since it's possible to receive the arguments on the stack itself,
- and indeed the RTL VM invokes us that way, shuffle up the
- arguments first. */
- VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs));
- {
- int i;
- for (i = nargs - 1; i >= 0; i--)
- sp[9 + i] = argv[i];
- }
-
- /* Initial frame */
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- PUSH (boot_continuation);
- fp = sp + 1;
- ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
-
- /* MV-call frame, function & arguments */
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (ip + 1)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- PUSH (program);
- fp = sp + 1;
- sp += nargs;
-
- PUSH_CONTINUATION_HOOK ();
-
- apply:
- program = fp[-1];
- if (!SCM_PROGRAM_P (program))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- fp[-1] = SCM_STRUCT_PROCEDURE (program);
- else if (SCM_HAS_TYP7 (program, scm_tc7_rtl_program))
- {
- SCM ret;
- SYNC_ALL ();
-
- ret = RTL_VM_NAME (vm, program, fp, sp - fp + 1);
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
- }
- else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
- && SCM_SMOB_APPLICABLE_P (program))
- {
- /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
- int i;
- PUSH (SCM_BOOL_F);
- for (i = sp - fp; i >= 0; i--)
- fp[i] = fp[i - 1];
- fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
- }
- else
- {
- SYNC_ALL();
- vm_error_wrong_type_apply (program);
- }
- goto apply;
- }
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
-
- /* 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 */
-}
-
-#undef ALIGNED_P
-#undef CACHE_REGISTER
-#undef CHECK_OVERFLOW
-#undef FUNC2
-#undef INIT
-#undef INUM_MAX
-#undef INUM_MIN
-#undef jump_table
-#undef LOCAL_REF
-#undef LOCAL_SET
-#undef NEXT
-#undef NEXT_JUMP
-#undef REL
-#undef RETURN
-#undef RETURN_ONE_VALUE
-#undef RETURN_VALUE_LIST
-#undef SYNC_ALL
-#undef SYNC_BEFORE_GC
-#undef SYNC_IP
-#undef SYNC_REGISTER
-#undef VARIABLE_BOUNDP
-#undef VARIABLE_REF
-#undef VARIABLE_SET
-#undef VM_DEFINE_OP
-#undef VM_INSTRUCTION_TO_LABEL
-
-
-\f
-
/* Virtual Machine
This is Guile's new virtual machine. When I say "new", I mean
exception. */
#define SYNC_IP() \
- vp->ip = (scm_t_uint8 *) (ip)
+ vp->ip = (ip)
#define SYNC_REGISTER() \
SYNC_IP()
} while (0)
/* Reserve stack space for a frame. Will check that there is sufficient
- stack space for N locals, including the procedure, in addition to
- 3 words to set up the next frame. Invoke after preparing the new
- frame and setting the fp and ip. */
+ stack space for N locals, including the procedure. Invoke after
+ preparing the new frame and setting the fp and ip. */
#define ALLOC_FRAME(n) \
do { \
- SCM *new_sp = vp->sp = fp - 1 + n - 1; \
- CHECK_OVERFLOW (new_sp + 4); \
+ SCM *new_sp = vp->sp = LOCAL_ADDRESS (n - 1); \
+ CHECK_OVERFLOW (new_sp); \
} while (0)
/* Reset the current frame to hold N locals. Used when we know that no
stack expansion is needed. */
#define RESET_FRAME(n) \
do { \
- vp->sp = fp - 2 + n; \
+ vp->sp = LOCAL_ADDRESS (n - 1); \
} while (0)
-/* Compute the number of locals in the frame. This is equal to the
- number of actual arguments when a function is first called, plus
- one for the function. */
-#define FRAME_LOCALS_COUNT() \
- (vp->sp + 1 - (fp - 1))
+/* Compute the number of locals in the frame. At a call, this is equal
+ to the number of actual arguments when a function is first called,
+ plus one for the function. */
+#define FRAME_LOCALS_COUNT_FROM(slot) \
+ (vp->sp + 1 - LOCAL_ADDRESS (slot))
+#define FRAME_LOCALS_COUNT() \
+ FRAME_LOCALS_COUNT_FROM (0)
/* Restore registers after returning from a frame. */
#define RESTORE_FRAME() \
case opcode:
#endif
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
+#define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
+#define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
+#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define RETURN_ONE_VALUE(ret) \
do { \
SCM val = ret; \
- SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
+ SCM *old_fp = fp; \
VM_HANDLE_INTERRUPTS; \
- ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
- vp->sp = sp; \
+ ip = SCM_FRAME_RETURN_ADDRESS (fp); \
fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
- *sp = val; \
- POP_CONTINUATION_HOOK (sp, 1); \
+ /* Clear frame. */ \
+ old_fp[-1] = SCM_BOOL_F; \
+ old_fp[-2] = SCM_BOOL_F; \
+ /* Leave proc. */ \
+ SCM_FRAME_LOCAL (old_fp, 1) = val; \
+ vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
+ POP_CONTINUATION_HOOK (old_fp); \
NEXT (0); \
} while (0)
do { \
SCM vals = vals_; \
VM_HANDLE_INTERRUPTS; \
- fp[-1] = rtl_apply; \
- fp[0] = rtl_values; \
- fp[1] = vals; \
+ fp[0] = vm_builtin_apply; \
+ fp[1] = vm_builtin_values; \
+ fp[2] = vals; \
RESET_FRAME (3); \
- ip = (scm_t_uint32 *) rtl_apply_code; \
- goto op_apply; \
+ ip = (scm_t_uint32 *) vm_builtin_apply_code; \
+ goto op_tail_apply; \
} while (0)
#define BR_NARGS(rel) \
- scm_t_uint16 expected; \
- SCM_UNPACK_RTL_24 (op, expected); \
+ scm_t_uint32 expected; \
+ UNPACK_24 (op, expected); \
if (FRAME_LOCALS_COUNT() rel expected) \
{ \
scm_t_int32 offset = ip[1]; \
#define BR_UNARY(x, exp) \
scm_t_uint32 test; \
SCM x; \
- SCM_UNPACK_RTL_24 (op, test); \
+ UNPACK_24 (op, test); \
x = LOCAL_REF (test); \
if ((ip[1] & 0x1) ? !(exp) : (exp)) \
{ \
#define BR_BINARY(x, y, exp) \
scm_t_uint16 a, b; \
SCM x, y; \
- SCM_UNPACK_RTL_12_12 (op, a, b); \
+ UNPACK_12_12 (op, a, b); \
x = LOCAL_REF (a); \
y = LOCAL_REF (b); \
if ((ip[1] & 0x1) ? !(exp) : (exp)) \
{ \
scm_t_uint16 a, b; \
SCM x, y; \
- SCM_UNPACK_RTL_12_12 (op, a, b); \
+ UNPACK_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) \
+ 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. */ \
} \
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. */ \
#define ARGS1(a1) \
scm_t_uint16 dst, src; \
SCM a1; \
- SCM_UNPACK_RTL_12_12 (op, dst, src); \
+ UNPACK_12_12 (op, dst, src); \
a1 = LOCAL_REF (src)
#define ARGS2(a1, a2) \
scm_t_uint8 dst, src1, src2; \
SCM a1, a2; \
- SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
+ UNPACK_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)
/* The maximum/minimum tagged integers. */
-#define INUM_MAX (INTPTR_MAX - 1)
-#define INUM_MIN (INTPTR_MIN + scm_tc2_int)
+#define INUM_MAX \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
+#define INUM_MIN \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
+#define INUM_STEP \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
+ - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
#define BINARY_INTEGER_OP(CFUNC,SFUNC) \
{ \
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
static SCM
-RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
+VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
{
/* Instruction pointer: A pointer to the opcode that is currently
running. */
to pull all our state back from the ip/fp/sp.
*/
CACHE_REGISTER ();
- ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT());
+ ABORT_CONTINUATION_HOOK ();
NEXT (0);
}
{
SCM *base;
- /* Check that we have enough space: 4 words for the boot
- continuation, 4 + nargs for the procedure application, and 4 for
+ /* Check that we have enough space: 3 words for the boot
+ continuation, 3 + nargs for the procedure application, and 3 for
setting up a new frame. */
base = vp->sp + 1;
- CHECK_OVERFLOW (vp->sp + 4 + 4 + nargs_ + 4);
+ CHECK_OVERFLOW (vp->sp + 3 + 3 + nargs_ + 3);
/* Since it's possible to receive the arguments on the stack itself,
and indeed the regular VM invokes us that way, shuffle up the
{
int i;
for (i = nargs_ - 1; i >= 0; i--)
- base[8 + i] = argv[i];
+ base[6 + i] = argv[i];
}
/* Initial frame, saving previous fp and ip, with the boot
continuation. */
base[0] = SCM_PACK (fp); /* dynamic link */
- base[1] = SCM_PACK (0); /* the boot continuation does not return to scheme */
- 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();
+ base[1] = SCM_PACK (ip); /* ra */
+ base[2] = vm_boot_continuation;
+ fp = &base[2];
+ ip = (scm_t_uint32 *) vm_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[6] = SCM_PACK (ip); /* ra */
- base[7] = program;
- fp = vp->fp = &base[8];
+ base[3] = SCM_PACK (fp); /* dynamic link */
+ base[4] = SCM_PACK (ip); /* ra */
+ base[5] = program;
+ fp = vp->fp = &base[5];
RESET_FRAME (nargs_ + 1);
}
apply:
- while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
+ while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
{
-#if 0
SCM proc = SCM_FRAME_PROGRAM (fp);
if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
{
- fp[-1] = SCM_STRUCT_PROCEDURE (proc);
+ LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc));
continue;
}
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
{
scm_t_uint32 n = FRAME_LOCALS_COUNT();
- /* Shuffle args up, place smob in local 0. */
- CHECK_OVERFLOW (vp->sp + 1);
- vp->sp++;
+ /* Shuffle args up. */
+ RESET_FRAME (n + 1);
while (n--)
LOCAL_SET (n + 1, LOCAL_REF (n));
- fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
+ LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline);
continue;
}
SYNC_IP();
vm_error_wrong_type_apply (proc);
-#else
- SCM ret;
- SYNC_ALL ();
-
- ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
- else
- RETURN_ONE_VALUE (ret);
-#endif
}
/* Let's go! */
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
NEXT (0);
BEGIN_DISPATCH_SWITCH;
/* 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);
+ /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
- 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;
-
- SYNC_BEFORE_GC();
+ scm_t_uint32 nvals = FRAME_LOCALS_COUNT_FROM (4);
+ SCM ret;
- /* 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 (4);
+ else
+ {
+ scm_t_uint32 n;
+ ret = SCM_EOL;
+ SYNC_BEFORE_GC();
+ for (n = nvals; n > 0; n--)
+ ret = scm_cons (LOCAL_REF (4 + n - 1), ret);
+ ret = scm_values (ret);
+ }
vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
- vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+ vp->sp = SCM_FRAME_PREVIOUS_SP (fp);
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);
+ UNPACK_24 (op, proc);
+ UNPACK_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_RETURN_ADDRESS (fp, ip + 2);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2);
+
+ RESET_FRAME (nlocals);
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
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. Will reset the
+ * frame to NLOCALS.
*/
- 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;
+
+ UNPACK_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];
+ RESET_FRAME (nlocals);
- PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
NEXT (0);
}
- /* tail-call nargs:24 _:8 proc:24
+ /* tail-call/shuffle from:24
*
- * Tail-call a procedure. Requires that all of the arguments have
- * already been shuffled into position.
+ * Tail-call a procedure. The procedure should already be set to slot
+ * 0. The rest of the args are taken from the frame, starting at
+ * FROM, shuffled down to start at slot 0. This is part of the
+ * implementation of the call-with-values builtin.
*/
- VM_DEFINE_OP (5, tail_call, "tail-call", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (3, tail_call_shuffle, "tail-call/shuffle", OP1 (U8_U24))
{
- scm_t_uint32 nargs, proc;
+ scm_t_uint32 n, from, nlocals;
- SCM_UNPACK_RTL_24 (op, nargs);
- SCM_UNPACK_RTL_24 (ip[1], proc);
+ UNPACK_24 (op, from);
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);
+ VM_ASSERT (from > 0, abort ());
+ nlocals = FRAME_LOCALS_COUNT ();
+
+ for (n = 0; from + n < nlocals; n++)
+ LOCAL_SET (n + 1, LOCAL_REF (from + n));
+
+ RESET_FRAME (n + 1);
APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
NEXT (0);
}
+ /* receive dst:12 proc:12 _:8 nlocals:24
+ *
+ * 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 (4, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ {
+ scm_t_uint16 dst, proc;
+ scm_t_uint32 nlocals;
+ UNPACK_12_12 (op, dst, proc);
+ UNPACK_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);
+ }
+
+ /* receive-values proc:24 allow-extra?:1 _:7 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. Unless ALLOW-EXTRA? is true, require that the number of
+ * return values equals NVALUES exactly. After receive-values has
+ * run, the values can be copied down via `mov'.
+ */
+ VM_DEFINE_OP (5, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
+ {
+ scm_t_uint32 proc, nvalues;
+ UNPACK_24 (op, proc);
+ UNPACK_24 (ip[1], nvalues);
+ if (ip[1] & 0x1)
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
+ vm_error_not_enough_values ());
+ else
+ VM_ASSERT (FRAME_LOCALS_COUNT () == proc + 1 + nvalues,
+ vm_error_wrong_number_of_values (nvalues));
+ NEXT (2);
+ }
+
/* return src:24
*
* Return a value.
VM_DEFINE_OP (6, return, "return", OP1 (U8_U24))
{
scm_t_uint32 src;
- SCM_UNPACK_RTL_24 (op, src);
+ UNPACK_24 (op, src);
RETURN_ONE_VALUE (LOCAL_REF (src));
}
- /* return-values nvalues:24
+ /* return-values _:24
*
* 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.
+ * We also expect the frame has already been reset.
*/
- VM_DEFINE_OP (7, return_values, "return/values", OP1 (U8_U24))
+ VM_DEFINE_OP (7, return_values, "return-values", OP1 (U8_X24))
{
- scm_t_uint32 nargs;
- SCM_UNPACK_RTL_24 (op, nargs);
- RESET_FRAME (nargs + 1);
- fp[-1] = rtl_values;
- goto op_values;
+ SCM *old_fp = fp;
+
+ VM_HANDLE_INTERRUPTS;
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+
+ /* Clear stack frame. */
+ old_fp[-1] = SCM_BOOL_F;
+ old_fp[-2] = SCM_BOOL_F;
+
+ POP_CONTINUATION_HOOK (old_fp);
+
+ NEXT (0);
}
SCM pointer, ret;
SCM (*subr)();
- SCM_UNPACK_RTL_24 (op, ptr_idx);
+ UNPACK_24 (op, ptr_idx);
- pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
+ pointer = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
subr = SCM_POINTER_VALUE (pointer);
VM_HANDLE_INTERRUPTS;
SYNC_IP ();
- switch (FRAME_LOCALS_COUNT ())
+ switch (FRAME_LOCALS_COUNT_FROM (1))
{
case 0:
ret = subr ();
break;
case 1:
- ret = subr (fp[0]);
+ ret = subr (fp[1]);
break;
case 2:
- ret = subr (fp[0], fp[1]);
+ ret = subr (fp[1], fp[2]);
break;
case 3:
- ret = subr (fp[0], fp[1], fp[2]);
+ ret = subr (fp[1], fp[2], fp[3]);
break;
case 4:
- ret = subr (fp[0], fp[1], fp[2], fp[3]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4]);
break;
case 5:
- ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5]);
break;
case 6:
- ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
break;
case 7:
- ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
break;
case 8:
- ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
break;
case 9:
- ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
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]);
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9], fp[10]);
break;
default:
abort ();
scm_t_uint16 cif_idx, ptr_idx;
SCM closure, cif, pointer, ret;
- SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
+ UNPACK_12_12 (op, cif_idx, ptr_idx);
closure = LOCAL_REF (0);
- cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
- pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
+ cif = SCM_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
+ pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
SYNC_IP ();
VM_HANDLE_INTERRUPTS;
// FIXME: separate args
- ret = scm_i_foreign_call (scm_cons (cif, pointer), fp);
+ ret = scm_i_foreign_call (scm_cons (cif, pointer), LOCAL_ADDRESS (1));
// NULLSTACK_FOR_NONLOCAL_EXIT ();
SCM contregs;
scm_t_uint32 contregs_idx;
- SCM_UNPACK_RTL_24 (op, contregs_idx);
+ UNPACK_24 (op, contregs_idx);
contregs =
- SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
+ SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
SYNC_IP ();
scm_i_check_continuation (contregs);
vm_return_to_continuation (scm_i_contregs_vm (contregs),
scm_i_contregs_vm_cont (contregs),
- FRAME_LOCALS_COUNT (), fp);
+ FRAME_LOCALS_COUNT_FROM (1),
+ LOCAL_ADDRESS (1));
scm_i_reinstate_continuation (contregs);
/* no NEXT */
SCM vmcont;
scm_t_uint32 cont_idx;
- SCM_UNPACK_RTL_24 (op, cont_idx);
- vmcont = LOCAL_REF (cont_idx);
+ UNPACK_24 (op, cont_idx);
+ vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx);
SYNC_IP ();
VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
vm_error_continuation_not_rewindable (vmcont));
- vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT (), fp,
+ vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT_FROM (1),
+ LOCAL_ADDRESS (1),
¤t_thread->dynstack,
®isters);
CACHE_REGISTER ();
NEXT (0);
}
- /* apply _:24
+ /* tail-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 (12, apply, "apply", OP1 (U8_X24))
+ VM_DEFINE_OP (12, tail_apply, "tail-apply", OP1 (U8_X24))
{
- int i, list_idx, list_len, nargs;
+ int i, list_idx, list_len, nlocals;
SCM list;
VM_HANDLE_INTERRUPTS;
- VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
- nargs = FRAME_LOCALS_COUNT ();
- list_idx = nargs - 1;
+ nlocals = FRAME_LOCALS_COUNT ();
+ // At a minimum, there should be apply, f, and the list.
+ VM_ASSERT (nlocals >= 3, abort ());
+ list_idx = nlocals - 1;
list = LOCAL_REF (list_idx);
list_len = scm_ilength (list);
VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
- nargs = nargs - 2 + list_len;
- ALLOC_FRAME (nargs);
+ nlocals = nlocals - 2 + list_len;
+ ALLOC_FRAME (nlocals);
- for (i = 0; i < list_idx; i++)
- LOCAL_SET(i - 1, LOCAL_REF (i));
+ for (i = 1; i < list_idx; i++)
+ LOCAL_SET (i - 1, LOCAL_REF (i));
/* Null out these slots, just in case there are less than 2 elements
in the list. */
APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ ip = SCM_PROGRAM_CODE (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
+ * local slot 1 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))
-#if 0
{
SCM vm_cont, cont;
scm_t_dynstack *dynstack;
+ int first;
VM_HANDLE_INTERRUPTS;
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_PREVIOUS_SP (fp),
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;
- RESET_FRAME (2);
+ /* FIXME: Seems silly to capture the registers here, when they are
+ already captured in the registers local, which here we are
+ copying out to the heap; and likewise, the setjmp(®isters)
+ code already has the non-local return handler. But oh
+ well! */
+ cont = scm_i_make_continuation (&first, vm, vm_cont);
+
+ if (first)
+ {
+ LOCAL_SET (0, LOCAL_REF (1));
+ LOCAL_SET (1, cont);
+ RESET_FRAME (2);
- APPLY_HOOK ();
+ APPLY_HOOK ();
- if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
- goto apply;
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
- ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
- NEXT (0);
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ NEXT (0);
+ }
+ else
+ {
+ CACHE_REGISTER ();
+ ABORT_CONTINUATION_HOOK ();
+ NEXT (0);
+ }
}
-#else
- abort();
-#endif
- /* values _:24
+ /* abort _: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.
+ * Abort to a prompt handler. The tag is expected in r1, and the rest
+ * of the values in the frame are returned to the prompt handler.
+ * This corresponds to a tail application of abort-to-prompt.
*/
- VM_DEFINE_OP (14, values, "values", OP1 (U8_X24))
+ VM_DEFINE_OP (14, abort, "abort", OP1 (U8_X24))
{
- SCM *base = fp;
-#if VM_USE_HOOKS
- int nargs = FRAME_LOCALS_COUNT () - 1;
-#endif
+ scm_t_uint32 nlocals = FRAME_LOCALS_COUNT ();
- /* We don't do much; it's the caller that's responsible for
- shuffling values and resetting the stack. */
+ ASSERT (nlocals >= 2);
+ /* FIXME: Really we should capture the caller's registers. Until
+ then, manually advance the IP so that when the prompt resumes,
+ it continues with the next instruction. */
+ ip++;
+ SYNC_IP ();
+ vm_abort (vm, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2),
+ SCM_EOL, LOCAL_ADDRESS (0), ®isters);
- VM_HANDLE_INTERRUPTS;
- ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
- fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ /* vm_abort should not return */
+ abort ();
+ }
- /* Clear stack frame. */
- base[-1] = SCM_BOOL_F;
- base[-2] = SCM_BOOL_F;
- base[-3] = SCM_BOOL_F;
- base[-4] = SCM_BOOL_F;
+ /* builtin-ref dst:12 idx:12
+ *
+ * Load a builtin stub by index into DST.
+ */
+ VM_DEFINE_OP (15, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, idx;
- POP_CONTINUATION_HOOK (base, nargs);
+ UNPACK_12_12 (op, dst, idx);
+ LOCAL_SET (dst, scm_vm_builtin_ref (idx));
- NEXT (0);
+ NEXT (1);
}
* 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 (16, 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 (17, 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 (18, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
{
BR_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 (19, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
{
scm_t_uint32 expected;
- SCM_UNPACK_RTL_24 (op, expected);
+ UNPACK_24 (op, expected);
VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
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 (20, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
{
scm_t_uint32 expected;
- SCM_UNPACK_RTL_24 (op, expected);
+ UNPACK_24 (op, expected);
VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
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 (21, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
{
scm_t_uint32 expected;
- SCM_UNPACK_RTL_24 (op, expected);
+ UNPACK_24 (op, expected);
VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
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 (22, alloc_frame, "alloc-frame", OP1 (U8_U24))
{
scm_t_uint32 nlocals, nargs;
- SCM_UNPACK_RTL_24 (op, nlocals);
+ UNPACK_24 (op, nlocals);
nargs = FRAME_LOCALS_COUNT ();
ALLOC_FRAME (nlocals);
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 (23, reset_frame, "reset-frame", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals;
+ UNPACK_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 (24, 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);
+ UNPACK_12_12 (op, expected, nlocals);
VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
ALLOC_FRAME (expected + nlocals);
NEXT (1);
}
+ /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
+ *
+ * Find the first positional argument after NREQ. If it is greater
+ * than NPOS, jump to OFFSET.
+ *
+ * This instruction is only emitted for functions with multiple
+ * clauses, and an earlier clause has keywords and no rest arguments.
+ * See "Case-lambda" in the manual, for more on how case-lambda
+ * chooses the clause to apply.
+ */
+ VM_DEFINE_OP (25, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24))
+ {
+ scm_t_uint32 nreq, npos;
+
+ UNPACK_24 (op, nreq);
+ UNPACK_24 (ip[1], npos);
+
+ /* We can only have too many positionals if there are more
+ arguments than NPOS. */
+ if (FRAME_LOCALS_COUNT() > npos)
+ {
+ scm_t_uint32 n;
+ for (n = nreq; n < npos; n++)
+ if (scm_is_keyword (LOCAL_REF (n)))
+ break;
+ if (n == npos && !scm_is_keyword (LOCAL_REF (n)))
+ {
+ scm_t_int32 offset = ip[2];
+ offset >>= 8; /* Sign-extending shift. */
+ NEXT (offset);
+ }
+ }
+ NEXT (3);
+ }
+
/* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
* _:8 ntotal:24 kw-offset:32
*
*
* A macro-mega-instruction.
*/
- VM_DEFINE_OP (23, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
+ VM_DEFINE_OP (26, 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;
SCM kw;
char allow_other_keys, has_rest;
- SCM_UNPACK_RTL_24 (op, nreq);
+ UNPACK_24 (op, nreq);
allow_other_keys = ip[1] & 0x1;
has_rest = ip[1] & 0x2;
- SCM_UNPACK_RTL_24 (ip[1], nreq_and_opt);
- SCM_UNPACK_RTL_24 (ip[2], ntotal);
+ UNPACK_24 (ip[1], nreq_and_opt);
+ UNPACK_24 (ip[2], ntotal);
kw_offset = ip[3];
kw_bits = (scm_t_bits) (ip + kw_offset);
VM_ASSERT (!(kw_bits & 0x7), abort());
* 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 (27, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst, nargs;
SCM rest = SCM_EOL;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
nargs = FRAME_LOCALS_COUNT ();
- while (nargs-- > dst)
+ if (nargs <= dst)
{
- rest = scm_cons (LOCAL_REF (nargs), rest);
- LOCAL_SET (nargs, SCM_UNDEFINED);
+ ALLOC_FRAME (dst + 1);
+ while (nargs < dst)
+ LOCAL_SET (nargs++, SCM_UNDEFINED);
}
+ else
+ {
+ while (nargs-- > dst)
+ {
+ rest = scm_cons (LOCAL_REF (nargs), rest);
+ LOCAL_SET (nargs, SCM_UNDEFINED);
+ }
- LOCAL_SET (dst, rest);
-
- RESET_FRAME (dst + 1);
-
- 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 (dst + 1);
+ }
- RESET_FRAME (nlocals);
+ LOCAL_SET (dst, rest);
NEXT (1);
}
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (26, br, "br", OP1 (U8_L24))
+ VM_DEFINE_OP (28, br, "br", OP1 (U8_L24))
{
scm_t_int32 offset = op;
offset >>= 8; /* Sign-extending shift. */
* 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 (29, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_true (x));
}
* 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 (30, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_null (x));
}
* 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 (31, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_lisp_false (x));
}
* 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 (32, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, scm_is_pair (x));
}
* 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 (33, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_STRUCTP (x));
}
* 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 (34, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
{
BR_UNARY (x, SCM_CHARP (x));
}
* 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 (35, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
{
BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
}
* 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 (36, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y, scm_is_eq (x, y));
}
* 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 (37, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
&& 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 (38, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_BINARY (x, y,
scm_is_eq (x, y)
&& 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 (39, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (==, scm_num_eq_p);
}
* 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 (40, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
{
BR_ARITHMETIC (<, scm_less_p);
}
* 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 (41, 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);
- }
-
\f
scm_t_uint16 dst;
scm_t_uint16 src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_12_12 (op, dst, src);
LOCAL_SET (dst, LOCAL_REF (src));
NEXT (1);
scm_t_uint32 dst;
scm_t_uint32 src;
- SCM_UNPACK_RTL_24 (op, dst);
- SCM_UNPACK_RTL_24 (ip[1], src);
+ UNPACK_24 (op, dst);
+ UNPACK_24 (ip[1], src);
LOCAL_SET (dst, LOCAL_REF (src));
NEXT (2);
VM_DEFINE_OP (44, box, "box", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_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 (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 (45, 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);
+ UNPACK_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 (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-ref", var));
+ VM_ASSERT (VARIABLE_BOUNDP (var),
+ vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
LOCAL_SET (dst, VARIABLE_REF (var));
NEXT (1);
}
*
* 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 (46, box_set, "box-set!", OP1 (U8_U12_U12))
{
scm_t_uint16 dst, src;
SCM var;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_12_12 (op, dst, src);
var = LOCAL_REF (dst);
- VM_ASSERT (SCM_VARIABLEP (var), abort ());
+ VM_ASSERT (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-set!", var));
VARIABLE_SET (var, LOCAL_REF (src));
NEXT (1);
}
* 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 (47, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
{
scm_t_uint32 dst, nfree, n;
scm_t_int32 offset;
SCM closure;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
offset = ip[1];
- SCM_UNPACK_RTL_24 (ip[2], nfree);
+ UNPACK_24 (ip[2], nfree);
// FIXME: Assert range of nfree?
- closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
+ closure = scm_words (scm_tc7_program | (nfree << 16), nfree + 2);
SCM_SET_CELL_WORD_1 (closure, ip + offset);
// FIXME: Elide these initializations?
for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
+ SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
LOCAL_SET (dst, closure);
NEXT (3);
}
*
* 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 (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
- SCM_UNPACK_RTL_24 (ip[1], idx);
+ UNPACK_12_12 (op, dst, src);
+ UNPACK_24 (ip[1], idx);
/* CHECK_FREE_VARIABLE (src); */
- LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
+ LOCAL_SET (dst, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
NEXT (2);
}
*
* 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 (49, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
{
scm_t_uint16 dst, src;
scm_t_uint32 idx;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
- SCM_UNPACK_RTL_24 (ip[1], idx);
+ UNPACK_12_12 (op, dst, src);
+ UNPACK_24 (ip[1], idx);
/* CHECK_FREE_VARIABLE (src); */
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
+ SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
NEXT (2);
}
* 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 (50, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
{
scm_t_uint8 dst;
scm_t_bits val;
- SCM_UNPACK_RTL_8_16 (op, dst, val);
+ UNPACK_8_16 (op, dst, val);
LOCAL_SET (dst, SCM_PACK (val));
NEXT (1);
}
* 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 (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
{
- scm_t_uint8 dst;
+ scm_t_uint32 dst;
scm_t_bits val;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
val = ip[1];
LOCAL_SET (dst, SCM_PACK (val));
NEXT (2);
*
* 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 (52, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
{
- scm_t_uint8 dst;
+ scm_t_uint32 dst;
scm_t_bits val;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
#if SIZEOF_SCM_T_BITS > 4
val = ip[1];
val <<= 32;
* 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 (53, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 offset;
scm_t_uint32* loc;
scm_t_bits unpacked;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
offset = ip[1];
loc = ip + offset;
unpacked = (scm_t_bits) loc;
* 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 (54, static_ref, "static-ref", OP2 (U8_U24, S32))
{
scm_t_uint32 dst;
scm_t_int32 offset;
scm_t_uint32* loc;
scm_t_uintptr loc_bits;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
offset = ip[1];
loc = ip + offset;
loc_bits = (scm_t_uintptr) loc;
* 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 (55, static_set, "static-set!", OP2 (U8_U24, LO32))
{
scm_t_uint32 src;
scm_t_int32 offset;
scm_t_uint32* loc;
- SCM_UNPACK_RTL_24 (op, src);
+ UNPACK_24 (op, src);
offset = ip[1];
loc = ip + offset;
VM_ASSERT (ALIGNED_P (loc, SCM), abort());
NEXT (2);
}
- /* link-procedure! src:24 offset:32
+ /* static-patch! _:24 dst-offset:32 src-offset:32
*
- * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
- * words away from the current instruction pointer. OFFSET is a
- * signed value.
+ * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
+ * are signed 32-bit values, indicating a memory address as a number
+ * of 32-bit words away from the current instruction pointer.
*/
- VM_DEFINE_OP (57, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
+ VM_DEFINE_OP (56, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32))
{
- scm_t_uint32 src;
- scm_t_int32 offset;
- scm_t_uint32* loc;
+ scm_t_int32 dst_offset, src_offset;
+ void *src;
+ void** dst_loc;
- SCM_UNPACK_RTL_24 (op, src);
- offset = ip[1];
- loc = ip + offset;
+ dst_offset = ip[1];
+ src_offset = ip[2];
- SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
+ dst_loc = (void **) (ip + dst_offset);
+ src = ip + src_offset;
+ VM_ASSERT (ALIGNED_P (dst_loc, void*), abort());
- NEXT (2);
+ *dst_loc = src;
+
+ NEXT (3);
}
\f
(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 (57, current_module, "current-module", OP1 (U8_U24) | OP_DST)
{
scm_t_uint32 dst;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
SYNC_IP ();
LOCAL_SET (dst, scm_current_module ());
NEXT (1);
}
- /* resolve dst:8 mod:8 sym:8
- *
- * 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 dst:24 bound?:1 _:7 sym:24
*
- * 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 (58, 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);
+ UNPACK_24 (op, dst);
+ UNPACK_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[0], LOCAL_REF (sym)));
+ LOCAL_SET (dst, var);
- NEXT (1);
+ NEXT (2);
}
- /* define sym:12 val:12
+ /* 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 (61, define, "define", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (59, define, "define!", OP1 (U8_U12_U12))
{
scm_t_uint16 sym, val;
- SCM_UNPACK_RTL_12_12 (op, sym, val);
+ UNPACK_12_12 (op, sym, val);
SYNC_IP ();
scm_define (LOCAL_REF (sym), LOCAL_REF (val));
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 (60, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
SCM *var_loc;
SCM var;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
var_offset = ip[1];
var_loc_u32 = ip + var_offset;
VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
mod = *((SCM *) mod_loc);
sym = *((SCM *) sym_loc);
- var = scm_module_lookup (mod, sym);
- VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
-
- *var_loc = var;
- }
-
- LOCAL_SET (dst, VARIABLE_REF (var));
- NEXT (4);
- }
-
- /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
- *
- * 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);
+ /* If the toplevel scope was captured before modules were
+ booted, use the root module. */
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
var = scm_module_lookup (mod, sym);
+ if (ip[4] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[0], sym));
*var_loc = var;
}
- VARIABLE_SET (var, LOCAL_REF (src));
- NEXT (4);
+ LOCAL_SET (dst, var);
+ NEXT (5);
}
- /* module-ref dst: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
*
- * 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 (61, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
{
scm_t_uint32 dst;
scm_t_int32 var_offset;
SCM *var_loc;
SCM var;
- SCM_UNPACK_RTL_24 (op, dst);
+ UNPACK_24 (op, dst);
var_offset = ip[1];
var_loc_u32 = ip + var_offset;
VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
modname = SCM_PACK ((scm_t_bits) modname_words);
sym = *((SCM *) sym_loc);
- if (scm_is_true (SCM_CAR (modname)))
+ if (!scm_module_system_booted_p)
+ {
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
+ ASSERT
+ (scm_is_true
+ scm_equal_p (modname,
+ scm_list_2 (SCM_BOOL_T,
+ scm_from_utf8_symbol ("guile"))));
+#endif
+ var = scm_lookup (sym);
+ }
+ else if (scm_is_true (SCM_CAR (modname)))
var = scm_public_lookup (SCM_CDR (modname), sym);
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[0], sym));
*var_loc = var;
}
- VARIABLE_SET (var, LOCAL_REF (src));
- NEXT (4);
+ LOCAL_SET (dst, var);
+ NEXT (5);
}
\f
* The dynamic environment
*/
- /* prompt tag:24 flags:8 handler-offset:24
+ /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _: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 a multiple-value return.
+ * will expect a multiple-value return as if from a call with the
+ * procedure at PROC-SLOT.
*/
- VM_DEFINE_OP (66, prompt, "prompt", OP2 (U8_U24, U8_L24))
-#if 0
+ VM_DEFINE_OP (62, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
{
- scm_t_uint32 tag;
+ scm_t_uint32 tag, proc_slot;
scm_t_int32 offset;
scm_t_uint8 escape_only_p;
scm_t_dynstack_prompt_flags flags;
- SCM_UNPACK_RTL_24 (op, tag);
- escape_only_p = ip[1] & 0xff;
- offset = ip[1];
+ UNPACK_24 (op, tag);
+ escape_only_p = ip[1] & 0x1;
+ UNPACK_24 (ip[1], proc_slot);
+ 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;
scm_dynstack_push_prompt (¤t_thread->dynstack, flags,
LOCAL_REF (tag),
- fp, vp->sp, ip + offset, ®isters);
- NEXT (2);
+ fp,
+ LOCAL_ADDRESS (proc_slot),
+ ip + offset,
+ ®isters);
+ NEXT (3);
}
-#else
- abort();
-#endif
/* wind winder:12 unwinder:12
*
* 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 (63, wind, "wind", OP1 (U8_U12_U12))
{
scm_t_uint16 winder, unwinder;
- SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
+ UNPACK_12_12 (op, winder, unwinder);
scm_dynstack_push_dynwind (¤t_thread->dynstack,
LOCAL_REF (winder), LOCAL_REF (unwinder));
NEXT (1);
}
- /* abort tag:24 _:8 from:24
- *
- * Return a number of values to a prompt handler. The values are
- * expected in a frame pushed on at FROM.
- */
- VM_DEFINE_OP (68, abort, "abort", OP2 (U8_U24, X8_U24))
-#if 0
- {
- scm_t_uint32 tag, from, nvalues;
- SCM *base;
-
- SCM_UNPACK_RTL_24 (op, tag);
- SCM_UNPACK_RTL_24 (ip[1], from);
- base = (fp - 1) + from + 3;
- nvalues = FRAME_LOCALS_COUNT () - from - 3;
-
- SYNC_IP ();
- vm_abort (vm, LOCAL_REF (tag), base, nvalues, ®isters);
-
- /* vm_abort should not return */
- abort ();
- }
-#else
- abort();
-#endif
-
/* unwind _:24
*
* 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 (64, unwind, "unwind", OP1 (U8_X24))
{
scm_dynstack_pop (¤t_thread->dynstack);
NEXT (1);
* 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 (65, push_fluid, "push-fluid", OP1 (U8_U12_U12))
{
scm_t_uint32 fluid, value;
- SCM_UNPACK_RTL_12_12 (op, fluid, value);
+ UNPACK_12_12 (op, fluid, value);
scm_dynstack_push_fluid (¤t_thread->dynstack,
- fp[fluid], fp[value],
+ LOCAL_REF (fluid), LOCAL_REF (value),
current_thread->dynamic_state);
NEXT (1);
}
* 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 (66, pop_fluid, "pop-fluid", OP1 (U8_X24))
{
/* This function must not allocate. */
scm_dynstack_unwind_fluid (¤t_thread->dynstack,
*
* 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 (67, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
size_t num;
SCM fluid, fluids;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_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))
*
* 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 (68, fluid_set, "fluid-set", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
size_t num;
SCM fluid, fluids;
- SCM_UNPACK_RTL_12_12 (op, a, b);
+ UNPACK_12_12 (op, a, b);
fluid = LOCAL_REF (a);
fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
*
* 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 (69, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (str);
if (SCM_LIKELY (scm_is_string (str)))
* 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 (70, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (str, idx);
*
* 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 (71, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_12_12 (op, dst, src);
SYNC_IP ();
LOCAL_SET (dst,
scm_string_to_number (LOCAL_REF (src),
*
* 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 (72, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_12_12 (op, dst, src);
SYNC_IP ();
LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
NEXT (1);
*
* 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 (73, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
+ UNPACK_12_12 (op, dst, src);
SYNC_IP ();
LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
NEXT (1);
*
* 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 (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
RETURN (scm_cons (x, y));
*
* Place the car of SRC in DST.
*/
- VM_DEFINE_OP (80, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (75, car, "car", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "car");
*
* Place the cdr of SRC in DST.
*/
- VM_DEFINE_OP (81, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (76, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
VM_VALIDATE_PAIR (x, "cdr");
*
* Set the car of DST to SRC.
*/
- VM_DEFINE_OP (82, set_car, "set-car!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (77, set_car, "set-car!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
- SCM_UNPACK_RTL_12_12 (op, a, b);
+ UNPACK_12_12 (op, a, b);
x = LOCAL_REF (a);
y = LOCAL_REF (b);
VM_VALIDATE_PAIR (x, "set-car!");
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (83, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (78, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
{
scm_t_uint16 a, b;
SCM x, y;
- SCM_UNPACK_RTL_12_12 (op, a, b);
+ UNPACK_12_12 (op, a, b);
x = LOCAL_REF (a);
y = LOCAL_REF (b);
VM_VALIDATE_PAIR (x, "set-car!");
*
* 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 (79, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (+, scm_sum);
}
*
* 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 (80, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
- /* Check for overflow. */
- if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) < INUM_MAX))
+ /* Check for overflow. We must avoid overflow in the signed
+ addition below, even if X is not an inum. */
+ if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
{
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);
+ /* Add 1 to the integer without untagging. */
+ result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
if (SCM_LIKELY (SCM_I_INUMP (result)))
RETURN (result);
*
* 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 (81, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
{
BINARY_INTEGER_OP (-, scm_difference);
}
*
* 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 (82, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (x);
- /* Check for underflow. */
- if (SCM_LIKELY ((scm_t_intptr) SCM_UNPACK (x) > INUM_MIN))
+ /* Check for overflow. We must avoid overflow in the signed
+ subtraction below, even if X is not an inum. */
+ if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
{
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);
+ /* Substract 1 from the integer without untagging. */
+ result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
if (SCM_LIKELY (SCM_I_INUMP (result)))
RETURN (result);
*
* 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 (83, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
*
* 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 (84, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
*
* 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 (85, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
*
* 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 (86, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
*
* 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 (87, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
SYNC_IP ();
*
* 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 (88, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
{
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)));
+ RETURN (SCM_I_MAKINUM
+ (SCM_SRS (SCM_I_INUM (x),
+ (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
+ ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
else
/* Left shift. See comments in scm_ash. */
{
*
* 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 (89, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) & SCM_I_INUM (y)));
+ /* Compute bitwise AND without untagging */
+ RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
SYNC_IP ();
RETURN (scm_logand (x, y));
}
*
* 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 (90, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) | SCM_I_INUM (y)));
+ /* Compute bitwise OR without untagging */
+ RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
SYNC_IP ();
RETURN (scm_logior (x, y));
}
*
* 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 (91, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
{
ARGS2 (x, y);
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
RETURN (scm_logxor (x, y));
}
+ /* make-vector/immediate dst:8 length:8 init:8
+ *
+ * Make a short vector of known size and write it to DST. The vector
+ * will have space for LENGTH slots, an immediate value. They will be
+ * filled with the value in slot INIT.
+ */
+ VM_DEFINE_OP (92, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, init;
+ scm_t_int32 length, n;
+ SCM val, vector;
+
+ UNPACK_8_8_8 (op, dst, length, init);
+
+ val = LOCAL_REF (init);
+ vector = scm_words (scm_tc7_vector | (length << 8), length + 1);
+ for (n = 0; n < length; n++)
+ SCM_SIMPLE_VECTOR_SET (vector, n, val);
+ LOCAL_SET (dst, vector);
+ NEXT (1);
+ }
+
/* vector-length dst:12 src:12
*
* 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 (93, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (vect);
if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
* 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 (94, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
}
}
- /* constant-vector-ref dst:8 src:8 idx:8
+ /* vector-ref/immediate 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 (99, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (95, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, src, idx;
SCM v;
- SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
+ UNPACK_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)))
*
* 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 (96, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx_var, src;
SCM vect, idx, val;
scm_t_signed_bits i = 0;
- SCM_UNPACK_RTL_8_8_8 (op, dst, idx_var, src);
+ UNPACK_8_8_8 (op, dst, idx_var, src);
vect = LOCAL_REF (dst);
idx = LOCAL_REF (idx_var);
val = LOCAL_REF (src);
NEXT (1);
}
+ /* vector-set!/immediate dst:8 idx:8 src:8
+ *
+ * Store SRC into the vector DST at index IDX. Here IDX is an
+ * immediate value.
+ */
+ VM_DEFINE_OP (97, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx, src;
+ SCM vect, val;
+
+ UNPACK_8_8_8 (op, dst, idx, src);
+ vect = LOCAL_REF (dst);
+ val = LOCAL_REF (src);
+
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
+ && idx < SCM_I_VECTOR_LENGTH (vect)))
+ SCM_I_VECTOR_WELTS (vect)[idx] = val;
+ else
+ {
+ SYNC_IP ();
+ scm_vector_set_x (vect, scm_from_uint8 (idx), val);
+ }
+ NEXT (1);
+ }
+
\f
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (98, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
- /* allocate-struct dst:8 vtable:8 nfields:8
+ /* allocate-struct/immediate dst:8 vtable:8 nfields:8
*
* Allocate a new struct with VTABLE, and place it in DST. The struct
* 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 (99, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
{
scm_t_uint8 dst, vtable, nfields;
SCM ret;
- SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
+ UNPACK_8_8_8 (op, dst, vtable, nfields);
SYNC_IP ();
ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
NEXT (1);
}
- /* struct-ref dst:8 src:8 idx:8
+ /* struct-ref/immediate dst:8 src:8 idx:8
*
* Fetch the item at slot IDX in the struct in SRC, and store it
- * in DST.
+ * in DST. IDX is an immediate unsigned 8-bit value.
*/
- VM_DEFINE_OP (103, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ VM_DEFINE_OP (100, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
{
- ARGS2 (obj, pos);
+ scm_t_uint8 dst, src, idx;
+ SCM obj;
+
+ UNPACK_8_8_8 (op, dst, src, idx);
+
+ obj = LOCAL_REF (src);
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]));
- }
- }
+ && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size)))
+ RETURN (SCM_STRUCT_SLOT_REF (obj, idx));
SYNC_IP ();
- RETURN (scm_struct_ref (obj, pos));
+ RETURN (scm_struct_ref (obj, SCM_I_MAKINUM (idx)));
}
- /* struct-set! dst:8 idx:8 src:8
+ /* struct-set!/immediate dst:8 idx:8 src:8
*
- * Store SRC into the struct DST at slot IDX.
+ * Store SRC into the struct DST at slot IDX. IDX is an immediate
+ * unsigned 8-bit value.
*/
- VM_DEFINE_OP (104, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (101, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8))
{
scm_t_uint8 dst, idx, src;
- SCM obj, pos, val;
-
- SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
+ SCM obj, val;
+
+ UNPACK_8_8_8 (op, dst, idx, 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)))
+ && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size)))
{
- 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 (1);
- }
+ SCM_STRUCT_SLOT_SET (obj, idx, val);
+ NEXT (1);
}
SYNC_IP ();
- scm_struct_set_x (obj, pos, val);
+ scm_struct_set_x (obj, SCM_I_MAKINUM (idx), val);
NEXT (1);
}
*
* Store the vtable of SRC into DST.
*/
- VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (102, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
* 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 (103, 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);
+ UNPACK_8_8_8 (op, dst, src, idx);
LOCAL_SET (dst,
SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
NEXT (1);
* 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 (104, 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);
+ UNPACK_8_8_8 (op, dst, idx, src);
SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
NEXT (1);
}
* 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 (105, 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;
scm_t_uint32 len;
- SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape);
+ UNPACK_8_8_8 (op, dst, type, shape);
offset = ip[1];
len = ip[2];
SYNC_IP ();
*
* 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 (106, 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);
- SCM_UNPACK_RTL_12_12 (ip[1], fill, bounds);
+ UNPACK_12_12 (op, dst, type);
+ UNPACK_12_12 (ip[1], fill, bounds);
SYNC_IP ();
LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
LOCAL_REF (bounds)));
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 (107, 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 (108, 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 (109, 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 (110, 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 (111, 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 (112, 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 (113, 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 (114, 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 (115, 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 (116, 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
SCM bv, scm_idx, val; \
scm_t_ ## type *int_ptr; \
\
- SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
+ UNPACK_8_8_8 (op, dst, idx, src); \
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
SCM bv, scm_idx, val; \
scm_t_ ## type *int_ptr; \
\
- SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
+ UNPACK_8_8_8 (op, dst, idx, src); \
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
SCM bv, scm_idx, val; \
type *float_ptr; \
\
- SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
+ UNPACK_8_8_8 (op, dst, idx, src); \
bv = LOCAL_REF (dst); \
scm_idx = LOCAL_REF (idx); \
val = LOCAL_REF (src); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
i = SCM_I_INUM (scm_idx); \
float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
\
NEXT (1); \
} while (0)
- VM_DEFINE_OP (120, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ VM_DEFINE_OP (117, 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 (118, 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 (119, 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 (120, 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 (121, 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 (122, 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 (123, 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 (124, 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 (125, 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 (126, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
END_DISPATCH_SWITCH;
#undef RETURN_VALUE_LIST
#undef RUN_HOOK
#undef RUN_HOOK0
+#undef RUN_HOOK1
#undef SYNC_ALL
#undef SYNC_BEFORE_GC
#undef SYNC_IP
#undef SYNC_REGISTER
+#undef UNPACK_8_8_8
+#undef UNPACK_8_16
+#undef UNPACK_16_8
+#undef UNPACK_12_12
+#undef UNPACK_24
#undef VARIABLE_BOUNDP
#undef VARIABLE_REF
#undef VARIABLE_SET
HCoop / bpt / guile.git / blobdiff