/* 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.
-
- 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. */
-
-
-/* The old VM. */
-static SCM VM_NAME (SCM, SCM, SCM*, int);
-/* The new VM. */
-static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
-
-
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
# define VM_USE_HOOKS 0 /* Various hooks */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#ifndef IP_REG
# define IP_REG
#endif
-#ifndef SP_REG
-# define SP_REG
-#endif
#ifndef FP_REG
# define FP_REG
#endif
RUN_HOOK0 (SCM_VM_APPLY_HOOK)
#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)
+#define POP_CONTINUATION_HOOK(old_fp) \
+ RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, \
+ &SCM_FRAME_LOCAL (old_fp, 1), \
+ SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1)
#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 ABORT_CONTINUATION_HOOK() \
+ RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, \
+ LOCAL_ADDRESS (1), \
+ FRAME_LOCALS_COUNT () - 1)
#define RESTORE_CONTINUATION_HOOK() \
RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
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 FREE_VARIABLE_REF
-#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
relative to the current virtual machine. At some point it will
become "the" virtual machine, and we'll delete this paragraph. As
such, the rest of the comments speak as if there's only one VM.
+ In difference from the old VM, local 0 is the procedure, and the
+ first argument is local 1. At some point in the future we should
+ change the fp to point to the procedure and not to local 1.
<more overview here>
*/
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, not including the procedure, in addition to
- 4 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; \
- 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 - 1 + 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. */
-#define FRAME_LOCALS_COUNT() \
- (vp->sp + 1 - fp)
+/* 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)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = 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 VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-#define FREE_VARIABLE_REF(i) SCM_RTL_PROGRAM_FREE_VARIABLE_REF (SCM_FRAME_PROGRAM (fp), i)
#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; \
- RESET_FRAME (2); \
- ip = (scm_t_uint32 *) rtl_apply_code; \
- goto op_apply; \
+ fp[0] = vm_builtin_apply; \
+ fp[1] = vm_builtin_values; \
+ fp[2] = vals; \
+ RESET_FRAME (3); \
+ ip = (scm_t_uint32 *) vm_builtin_apply_code; \
+ goto op_tail_apply; \
} while (0)
#define BR_NARGS(rel) \
- scm_t_uint16 expected; \
+ scm_t_uint32 expected; \
SCM_UNPACK_RTL_24 (op, expected); \
if (FRAME_LOCALS_COUNT() rel expected) \
{ \
{ \
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. */ \
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) \
{ \
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] = rtl_boot_continuation;
+ fp = &base[2];
+ ip = (scm_t_uint32 *) rtl_boot_continuation_code;
/* MV-call frame, function & arguments */
- base[4] = SCM_PACK (fp); /* dynamic link */
- base[5] = SCM_PACK (ip - 1); /* in RTL programs, MVRA precedes RA by one */
- base[6] = SCM_PACK (ip); /* ra */
- base[7] = program;
- fp = vp->fp = &base[8];
- RESET_FRAME (nargs_);
+ 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));
- LOCAL_SET (0, proc);
- 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 ());
-
- 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 r0.
+ * 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 (0);
+ /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
- vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
- vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- return ret;
- }
-
- /* halt/values _:24
- *
- * Bring the VM to a halt, returning all the values on the stack.
- */
- VM_DEFINE_OP (1, halt_values, "halt/values", OP1 (U8_X24))
- {
- scm_t_ptrdiff n;
- SCM *base;
- SCM ret = SCM_EOL;
-
- SYNC_BEFORE_GC();
+ scm_t_uint32 nvals = FRAME_LOCALS_COUNT_FROM (4);
+ SCM ret;
- base = fp + 4;
- n = FRAME_LOCALS_COUNT ();
- while (n--)
- ret = scm_cons (base[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);
+ return ret;
}
- /* call from:24 _:8 proc:24 _:8 nargs:24 arg0:24 0:8 ...
+ /* call proc:24 _:8 nlocals:24
*
- * Call a procedure. Push a call frame on at FROM, saving the return
- * address and the fp. Parse out NARGS, and push the procedure and
- * arguments. All arguments except for RETURN-LOC are 24-bit values.
- * FROM, PROC, and NARGS are in the upper 24 bits of the words. The
- * ARGN... are in the lower 24 bits, with the upper 8 bits being 0.
+ * 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 (2, call, "call", OP3 (U8_U24, X8_U24, X8_R24))
+ VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
{
- scm_t_uint32 from, proc, nargs, n;
+ scm_t_uint32 proc, nlocals;
SCM *old_fp = fp;
- SCM_UNPACK_RTL_24 (op, from);
- SCM_UNPACK_RTL_24 (ip[1], proc);
- SCM_UNPACK_RTL_24 (ip[2], nargs);
+ SCM_UNPACK_RTL_24 (op, proc);
+ SCM_UNPACK_RTL_24 (ip[1], nlocals);
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 4;
+ fp = vp->fp = old_fp + proc;
SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 3 + nargs);
- SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 4 + nargs);
- fp[-1] = old_fp[proc];
- ALLOC_FRAME (nargs);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2);
- for (n = 0; n < nargs; n++)
- LOCAL_SET (n, old_fp[ip[3 + n]]);
+ 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
+ /* tail-call nlocals: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.
- *
- * 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 (3, call_values, "call/values", OP2 (U8_U24, X8_U24))
+ VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
{
- scm_t_uint32 from, proc;
- SCM *old_fp = fp;
-
- SCM_UNPACK_RTL_24 (op, from);
- SCM_UNPACK_RTL_24 (ip[1], proc);
+ scm_t_uint32 nlocals;
+
+ SCM_UNPACK_RTL_24 (op, nlocals);
VM_HANDLE_INTERRUPTS;
- fp = vp->fp = old_fp + from + 4;
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
- SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 3);
- fp[-1] = old_fp[proc];
+ 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 (4, 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);
+ SCM_UNPACK_RTL_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);
+ 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;
+ SCM_UNPACK_RTL_12_12 (op, dst, proc);
+ SCM_UNPACK_RTL_24 (ip[1], nlocals);
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ());
+ LOCAL_SET (dst, LOCAL_REF (proc + 1));
+ RESET_FRAME (nlocals);
+ NEXT (2);
+ }
+
+ /* 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;
+ SCM_UNPACK_RTL_24 (op, proc);
+ SCM_UNPACK_RTL_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 (5, return, "return", OP1 (U8_U24))
+ VM_DEFINE_OP (6, return, "return", OP1 (U8_U24))
{
scm_t_uint32 src;
SCM_UNPACK_RTL_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 (6, 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);
- 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);
}
* calling frame. This instruction is part of the trampolines
* created in gsubr.c, and is not generated by the compiler.
*/
- VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
+ VM_DEFINE_OP (8, subr_call, "subr-call", OP1 (U8_U24))
{
scm_t_uint32 ptr_idx;
SCM pointer, ret;
SCM_UNPACK_RTL_24 (op, ptr_idx);
- pointer = FREE_VARIABLE_REF (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 ();
* part of the trampolines created by the FFI, and is not generated by
* the compiler.
*/
- VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
+ VM_DEFINE_OP (9, foreign_call, "foreign-call", OP1 (U8_U12_U12))
{
scm_t_uint16 cif_idx, ptr_idx;
- SCM cif, pointer, ret;
+ SCM closure, cif, pointer, ret;
SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
- cif = FREE_VARIABLE_REF (cif_idx);
- pointer = FREE_VARIABLE_REF (ptr_idx);
+ closure = LOCAL_REF (0);
+ 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 ();
* the implementation of undelimited continuations, and is not
* generated by the compiler.
*/
- VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
+ VM_DEFINE_OP (10, continuation_call, "continuation-call", OP1 (U8_U24))
{
SCM contregs;
scm_t_uint32 contregs_idx;
SCM_UNPACK_RTL_24 (op, contregs_idx);
- contregs = FREE_VARIABLE_REF (contregs_idx);
+ contregs =
+ 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 */
* instruction is part of the implementation of partial continuations,
* and is not generated by the compiler.
*/
- VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
+ VM_DEFINE_OP (11, compose_continuation, "compose-continuation", OP1 (U8_U24))
{
SCM vmcont;
scm_t_uint32 cont_idx;
SCM_UNPACK_RTL_24 (op, cont_idx);
- vmcont = LOCAL_REF (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 (11, 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++)
- fp[i - 1] = fp[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. */
- fp[list_idx - 1] = SCM_UNDEFINED;
- fp[list_idx] = SCM_UNDEFINED;
+ LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
+ LOCAL_SET (list_idx, SCM_UNDEFINED);
for (i = 0; i < list_len; i++, list = SCM_CDR (list))
- fp[list_idx - 1 + i] = SCM_CAR (list);
+ LOCAL_SET (list_idx - 1 + i, SCM_CAR (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 (12, call_cc, "call/cc", OP1 (U8_X24))
-#if 0
+ VM_DEFINE_OP (13, call_cc, "call/cc", OP1 (U8_X24))
{
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 (1);
+ /* 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 (13, 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 ();
-#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);
+ SCM_UNPACK_RTL_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 (14, 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 (15, 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 (16, 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 (17, 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);
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (18, 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);
vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
NEXT (1);
}
- VM_DEFINE_OP (19, 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);
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.
+ * were passed as arguments and procedure.
*/
- VM_DEFINE_OP (20, 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);
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;
+ SCM_UNPACK_RTL_24 (op, nlocals);
+ RESET_FRAME (nlocals);
+ NEXT (1);
+ }
+
/* assert-nargs-ee/locals expected:12 nlocals:12
*
* Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
* number of locals reserved is EXPECTED + NLOCALS.
*/
- VM_DEFINE_OP (21, 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);
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;
+
+ SCM_UNPACK_RTL_24 (op, nreq);
+ SCM_UNPACK_RTL_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 (22, 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;
break;
}
VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
- vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp)));
+ vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp),
+ LOCAL_REF (ntotal + n)));
n++;
}
else
- VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp)));
+ VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
+ LOCAL_REF (ntotal + n)));
if (has_rest)
{
* Collect any arguments at or above DST into a list, and store that
* list at DST.
*/
- VM_DEFINE_OP (23, 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);
nargs = FRAME_LOCALS_COUNT ();
- while (nargs-- > dst)
- {
- rest = scm_cons (LOCAL_REF (nargs), rest);
- LOCAL_SET (nargs, SCM_UNDEFINED);
+ if (nargs <= dst)
+ {
+ 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);
+ }
+
+ RESET_FRAME (dst + 1);
}
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 (24, drop_values, "drop-values", OP1 (U8_U24))
- {
- scm_t_bits nlocals;
-
- SCM_UNPACK_RTL_24 (op, nlocals);
-
- RESET_FRAME (nlocals);
-
NEXT (1);
}
* Add OFFSET, a signed 24-bit number, to the current instruction
* pointer.
*/
- VM_DEFINE_OP (25, 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 (26, 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 (27, 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 (28, 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 (29, 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 (30, 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 (31, 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 (32, 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 (33, 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 (34, 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 (35, 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 (36, 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 (37, 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 (38, 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 (39, 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 (40, br_if_ge, "br-if->=", OP2 (U8_U12_U12, X8_L24))
- {
- BR_ARITHMETIC (>=, scm_geq_p);
- }
-
\f
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (41, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ VM_DEFINE_OP (42, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
{
scm_t_uint16 dst;
scm_t_uint16 src;
*
* Copy a value from one local slot to another.
*/
- VM_DEFINE_OP (42, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ VM_DEFINE_OP (43, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
{
scm_t_uint32 dst;
scm_t_uint32 src;
*
* Create a new variable holding SRC, and place it in DST.
*/
- VM_DEFINE_OP (43, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ 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);
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 (44, 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
SCM var;
SCM_UNPACK_RTL_12_12 (op, dst, src);
var = LOCAL_REF (src);
- VM_ASSERT (SCM_VARIABLEP (var), abort ());
- if (SCM_UNLIKELY (!VARIABLE_BOUNDP (var)))
- {
- SCM var_name;
- /* Attempt to provide the variable name in the error message. */
- SYNC_IP ();
- var_name = scm_module_reverse_lookup (scm_current_module (), var);
- vm_error_unbound (SCM_FRAME_PROGRAM (fp), scm_is_true (var_name) ? var_name : var);
- }
+ VM_ASSERT (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 (46, 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);
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);
}
- /* free-ref dst:12 src:12
- *
- * Load free variable SRC into local slot DST.
- */
- VM_DEFINE_OP (47, free_ref, "free-ref", OP1 (U8_U12_U12) | OP_DST)
- {
- scm_t_uint16 dst, src;
- SCM_UNPACK_RTL_12_12 (op, dst, src);
- CHECK_FREE_VARIABLE (src);
- LOCAL_SET (dst, FREE_VARIABLE_REF (src));
- NEXT (1);
- }
-
- /* make-closure dst:24 offset:32 _:8 nfree:24 free0:24 0:8 ...
+ /* make-closure dst:24 offset:32 _:8 nfree:24
*
* Make a new closure, and write it to DST. The code for the closure
* will be found at OFFSET words from the current IP. OFFSET is a
- * signed 32-bit integer. The registers for the NFREE free variables
- * follow.
+ * 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_R24) | 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_UNPACK_RTL_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, LOCAL_REF (ip[n + 3]));
+ SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
LOCAL_SET (dst, closure);
- NEXT (nfree + 3);
+ NEXT (3);
}
- /* fix-closure dst:24 _:8 nfree:24 free0:24 0:8 ...
+ /* free-ref dst:12 src:12 _:8 idx:24
*
- * "Fix" a closure. This is used for lambda expressions bound in a
- * <fix>, but which are not always called in tail position. In that
- * case we allocate the closures first, then destructively update their
- * free variables to point to each other. NFREE and the locals FREE0...
- * are as in make-closure.
+ * Load free variable IDX from the closure SRC into local slot DST.
*/
- VM_DEFINE_OP (49, fix_closure, "fix-closure", OP2 (U8_U24, X8_R24))
+ VM_DEFINE_OP (48, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
{
- scm_t_uint32 dst, nfree, n;
- SCM closure;
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ SCM_UNPACK_RTL_12_12 (op, dst, src);
+ SCM_UNPACK_RTL_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ LOCAL_SET (dst, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
+ NEXT (2);
+ }
- SCM_UNPACK_RTL_24 (op, dst);
- SCM_UNPACK_RTL_24 (ip[1], nfree);
- closure = LOCAL_REF (dst);
- for (n = 0; n < nfree; n++)
- SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, LOCAL_REF (ip[n + 2]));
- NEXT (nfree + 2);
+ /* free-set! dst:12 src:12 _8 idx:24
+ *
+ * Set free variable IDX from the closure DST to SRC.
+ */
+ 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);
+ /* CHECK_FREE_VARIABLE (src); */
+ SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
+ NEXT (2);
}
*/
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);
*/
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);
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 (56, 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
NEXT (1);
}
- /* resolve dst:8 mod:8 sym:8
- *
- * Resolve SYM in MOD, and place the resulting variable in DST.
- */
- VM_DEFINE_OP (58, 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 (59, 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);
+ SCM_UNPACK_RTL_24 (op, dst);
+ SCM_UNPACK_RTL_24 (ip[1], sym);
SYNC_IP ();
- mod = scm_resolve_module (LOCAL_REF (name));
- if (public)
- mod = scm_module_public_interface (mod);
- LOCAL_SET (dst, mod);
+ var = scm_lookup (LOCAL_REF (sym));
+ if (ip[1] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var),
+ vm_error_unbound (fp[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 (60, 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);
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 (61, 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;
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 (62, 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 (63, 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;
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 (64, 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 (65, 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];
+ escape_only_p = ip[1] & 0x1;
+ SCM_UNPACK_RTL_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 (66, 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);
NEXT (1);
}
- /* abort tag:24 _:8 nvalues:24 val0:24 0:8 val1:24 0:8 ...
- *
- * Return a number of values to a prompt handler. The values VAL0,
- * VAL1, etc are 24-bit values, in the lower 24 bits of their words.
- * The upper 8 bits are 0.
- */
- VM_DEFINE_OP (67, abort, "abort", OP2 (U8_U24, X8_R24))
-#if 0
- {
- scm_t_uint32 tag, nvalues;
-
- SCM_UNPACK_RTL_24 (op, tag);
- SCM_UNPACK_RTL_24 (ip[1], nvalues);
-
- SYNC_IP ();
- vm_abort (vm, LOCAL_REF (tag), nvalues, &ip[2], ®isters);
-
- /* vm_abort should not return */
- abort ();
- }
-#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 (68, 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 (69, 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);
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 (70, 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 (71, 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;
*
* Set the value of the fluid in DST to the value in SRC.
*/
- VM_DEFINE_OP (72, 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;
*
* Store the length of the string in SRC in DST.
*/
- VM_DEFINE_OP (73, 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 (74, 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 (75, 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;
*
* Parse a string in SRC to a symbol, and store in DST.
*/
- VM_DEFINE_OP (76, 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;
*
* Make a keyword from the symbol in SRC, and store it in DST.
*/
- VM_DEFINE_OP (77, 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);
*
* Cons CAR and CDR, and store the result in DST.
*/
- VM_DEFINE_OP (78, 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 (79, 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 (80, 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 (81, 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;
*
* Set the cdr of DST to SRC.
*/
- VM_DEFINE_OP (82, 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;
*
* Add A to B, and place the result in DST.
*/
- VM_DEFINE_OP (83, 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 (84, 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 (85, 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 (86, 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 (87, 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 (88, 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 (89, 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 (90, 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 (91, 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 (92, 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 (93, 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 (94, 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 (95, 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;
+
+ SCM_UNPACK_RTL_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 (96, 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 (97, 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 (98, 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;
*
* Store SRC into the vector DST at index IDX.
*/
- VM_DEFINE_OP (99, 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;
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;
+
+ SCM_UNPACK_RTL_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 (100, 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));
}
- /* make-struct dst:12 vtable:12 _:8 n-init:24 init0:24 0:8 ...
+ /* allocate-struct/immediate dst:8 vtable:8 nfields:8
*
- * Make a new struct with VTABLE, and place it in DST. The struct
- * will be constructed with N-INIT initializers, which are located in
- * the locals given by INIT0.... The format of INIT0... is as in the
- * "call" opcode: unsigned 24-bit values, with 0 in the high byte.
+ * 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 (101, make_struct, "make-struct", OP2 (U8_U12_U12, X8_R24))
-#if 0
+ VM_DEFINE_OP (99, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
{
- scm_t_uint16 dst, vtable_r;
- scm_t_uint32 n_init, n;
- SCM vtable, ret;
+ scm_t_uint8 dst, vtable, nfields;
+ SCM ret;
- SCM_UNPACK_RTL_12_12 (op, dst, vtable_r);
- vtable = LOCAL_REF (vtable_r);
- SCM_UNPACK_RTL_24 (ip[1], n_init);
+ SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
SYNC_IP ();
-
- if (SCM_LIKELY (SCM_STRUCTP (vtable)
- && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)
- == n_init)
- && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
- {
- /* Verily, we are making a simple struct with the right number of
- initializers, and no finalizer. */
- ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
- n_init + 2);
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
-
- for (n = 0; n < n_init; n++)
- SCM_STRUCT_DATA (ret)[n] = SCM_UNPACK (LOCAL_REF (ip[n + 1]));
- }
- else
- ret = scm_c_make_structvs (vtable, fp, &ip[1], n_init);
-
+ ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
LOCAL_SET (dst, ret);
- NEXT (n_init + 1);
+
+ NEXT (1);
}
-#else
- abort ();
-#endif
- /* 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 (102, 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;
+
+ SCM_UNPACK_RTL_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 (103, 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 obj, val;
+
SCM_UNPACK_RTL_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 (104, 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 (105, 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);
* 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 (106, 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);
* from the instruction pointer, and store into DST. LEN is a byte
* length. OFFSET is signed.
*/
- VM_DEFINE_OP (107, 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;
*
* Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
*/
- VM_DEFINE_OP (108, 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);
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
} while (0)
- VM_DEFINE_OP (109, 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 (110, 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 (111, 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 (112, 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 (113, 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 (114, 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 (115, 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 (116, 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 (117, 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 (118, 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
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); \
\
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); \
\
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 (119, 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 (120, 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 (121, 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 (122, 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 (123, 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 (124, 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 (125, 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 (126, 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 (127, 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 (128, 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;
HCoop / bpt / guile.git / blobdiff