1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* This file is included in vm.c multiple times. */
24 This file contains two virtual machines. First, the old one -- the
25 one that is currently used, and corresponds to Guile 2.0. It's a
26 stack machine, meaning that most instructions pop their operands from
27 the top of the stack, and push results there too.
29 Following it is the new virtual machine. It's a register machine,
30 meaning that intructions address their operands by index, and store
31 results in indexed slots as well. Those slots are on the stack.
32 It's somewhat confusing to call it a register machine, given that the
33 values are on the stack. Perhaps it needs a new name.
35 Anyway, things are in a transitional state. We're going to try to
36 avoid munging the old VM very much while we flesh out the new one.
37 We're also going to try to make them interoperable, as much as
38 possible -- to have the old VM be able to call procedures for the new
39 VM, and vice versa. This should ease the bootstrapping process. */
43 static SCM
VM_NAME (SCM
, SCM
, SCM
*, int);
45 static SCM
RTL_VM_NAME (SCM
, SCM
, SCM
*, size_t);
48 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
49 # define VM_USE_HOOKS 0 /* Various hooks */
50 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
51 # define VM_USE_HOOKS 1
53 # error unknown debug engine VM_ENGINE
56 /* Assign some registers by hand. There used to be a bigger list here,
57 but it was never tested, and in the case of x86-32, was a source of
58 compilation failures. It can be revived if it's useful, but my naive
59 hope is that simply annotating the locals with "register" will be a
60 sufficient hint to the compiler. */
62 # if defined __x86_64__
63 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
64 well. Tell it to keep the jump table in a r12, which is
66 # define JT_REG asm ("r12")
83 #define VM_ASSERT(condition, handler) \
85 if (SCM_UNLIKELY (!(condition))) \
92 #ifdef VM_ENABLE_ASSERTIONS
93 # define ASSERT(condition) VM_ASSERT (condition, abort())
95 # define ASSERT(condition)
99 #define RUN_HOOK(h, args, n) \
101 if (SCM_UNLIKELY (vp->trace_level > 0)) \
104 vm_dispatch_hook (vm, h, args, n); \
108 #define RUN_HOOK(h, args, n)
110 #define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
112 #define APPLY_HOOK() \
113 RUN_HOOK0 (SCM_VM_APPLY_HOOK)
114 #define PUSH_CONTINUATION_HOOK() \
115 RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK)
116 #define POP_CONTINUATION_HOOK(vals, n) \
117 RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n)
118 #define NEXT_HOOK() \
119 RUN_HOOK0 (SCM_VM_NEXT_HOOK)
120 #define ABORT_CONTINUATION_HOOK(vals, n) \
121 RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n)
122 #define RESTORE_CONTINUATION_HOOK() \
123 RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
125 #define VM_HANDLE_INTERRUPTS \
126 SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
131 /* Cache the VM's instruction, stack, and frame pointer in local variables. */
132 #define CACHE_REGISTER() \
139 /* Update the registers in VP, a pointer to the current VM. This must be done
140 at least before any GC invocation so that `vp->sp' is up-to-date and the
141 whole stack gets marked. */
142 #define SYNC_REGISTER() \
150 #define ASSERT_VARIABLE(x) \
151 VM_ASSERT (SCM_VARIABLEP (x), abort())
152 #define ASSERT_BOUND_VARIABLE(x) \
153 VM_ASSERT (SCM_VARIABLEP (x) \
154 && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \
157 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
159 do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
160 #define ASSERT_ALIGNED_PROCEDURE() \
161 do { if ((scm_t_bits)bp % 8) abort (); } while (0)
162 #define ASSERT_BOUND(x) \
163 VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
166 #define ASSERT_ALIGNED_PROCEDURE()
167 #define ASSERT_BOUND(x)
170 /* Cache the object table and free variables. */
171 #define CACHE_PROGRAM() \
173 if (bp != SCM_PROGRAM_DATA (program)) { \
174 bp = SCM_PROGRAM_DATA (program); \
175 ASSERT_ALIGNED_PROCEDURE (); \
176 if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
177 objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
184 #define SYNC_BEFORE_GC() \
199 /* Accesses to a program's object table. */
200 #define CHECK_OBJECT(_num)
201 #define CHECK_FREE_VARIABLE(_num)
208 #ifdef VM_ENABLE_STACK_NULLING
209 # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
210 # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
211 # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
212 /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
213 inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
214 that continuation doesn't have a chance to run. It's not important on a
215 semantic level, but it does mess up our stack nulling -- so this macro is to
217 # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
219 # define CHECK_STACK_LEAKN(_n)
220 # define CHECK_STACK_LEAK()
221 # define NULLSTACK(_n)
222 # define NULLSTACK_FOR_NONLOCAL_EXIT()
225 /* For this check, we don't use VM_ASSERT, because that leads to a
226 per-site SYNC_ALL, which is too much code growth. The real problem
227 of course is having to check for overflow all the time... */
228 #define CHECK_OVERFLOW() \
229 do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
231 #ifdef VM_CHECK_UNDERFLOW
232 #define PRE_CHECK_UNDERFLOW(N) \
233 VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
234 #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
236 #define PRE_CHECK_UNDERFLOW(N) /* nop */
237 #define CHECK_UNDERFLOW() /* nop */
241 #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
242 #define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
243 #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
244 #define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
245 #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
246 #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
248 /* Pop the N objects on top of the stack and push a list that contains
250 #define POP_LIST(n) \
254 SCM l = SCM_EOL, x; \
256 for (i = n; i; i--) \
259 l = scm_cons (x, l); \
264 /* The opposite: push all of the elements in L onto the list. */
265 #define PUSH_LIST(l, NILP) \
268 for (; scm_is_pair (l); l = SCM_CDR (l)) \
269 PUSH (SCM_CAR (l)); \
270 VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
275 * Instruction operation
278 #define FETCH() (*ip++)
279 #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
282 #ifdef HAVE_LABELS_AS_VALUES
283 # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
285 # define NEXT_JUMP() goto vm_start
291 CHECK_STACK_LEAK (); \
296 /* See frames.h for the layout of stack frames */
297 /* When this is called, bp points to the new program data,
298 and the arguments are already on the stack */
299 #define DROP_FRAME() \
303 CHECK_UNDERFLOW (); \
308 VM_NAME (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
311 register scm_t_uint8
*ip IP_REG
; /* instruction pointer */
312 register SCM
*sp SP_REG
; /* stack pointer */
313 register SCM
*fp FP_REG
; /* frame pointer */
314 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
316 /* Cache variables */
317 struct scm_objcode
*bp
= NULL
; /* program base pointer */
318 SCM
*objects
= NULL
; /* constant objects */
319 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
321 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
323 /* Internal variables */
325 scm_i_jmp_buf registers
; /* used for prompts */
327 #ifdef HAVE_LABELS_AS_VALUES
328 static const void **jump_table_pointer
= NULL
;
331 #ifdef HAVE_LABELS_AS_VALUES
332 register const void **jump_table JT_REG
;
334 if (SCM_UNLIKELY (!jump_table_pointer
))
337 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
338 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
339 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
340 #define VM_INSTRUCTION_TO_LABEL 1
341 #define jump_table jump_table_pointer
342 #include <libguile/vm-expand.h>
343 #include <libguile/vm-i-system.i>
344 #include <libguile/vm-i-scheme.i>
345 #include <libguile/vm-i-loader.i>
347 #undef VM_INSTRUCTION_TO_LABEL
350 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
351 load instruction at each instruction dispatch. */
352 jump_table
= jump_table_pointer
;
355 if (SCM_I_SETJMP (registers
))
357 /* Non-local return. Cache the VM registers back from the vp, and
360 Note, at this point, we must assume that any variable local to
361 vm_engine that can be assigned *has* been assigned. So we need to pull
362 all our state back from the ip/fp/sp.
365 program
= SCM_FRAME_PROGRAM (fp
);
367 /* The stack contains the values returned to this continuation,
368 along with a number-of-values marker -- like an MV return. */
369 ABORT_CONTINUATION_HOOK (sp
- SCM_I_INUM (*sp
), SCM_I_INUM (*sp
));
375 /* Since it's possible to receive the arguments on the stack itself,
376 and indeed the RTL VM invokes us that way, shuffle up the
378 VM_ASSERT (sp
+ 8 + nargs
< stack_limit
, vm_error_too_many_args (nargs
));
381 for (i
= nargs
- 1; i
>= 0; i
--)
386 PUSH (SCM_PACK (fp
)); /* dynamic link */
387 PUSH (SCM_PACK (0)); /* mvra */
388 PUSH (SCM_PACK (ip
)); /* ra */
389 PUSH (boot_continuation
);
391 ip
= SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation
));
393 /* MV-call frame, function & arguments */
394 PUSH (SCM_PACK (fp
)); /* dynamic link */
395 PUSH (SCM_PACK (ip
+ 1)); /* mvra */
396 PUSH (SCM_PACK (ip
)); /* ra */
401 PUSH_CONTINUATION_HOOK ();
405 if (!SCM_PROGRAM_P (program
))
407 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
408 fp
[-1] = SCM_STRUCT_PROCEDURE (program
);
409 else if (SCM_HAS_TYP7 (program
, scm_tc7_rtl_program
))
414 ret
= RTL_VM_NAME (vm
, program
, fp
, sp
- fp
+ 1);
416 NULLSTACK_FOR_NONLOCAL_EXIT ();
418 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
420 /* multiple values returned to continuation */
421 ret
= scm_struct_ref (ret
, SCM_INUM0
);
422 nvalues
= scm_ilength (ret
);
423 PUSH_LIST (ret
, scm_is_null
);
424 goto vm_return_values
;
432 else if (SCM_HAS_TYP7 (program
, scm_tc7_smob
)
433 && SCM_SMOB_APPLICABLE_P (program
))
435 /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
438 for (i
= sp
- fp
; i
>= 0; i
--)
440 fp
[-1] = SCM_SMOB_DESCRIPTOR (program
).apply_trampoline
;
445 vm_error_wrong_type_apply (program
);
451 ip
= SCM_C_OBJCODE_BASE (bp
);
458 #ifndef HAVE_LABELS_AS_VALUES
460 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
463 #include "vm-expand.h"
464 #include "vm-i-system.c"
465 #include "vm-i-scheme.c"
466 #include "vm-i-loader.c"
468 #ifndef HAVE_LABELS_AS_VALUES
470 goto vm_error_bad_instruction
;
474 abort (); /* never reached */
476 vm_error_bad_instruction
:
477 vm_error_bad_instruction (ip
[-1]);
478 abort (); /* never reached */
482 vm_error_stack_overflow (vp
);
483 abort (); /* never reached */
487 #undef CACHE_REGISTER
488 #undef CHECK_OVERFLOW
500 #undef RETURN_ONE_VALUE
501 #undef RETURN_VALUE_LIST
503 #undef SYNC_BEFORE_GC
506 #undef VARIABLE_BOUNDP
510 #undef VM_INSTRUCTION_TO_LABEL
517 This is Guile's new virtual machine. When I say "new", I mean
518 relative to the current virtual machine. At some point it will
519 become "the" virtual machine, and we'll delete this paragraph. As
520 such, the rest of the comments speak as if there's only one VM.
521 In difference from the old VM, local 0 is the procedure, and the
522 first argument is local 1. At some point in the future we should
523 change the fp to point to the procedure and not to local 1.
529 /* The VM has three state bits: the instruction pointer (IP), the frame
530 pointer (FP), and the top-of-stack pointer (SP). We cache the first
531 two of these in machine registers, local to the VM, because they are
532 used extensively by the VM. As the SP is used more by code outside
533 the VM than by the VM itself, we don't bother caching it locally.
535 Since the FP changes infrequently, relative to the IP, we keep vp->fp
536 in sync with the local FP. This would be a big lose for the IP,
537 though, so instead of updating vp->ip all the time, we call SYNC_IP
538 whenever we would need to know the IP of the top frame. In practice,
539 we need to SYNC_IP whenever we call out of the VM to a function that
540 would like to walk the stack, perhaps as the result of an
544 vp->ip = (scm_t_uint8 *) (ip)
546 #define SYNC_REGISTER() \
548 #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
549 #define SYNC_ALL() /* FP already saved */ \
552 #define CHECK_OVERFLOW(sp) \
554 if (SCM_UNLIKELY ((sp) >= stack_limit)) \
555 vm_error_stack_overflow (vp); \
558 /* Reserve stack space for a frame. Will check that there is sufficient
559 stack space for N locals, including the procedure, in addition to
560 3 words to set up the next frame. Invoke after preparing the new
561 frame and setting the fp and ip. */
562 #define ALLOC_FRAME(n) \
564 SCM *new_sp = vp->sp = fp - 1 + n - 1; \
565 CHECK_OVERFLOW (new_sp + 4); \
568 /* Reset the current frame to hold N locals. Used when we know that no
569 stack expansion is needed. */
570 #define RESET_FRAME(n) \
572 vp->sp = fp - 2 + n; \
575 /* Compute the number of locals in the frame. This is equal to the
576 number of actual arguments when a function is first called, plus
577 one for the function. */
578 #define FRAME_LOCALS_COUNT() \
579 (vp->sp + 1 - (fp - 1))
581 /* Restore registers after returning from a frame. */
582 #define RESTORE_FRAME() \
587 #define CACHE_REGISTER() \
589 ip = (scm_t_uint32 *) vp->ip; \
593 #ifdef HAVE_LABELS_AS_VALUES
594 # define BEGIN_DISPATCH_SWITCH /* */
595 # define END_DISPATCH_SWITCH /* */
602 goto *jump_table[op & 0xff]; \
605 # define VM_DEFINE_OP(opcode, tag, name, meta) \
608 # define BEGIN_DISPATCH_SWITCH \
614 # define END_DISPATCH_SWITCH \
616 goto vm_error_bad_instruction; \
625 # define VM_DEFINE_OP(opcode, tag, name, meta) \
630 #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
631 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
633 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
634 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
635 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
637 #define RETURN_ONE_VALUE(ret) \
640 SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
641 VM_HANDLE_INTERRUPTS; \
642 ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
644 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
646 POP_CONTINUATION_HOOK (sp, 1); \
650 /* While we could generate the list-unrolling code here, it's fine for
651 now to just tail-call (apply values vals). */
652 #define RETURN_VALUE_LIST(vals_) \
655 VM_HANDLE_INTERRUPTS; \
656 fp[-1] = rtl_apply; \
657 fp[0] = rtl_values; \
660 ip = (scm_t_uint32 *) rtl_apply_code; \
664 #define BR_NARGS(rel) \
665 scm_t_uint16 expected; \
666 SCM_UNPACK_RTL_24 (op, expected); \
667 if (FRAME_LOCALS_COUNT() rel expected) \
669 scm_t_int32 offset = ip[1]; \
670 offset >>= 8; /* Sign-extending shift. */ \
675 #define BR_UNARY(x, exp) \
678 SCM_UNPACK_RTL_24 (op, test); \
679 x = LOCAL_REF (test); \
680 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
682 scm_t_int32 offset = ip[1]; \
683 offset >>= 8; /* Sign-extending shift. */ \
685 VM_HANDLE_INTERRUPTS; \
690 #define BR_BINARY(x, y, exp) \
693 SCM_UNPACK_RTL_12_12 (op, a, b); \
696 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
698 scm_t_int32 offset = ip[1]; \
699 offset >>= 8; /* Sign-extending shift. */ \
701 VM_HANDLE_INTERRUPTS; \
706 #define BR_ARITHMETIC(crel,srel) \
710 SCM_UNPACK_RTL_12_12 (op, a, b); \
713 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
715 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
716 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
717 if (x_bits crel y_bits) \
719 scm_t_int32 offset = ip[1]; \
720 offset >>= 8; /* Sign-extending shift. */ \
722 VM_HANDLE_INTERRUPTS; \
730 if (scm_is_true (srel (x, y))) \
732 scm_t_int32 offset = ip[1]; \
733 offset >>= 8; /* Sign-extending shift. */ \
735 VM_HANDLE_INTERRUPTS; \
743 scm_t_uint16 dst, src; \
745 SCM_UNPACK_RTL_12_12 (op, dst, src); \
747 #define ARGS2(a1, a2) \
748 scm_t_uint8 dst, src1, src2; \
750 SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
751 a1 = LOCAL_REF (src1); \
752 a2 = LOCAL_REF (src2)
754 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
756 /* The maximum/minimum tagged integers. */
757 #define INUM_MAX (INTPTR_MAX - 1)
758 #define INUM_MIN (INTPTR_MIN + scm_tc2_int)
760 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
763 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
765 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
766 if (SCM_FIXABLE (n)) \
767 RETURN (SCM_I_MAKINUM (n)); \
770 RETURN (SFUNC (x, y)); \
773 #define VM_VALIDATE_PAIR(x, proc) \
774 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
776 #define VM_VALIDATE_STRUCT(obj, proc) \
777 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
779 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
780 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
782 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
783 #define ALIGNED_P(ptr, type) \
784 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
787 RTL_VM_NAME (SCM vm
, SCM program
, SCM
*argv
, size_t nargs_
)
789 /* Instruction pointer: A pointer to the opcode that is currently
791 register scm_t_uint32
*ip IP_REG
;
793 /* Frame pointer: A pointer into the stack, off of which we index
794 arguments and local variables. Pushed at function calls, popped on
796 register SCM
*fp FP_REG
;
798 /* Current opcode: A cache of *ip. */
799 register scm_t_uint32 op
;
801 /* Cached variables. */
802 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
803 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
804 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
805 scm_i_jmp_buf registers
; /* used for prompts */
807 #ifdef HAVE_LABELS_AS_VALUES
808 static const void **jump_table_pointer
= NULL
;
809 register const void **jump_table JT_REG
;
811 if (SCM_UNLIKELY (!jump_table_pointer
))
814 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
815 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
816 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
817 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
818 FOR_EACH_VM_OPERATION(INIT
);
822 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
823 load instruction at each instruction dispatch. */
824 jump_table
= jump_table_pointer
;
827 if (SCM_I_SETJMP (registers
))
829 /* Non-local return. The values are on the stack, on a new frame
830 set up to call `values' to return the values to the handler.
831 Cache the VM registers back from the vp, and dispatch to the
834 Note, at this point, we must assume that any variable local to
835 vm_engine that can be assigned *has* been assigned. So we need
836 to pull all our state back from the ip/fp/sp.
839 ABORT_CONTINUATION_HOOK (fp
, FRAME_LOCALS_COUNT());
843 /* Load previous VM registers. */
846 VM_HANDLE_INTERRUPTS
;
852 /* Check that we have enough space: 4 words for the boot
853 continuation, 4 + nargs for the procedure application, and 4 for
854 setting up a new frame. */
856 CHECK_OVERFLOW (vp
->sp
+ 4 + 4 + nargs_
+ 4);
858 /* Since it's possible to receive the arguments on the stack itself,
859 and indeed the regular VM invokes us that way, shuffle up the
863 for (i
= nargs_
- 1; i
>= 0; i
--)
864 base
[8 + i
] = argv
[i
];
867 /* Initial frame, saving previous fp and ip, with the boot
869 base
[0] = SCM_PACK (fp
); /* dynamic link */
870 base
[1] = SCM_PACK (0); /* the boot continuation does not return to scheme */
871 base
[2] = SCM_PACK (ip
); /* ra */
872 base
[3] = rtl_boot_continuation
;
874 ip
= rtl_boot_single_value_continuation_code
;
875 if (ip
- 1 != rtl_boot_multiple_value_continuation_code
)
878 /* MV-call frame, function & arguments */
879 base
[4] = SCM_PACK (fp
); /* dynamic link */
880 base
[5] = SCM_PACK (ip
- 1); /* in RTL programs, MVRA precedes RA by one */
881 base
[6] = SCM_PACK (ip
); /* ra */
883 fp
= vp
->fp
= &base
[8];
884 RESET_FRAME (nargs_
+ 1);
888 while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
891 SCM proc
= SCM_FRAME_PROGRAM (fp
);
893 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
895 fp
[-1] = SCM_STRUCT_PROCEDURE (proc
);
898 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
900 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
902 /* Shuffle args up, place smob in local 0. */
903 CHECK_OVERFLOW (vp
->sp
+ 1);
906 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
908 fp
[-1] = SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
;
913 vm_error_wrong_type_apply (proc
);
918 ret
= VM_NAME (vm
, fp
[-1], fp
, FRAME_LOCALS_COUNT () - 1);
920 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
921 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
923 RETURN_ONE_VALUE (ret
);
928 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
931 BEGIN_DISPATCH_SWITCH
;
942 * Bring the VM to a halt, returning the single value from slot 1.
944 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
946 SCM ret
= LOCAL_REF (1);
948 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
949 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
950 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
957 * Bring the VM to a halt, returning all the values from the MV stack.
959 VM_DEFINE_OP (1, halt_values
, "halt/values", OP1 (U8_X24
))
966 /* Boot closure in r0, empty stack from r1 to r4, values from r5. */
967 for (n
= FRAME_LOCALS_COUNT () - 1; n
>= 5; n
--)
968 ret
= scm_cons (LOCAL_REF (n
), ret
);
970 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
971 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
972 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
974 return scm_values (ret
);
977 /* push-frame from:24 _:8 nargs:24
979 * Push a frame for a new procedure call starting at FROM.
980 * Reserve stack space for NARGS values in the new frame, including
983 VM_DEFINE_OP (2, push_frame
, "push-frame", OP2 (U8_U24
, X8_U24
))
985 scm_t_uint32 from
, nargs
, new_size
, n
;
987 SCM_UNPACK_RTL_24 (op
, from
);
988 SCM_UNPACK_RTL_24 (ip
[1], nargs
);
990 new_size
= from
+ 3 + nargs
;
991 ALLOC_FRAME (new_size
);
993 /* FIXME: Elide this initialization? */
994 for (n
= from
; n
< new_size
; n
++)
995 LOCAL_SET (n
, SCM_UNDEFINED
);
1002 * Call a procedure. Links a call frame at FROM, saving the return
1003 * address and the fp.
1005 * The MVRA of the new frame is set to point to the next instruction
1006 * after the end of the `call' instruction. The word following that
1009 VM_DEFINE_OP (3, call
, "call", OP1 (U8_U24
))
1014 SCM_UNPACK_RTL_24 (op
, from
);
1016 VM_HANDLE_INTERRUPTS
;
1018 fp
= vp
->fp
= old_fp
+ from
+ 3;
1019 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1020 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 1);
1021 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 2);
1023 PUSH_CONTINUATION_HOOK ();
1026 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1029 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1033 /* call/values from:24 _:8 proc:24
1035 * Call a procedure, with the values already pushed above a call frame
1036 * at FROM. This instruction is used to handle MV returns in the case
1037 * that we can't inline the handler.
1039 * As with `call', the next instruction after the call/values will be
1040 * the MVRA, and the word after that instruction is the RA.
1042 VM_DEFINE_OP (4, call_values
, "call/values", OP2 (U8_U24
, X8_U24
))
1044 scm_t_uint32 from
, proc
;
1047 SCM_UNPACK_RTL_24 (op
, from
);
1048 SCM_UNPACK_RTL_24 (ip
[1], proc
);
1050 VM_HANDLE_INTERRUPTS
;
1052 fp
= vp
->fp
= old_fp
+ from
+ 4;
1053 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1054 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 2);
1055 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 3);
1056 fp
[-1] = old_fp
[proc
- 1];
1058 PUSH_CONTINUATION_HOOK ();
1061 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1064 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1068 /* tail-call nargs:24 _:8 proc:24
1070 * Tail-call a procedure. Requires that all of the arguments have
1071 * already been shuffled into position.
1073 VM_DEFINE_OP (5, tail_call
, "tail-call", OP2 (U8_U24
, X8_U24
))
1075 scm_t_uint32 nargs
, proc
;
1077 SCM_UNPACK_RTL_24 (op
, nargs
);
1078 SCM_UNPACK_RTL_24 (ip
[1], proc
);
1080 VM_HANDLE_INTERRUPTS
;
1082 fp
[-1] = LOCAL_REF (proc
);
1083 /* No need to check for overflow, as the compiler has already
1084 ensured that this frame has enough space. */
1085 RESET_FRAME (nargs
+ 1);
1089 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1092 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1100 VM_DEFINE_OP (6, return, "return", OP1 (U8_U24
))
1103 SCM_UNPACK_RTL_24 (op
, src
);
1104 RETURN_ONE_VALUE (LOCAL_REF (src
));
1107 /* return-values nvalues:24
1109 * Return a number of values from a call frame. This opcode
1110 * corresponds to an application of `values' in tail position. As
1111 * with tail calls, we expect that the NVALUES values have already
1112 * been shuffled down to a contiguous array starting at slot 0.
1114 VM_DEFINE_OP (7, return_values
, "return/values", OP1 (U8_U24
))
1117 SCM_UNPACK_RTL_24 (op
, nargs
);
1118 RESET_FRAME (nargs
+ 1);
1119 fp
[-1] = rtl_values
;
1127 * Specialized call stubs
1130 /* subr-call ptr-idx:24
1132 * Call a subr, passing all locals in this frame as arguments. Fetch
1133 * the foreign pointer from PTR-IDX, a free variable. Return from the
1134 * calling frame. This instruction is part of the trampolines
1135 * created in gsubr.c, and is not generated by the compiler.
1137 VM_DEFINE_OP (8, subr_call
, "subr-call", OP1 (U8_U24
))
1139 scm_t_uint32 ptr_idx
;
1143 SCM_UNPACK_RTL_24 (op
, ptr_idx
);
1145 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
1146 subr
= SCM_POINTER_VALUE (pointer
);
1148 VM_HANDLE_INTERRUPTS
;
1151 switch (FRAME_LOCALS_COUNT ())
1160 ret
= subr (fp
[0], fp
[1]);
1163 ret
= subr (fp
[0], fp
[1], fp
[2]);
1166 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3]);
1169 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4]);
1172 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
1175 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
1178 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
1181 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
1184 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
1190 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1192 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1193 /* multiple values returned to continuation */
1194 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1196 RETURN_ONE_VALUE (ret
);
1199 /* foreign-call cif-idx:12 ptr-idx:12
1201 * Call a foreign function. Fetch the CIF and foreign pointer from
1202 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1203 * frame. Arguments are taken from the stack. This instruction is
1204 * part of the trampolines created by the FFI, and is not generated by
1207 VM_DEFINE_OP (9, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
1209 scm_t_uint16 cif_idx
, ptr_idx
;
1210 SCM closure
, cif
, pointer
, ret
;
1212 SCM_UNPACK_RTL_12_12 (op
, cif_idx
, ptr_idx
);
1214 closure
= LOCAL_REF (0);
1215 cif
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
1216 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
1219 VM_HANDLE_INTERRUPTS
;
1221 // FIXME: separate args
1222 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), fp
);
1224 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1226 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1227 /* multiple values returned to continuation */
1228 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1230 RETURN_ONE_VALUE (ret
);
1233 /* continuation-call contregs:24
1235 * Return to a continuation, nonlocally. The arguments to the
1236 * continuation are taken from the stack. CONTREGS is a free variable
1237 * containing the reified continuation. This instruction is part of
1238 * the implementation of undelimited continuations, and is not
1239 * generated by the compiler.
1241 VM_DEFINE_OP (10, continuation_call
, "continuation-call", OP1 (U8_U24
))
1244 scm_t_uint32 contregs_idx
;
1246 SCM_UNPACK_RTL_24 (op
, contregs_idx
);
1249 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
1252 scm_i_check_continuation (contregs
);
1253 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
1254 scm_i_contregs_vm_cont (contregs
),
1255 FRAME_LOCALS_COUNT (), fp
);
1256 scm_i_reinstate_continuation (contregs
);
1262 /* compose-continuation cont:24
1264 * Compose a partial continution with the current continuation. The
1265 * arguments to the continuation are taken from the stack. CONT is a
1266 * free variable containing the reified continuation. This
1267 * instruction is part of the implementation of partial continuations,
1268 * and is not generated by the compiler.
1270 VM_DEFINE_OP (11, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
1273 scm_t_uint32 cont_idx
;
1275 SCM_UNPACK_RTL_24 (op
, cont_idx
);
1276 vmcont
= LOCAL_REF (cont_idx
);
1279 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
1280 vm_error_continuation_not_rewindable (vmcont
));
1281 vm_reinstate_partial_continuation (vm
, vmcont
, FRAME_LOCALS_COUNT (), fp
,
1282 ¤t_thread
->dynstack
,
1290 * Tail-apply the procedure in local slot 0 to the rest of the
1291 * arguments. This instruction is part of the implementation of
1292 * `apply', and is not generated by the compiler.
1294 VM_DEFINE_OP (12, apply
, "apply", OP1 (U8_X24
))
1296 int i
, list_idx
, list_len
, nargs
;
1299 VM_HANDLE_INTERRUPTS
;
1301 VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
1302 nargs
= FRAME_LOCALS_COUNT ();
1303 list_idx
= nargs
- 1;
1304 list
= LOCAL_REF (list_idx
);
1305 list_len
= scm_ilength (list
);
1307 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
1309 nargs
= nargs
- 2 + list_len
;
1310 ALLOC_FRAME (nargs
);
1312 for (i
= 0; i
< list_idx
; i
++)
1313 LOCAL_SET(i
- 1, LOCAL_REF (i
));
1315 /* Null out these slots, just in case there are less than 2 elements
1317 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
1318 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
1320 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
1321 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
1325 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1328 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1334 * Capture the current continuation, and tail-apply the procedure in
1335 * local slot 0 to it. This instruction is part of the implementation
1336 * of `call/cc', and is not generated by the compiler.
1338 VM_DEFINE_OP (13, call_cc
, "call/cc", OP1 (U8_X24
))
1342 scm_t_dynstack
*dynstack
;
1344 VM_HANDLE_INTERRUPTS
;
1347 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
1348 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1349 SCM_FRAME_DYNAMIC_LINK (fp
),
1350 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1351 SCM_FRAME_RETURN_ADDRESS (fp
),
1352 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1355 cont
= scm_i_make_continuation (®isters
, vm
, vm_cont
);
1363 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1366 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1375 * Return all values on the stack to the current continuation.
1376 * This instruction is part of the implementation of
1377 * `values', and is not generated by the compiler.
1379 VM_DEFINE_OP (14, values
, "values", OP1 (U8_X24
))
1383 int nargs
= FRAME_LOCALS_COUNT () - 1;
1386 /* We don't do much; it's the caller that's responsible for
1387 shuffling values and resetting the stack. */
1389 VM_HANDLE_INTERRUPTS
;
1390 ip
= SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp
);
1391 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1393 /* Clear stack frame. */
1394 base
[-1] = SCM_BOOL_F
;
1395 base
[-2] = SCM_BOOL_F
;
1396 base
[-3] = SCM_BOOL_F
;
1397 base
[-4] = SCM_BOOL_F
;
1399 POP_CONTINUATION_HOOK (base
, nargs
);
1408 * Function prologues
1411 /* br-if-nargs-ne expected:24 _:8 offset:24
1412 * br-if-nargs-lt expected:24 _:8 offset:24
1413 * br-if-nargs-gt expected:24 _:8 offset:24
1415 * If the number of actual arguments is not equal, less than, or greater
1416 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1417 * the current instruction pointer.
1419 VM_DEFINE_OP (15, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1423 VM_DEFINE_OP (16, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1427 VM_DEFINE_OP (17, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1432 /* assert-nargs-ee expected:24
1433 * assert-nargs-ge expected:24
1434 * assert-nargs-le expected:24
1436 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1437 * respectively, signal an error.
1439 VM_DEFINE_OP (18, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1441 scm_t_uint32 expected
;
1442 SCM_UNPACK_RTL_24 (op
, expected
);
1443 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1444 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1447 VM_DEFINE_OP (19, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1449 scm_t_uint32 expected
;
1450 SCM_UNPACK_RTL_24 (op
, expected
);
1451 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1452 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1455 VM_DEFINE_OP (20, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1457 scm_t_uint32 expected
;
1458 SCM_UNPACK_RTL_24 (op
, expected
);
1459 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1460 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1464 /* reserve-locals nlocals:24
1466 * Ensure that there is space on the stack for NLOCALS local variables,
1467 * setting them all to SCM_UNDEFINED, except those nargs values that
1468 * were passed as arguments and procedure.
1470 VM_DEFINE_OP (21, reserve_locals
, "reserve-locals", OP1 (U8_U24
))
1472 scm_t_uint32 nlocals
, nargs
;
1473 SCM_UNPACK_RTL_24 (op
, nlocals
);
1475 nargs
= FRAME_LOCALS_COUNT ();
1476 ALLOC_FRAME (nlocals
);
1477 while (nlocals
-- > nargs
)
1478 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1483 /* assert-nargs-ee/locals expected:12 nlocals:12
1485 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1486 * number of locals reserved is EXPECTED + NLOCALS.
1488 VM_DEFINE_OP (22, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1490 scm_t_uint16 expected
, nlocals
;
1491 SCM_UNPACK_RTL_12_12 (op
, expected
, nlocals
);
1492 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1493 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1494 ALLOC_FRAME (expected
+ nlocals
);
1496 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1501 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1502 * _:8 ntotal:24 kw-offset:32
1504 * Find the last positional argument, and shuffle all the rest above
1505 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1506 * load the constant at KW-OFFSET words from the current IP, and use it
1507 * to bind keyword arguments. If HAS-REST, collect all shuffled
1508 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1509 * the arguments that we shuffled up.
1511 * A macro-mega-instruction.
1513 VM_DEFINE_OP (23, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1515 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1516 scm_t_int32 kw_offset
;
1519 char allow_other_keys
, has_rest
;
1521 SCM_UNPACK_RTL_24 (op
, nreq
);
1522 allow_other_keys
= ip
[1] & 0x1;
1523 has_rest
= ip
[1] & 0x2;
1524 SCM_UNPACK_RTL_24 (ip
[1], nreq_and_opt
);
1525 SCM_UNPACK_RTL_24 (ip
[2], ntotal
);
1527 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1528 VM_ASSERT (!(kw_bits
& 0x7), abort());
1529 kw
= SCM_PACK (kw_bits
);
1531 nargs
= FRAME_LOCALS_COUNT ();
1533 /* look in optionals for first keyword or last positional */
1534 /* starting after the last required positional arg */
1536 while (/* while we have args */
1538 /* and we still have positionals to fill */
1539 && npositional
< nreq_and_opt
1540 /* and we haven't reached a keyword yet */
1541 && !scm_is_keyword (LOCAL_REF (npositional
)))
1542 /* bind this optional arg (by leaving it in place) */
1544 nkw
= nargs
- npositional
;
1545 /* shuffle non-positional arguments above ntotal */
1546 ALLOC_FRAME (ntotal
+ nkw
);
1549 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1550 /* and fill optionals & keyword args with SCM_UNDEFINED */
1553 LOCAL_SET (n
++, SCM_UNDEFINED
);
1555 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1556 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1558 /* Now bind keywords, in the order given. */
1559 for (n
= 0; n
< nkw
; n
++)
1560 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1563 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1564 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1566 SCM si
= SCM_CDAR (walk
);
1567 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1568 LOCAL_REF (ntotal
+ n
+ 1));
1571 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1572 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1573 LOCAL_REF (ntotal
+ n
)));
1577 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1578 LOCAL_REF (ntotal
+ n
)));
1585 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1586 LOCAL_SET (nreq_and_opt
, rest
);
1589 RESET_FRAME (ntotal
);
1596 * Collect any arguments at or above DST into a list, and store that
1599 VM_DEFINE_OP (24, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1601 scm_t_uint32 dst
, nargs
;
1604 SCM_UNPACK_RTL_24 (op
, dst
);
1605 nargs
= FRAME_LOCALS_COUNT ();
1607 while (nargs
-- > dst
)
1609 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1610 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1613 LOCAL_SET (dst
, rest
);
1615 RESET_FRAME (dst
+ 1);
1620 /* drop-values nlocals:24
1622 * Reset the stack pointer to only have space for NLOCALS values.
1623 * Used after extracting values from an MV return.
1625 VM_DEFINE_OP (25, drop_values
, "drop-values", OP1 (U8_U24
))
1629 SCM_UNPACK_RTL_24 (op
, nlocals
);
1631 RESET_FRAME (nlocals
);
1640 * Branching instructions
1645 * Add OFFSET, a signed 24-bit number, to the current instruction
1648 VM_DEFINE_OP (26, br
, "br", OP1 (U8_L24
))
1650 scm_t_int32 offset
= op
;
1651 offset
>>= 8; /* Sign-extending shift. */
1655 /* br-if-true test:24 invert:1 _:7 offset:24
1657 * If the value in TEST is true for the purposes of Scheme, add
1658 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1660 VM_DEFINE_OP (27, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1662 BR_UNARY (x
, scm_is_true (x
));
1665 /* br-if-null test:24 invert:1 _:7 offset:24
1667 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1668 * signed 24-bit number, to the current instruction pointer.
1670 VM_DEFINE_OP (28, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1672 BR_UNARY (x
, scm_is_null (x
));
1675 /* br-if-nil test:24 invert:1 _:7 offset:24
1677 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1678 * number, to the current instruction pointer.
1680 VM_DEFINE_OP (29, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1682 BR_UNARY (x
, scm_is_lisp_false (x
));
1685 /* br-if-pair test:24 invert:1 _:7 offset:24
1687 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1688 * to the current instruction pointer.
1690 VM_DEFINE_OP (30, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1692 BR_UNARY (x
, scm_is_pair (x
));
1695 /* br-if-struct test:24 invert:1 _:7 offset:24
1697 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1698 * number, to the current instruction pointer.
1700 VM_DEFINE_OP (31, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1702 BR_UNARY (x
, SCM_STRUCTP (x
));
1705 /* br-if-char test:24 invert:1 _:7 offset:24
1707 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1708 * to the current instruction pointer.
1710 VM_DEFINE_OP (32, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1712 BR_UNARY (x
, SCM_CHARP (x
));
1715 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1717 * If the value in TEST has the TC7 given in the second word, add
1718 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1720 VM_DEFINE_OP (33, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1722 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1725 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1727 * If the value in A is eq? to the value in B, add OFFSET, a signed
1728 * 24-bit number, to the current instruction pointer.
1730 VM_DEFINE_OP (34, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1732 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1735 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1737 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1738 * 24-bit number, to the current instruction pointer.
1740 VM_DEFINE_OP (35, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1744 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1745 && scm_is_true (scm_eqv_p (x
, y
))));
1748 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1750 * If the value in A is equal? to the value in B, add OFFSET, a signed
1751 * 24-bit number, to the current instruction pointer.
1753 // FIXME: should sync_ip before calling out?
1754 VM_DEFINE_OP (36, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1758 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1759 && scm_is_true (scm_equal_p (x
, y
))));
1762 /* br-if-= a:12 b:12 _:8 offset:24
1764 * If the value in A is = to the value in B, add OFFSET, a signed
1765 * 24-bit number, to the current instruction pointer.
1767 VM_DEFINE_OP (37, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, X8_L24
))
1769 BR_ARITHMETIC (==, scm_num_eq_p
);
1772 /* br-if-< a:12 b:12 _:8 offset:24
1774 * If the value in A is < to the value in B, add OFFSET, a signed
1775 * 24-bit number, to the current instruction pointer.
1777 VM_DEFINE_OP (38, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, X8_L24
))
1779 BR_ARITHMETIC (<, scm_less_p
);
1782 /* br-if-<= a:12 b:12 _:8 offset:24
1784 * If the value in A is <= to the value in B, add OFFSET, a signed
1785 * 24-bit number, to the current instruction pointer.
1787 VM_DEFINE_OP (39, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, X8_L24
))
1789 BR_ARITHMETIC (<=, scm_leq_p
);
1792 /* br-if-> a:12 b:12 _:8 offset:24
1794 * If the value in A is > to the value in B, add OFFSET, a signed
1795 * 24-bit number, to the current instruction pointer.
1797 VM_DEFINE_OP (40, br_if_gt
, "br-if->", OP2 (U8_U12_U12
, X8_L24
))
1799 BR_ARITHMETIC (>, scm_gr_p
);
1802 /* br-if->= a:12 b:12 _:8 offset:24
1804 * If the value in A is >= to the value in B, add OFFSET, a signed
1805 * 24-bit number, to the current instruction pointer.
1807 VM_DEFINE_OP (41, br_if_ge
, "br-if->=", OP2 (U8_U12_U12
, X8_L24
))
1809 BR_ARITHMETIC (>=, scm_geq_p
);
1816 * Lexical binding instructions
1819 /* mov dst:12 src:12
1821 * Copy a value from one local slot to another.
1823 VM_DEFINE_OP (42, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1828 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1829 LOCAL_SET (dst
, LOCAL_REF (src
));
1834 /* long-mov dst:24 _:8 src:24
1836 * Copy a value from one local slot to another.
1838 VM_DEFINE_OP (43, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1843 SCM_UNPACK_RTL_24 (op
, dst
);
1844 SCM_UNPACK_RTL_24 (ip
[1], src
);
1845 LOCAL_SET (dst
, LOCAL_REF (src
));
1850 /* box dst:12 src:12
1852 * Create a new variable holding SRC, and place it in DST.
1854 VM_DEFINE_OP (44, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1856 scm_t_uint16 dst
, src
;
1857 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1858 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1864 * Create a new unbound variable, and place it in DST. Used in the
1865 * general implementation of `letrec', in those cases that fix-letrec
1868 VM_DEFINE_OP (45, empty_box
, "empty-box", OP1 (U8_U24
) | OP_DST
)
1871 SCM_UNPACK_RTL_24 (op
, dst
);
1872 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1876 /* box-ref dst:12 src:12
1878 * Unpack the variable at SRC into DST, asserting that the variable is
1881 VM_DEFINE_OP (46, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1883 scm_t_uint16 dst
, src
;
1885 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1886 var
= LOCAL_REF (src
);
1887 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1888 if (SCM_UNLIKELY (!VARIABLE_BOUNDP (var
)))
1891 /* Attempt to provide the variable name in the error message. */
1893 var_name
= scm_module_reverse_lookup (scm_current_module (), var
);
1894 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), scm_is_true (var_name
) ? var_name
: var
);
1896 LOCAL_SET (dst
, VARIABLE_REF (var
));
1900 /* box-set! dst:12 src:12
1902 * Set the contents of the variable at DST to SET.
1904 VM_DEFINE_OP (47, box_set
, "box-set!", OP1 (U8_U12_U12
) | OP_DST
)
1906 scm_t_uint16 dst
, src
;
1908 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1909 var
= LOCAL_REF (dst
);
1910 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1911 VARIABLE_SET (var
, LOCAL_REF (src
));
1915 /* make-closure dst:24 offset:32 _:8 nfree:24
1917 * Make a new closure, and write it to DST. The code for the closure
1918 * will be found at OFFSET words from the current IP. OFFSET is a
1919 * signed 32-bit integer. Space for NFREE free variables will be
1922 VM_DEFINE_OP (48, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1924 scm_t_uint32 dst
, nfree
, n
;
1928 SCM_UNPACK_RTL_24 (op
, dst
);
1930 SCM_UNPACK_RTL_24 (ip
[2], nfree
);
1932 // FIXME: Assert range of nfree?
1933 closure
= scm_words (scm_tc7_rtl_program
| (nfree
<< 16), nfree
+ 2);
1934 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1935 // FIXME: Elide these initializations?
1936 for (n
= 0; n
< nfree
; n
++)
1937 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1938 LOCAL_SET (dst
, closure
);
1942 /* free-ref dst:12 src:12 _:8 idx:24
1944 * Load free variable IDX from the closure SRC into local slot DST.
1946 VM_DEFINE_OP (49, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1948 scm_t_uint16 dst
, src
;
1950 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1951 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1952 /* CHECK_FREE_VARIABLE (src); */
1953 LOCAL_SET (dst
, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1957 /* free-set! dst:12 src:12 _8 idx:24
1959 * Set free variable IDX from the closure DST to SRC.
1961 VM_DEFINE_OP (50, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1963 scm_t_uint16 dst
, src
;
1965 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1966 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1967 /* CHECK_FREE_VARIABLE (src); */
1968 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1976 * Immediates and statically allocated non-immediates
1979 /* make-short-immediate dst:8 low-bits:16
1981 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1984 VM_DEFINE_OP (51, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1989 SCM_UNPACK_RTL_8_16 (op
, dst
, val
);
1990 LOCAL_SET (dst
, SCM_PACK (val
));
1994 /* make-long-immediate dst:24 low-bits:32
1996 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1999 VM_DEFINE_OP (52, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
2004 SCM_UNPACK_RTL_24 (op
, dst
);
2006 LOCAL_SET (dst
, SCM_PACK (val
));
2010 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
2012 * Make an immediate with HIGH-BITS and LOW-BITS.
2014 VM_DEFINE_OP (53, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
2019 SCM_UNPACK_RTL_24 (op
, dst
);
2020 #if SIZEOF_SCM_T_BITS > 4
2025 ASSERT (ip
[1] == 0);
2028 LOCAL_SET (dst
, SCM_PACK (val
));
2032 /* make-non-immediate dst:24 offset:32
2034 * Load a pointer to statically allocated memory into DST. The
2035 * object's memory is will be found OFFSET 32-bit words away from the
2036 * current instruction pointer. OFFSET is a signed value. The
2037 * intention here is that the compiler would produce an object file
2038 * containing the words of a non-immediate object, and this
2039 * instruction creates a pointer to that memory, effectively
2040 * resurrecting that object.
2042 * Whether the object is mutable or immutable depends on where it was
2043 * allocated by the compiler, and loaded by the loader.
2045 VM_DEFINE_OP (54, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
2050 scm_t_bits unpacked
;
2052 SCM_UNPACK_RTL_24 (op
, dst
);
2055 unpacked
= (scm_t_bits
) loc
;
2057 VM_ASSERT (!(unpacked
& 0x7), abort());
2059 LOCAL_SET (dst
, SCM_PACK (unpacked
));
2064 /* static-ref dst:24 offset:32
2066 * Load a SCM value into DST. The SCM value will be fetched from
2067 * memory, OFFSET 32-bit words away from the current instruction
2068 * pointer. OFFSET is a signed value.
2070 * The intention is for this instruction to be used to load constants
2071 * that the compiler is unable to statically allocate, like symbols.
2072 * These values would be initialized when the object file loads.
2074 VM_DEFINE_OP (55, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
2079 scm_t_uintptr loc_bits
;
2081 SCM_UNPACK_RTL_24 (op
, dst
);
2084 loc_bits
= (scm_t_uintptr
) loc
;
2085 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2087 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
2092 /* static-set! src:24 offset:32
2094 * Store a SCM value into memory, OFFSET 32-bit words away from the
2095 * current instruction pointer. OFFSET is a signed value.
2097 VM_DEFINE_OP (56, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
2103 SCM_UNPACK_RTL_24 (op
, src
);
2106 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2108 *((SCM
*) loc
) = LOCAL_REF (src
);
2113 /* link-procedure! src:24 offset:32
2115 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2116 * words away from the current instruction pointer. OFFSET is a
2119 VM_DEFINE_OP (57, link_procedure
, "link-procedure!", OP2 (U8_U24
, L32
))
2125 SCM_UNPACK_RTL_24 (op
, src
);
2129 SCM_SET_CELL_WORD_1 (LOCAL_REF (src
), (scm_t_bits
) loc
);
2137 * Mutable top-level bindings
2140 /* There are three slightly different ways to resolve toplevel
2143 1. A toplevel reference outside of a function. These need to be
2144 looked up when the expression is evaluated -- no later, and no
2145 before. They are looked up relative to the module that is
2146 current when the expression is evaluated. For example:
2150 The "resolve" instruction resolves the variable (box), and then
2151 access is via box-ref or box-set!.
2153 2. A toplevel reference inside a function. These are looked up
2154 relative to the module that was current when the function was
2155 defined. Unlike code at the toplevel, which is usually run only
2156 once, these bindings benefit from memoized lookup, in which the
2157 variable resulting from the lookup is cached in the function.
2159 (lambda () (if (foo) a b))
2161 Although one can use resolve and box-ref, the toplevel-ref and
2162 toplevel-set! instructions are better for references.
2164 3. A reference to an identifier with respect to a particular
2165 module. This can happen for primitive references, and
2166 references residualized by macro expansions. These can be
2167 cached or not, depending on whether they are in a lambda or not.
2172 For these, one can use resolve-module, resolve, and the box
2173 interface, though there is also module-ref as a shortcut.
2176 /* current-module dst:24
2178 * Store the current module in DST.
2180 VM_DEFINE_OP (58, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
2184 SCM_UNPACK_RTL_24 (op
, dst
);
2187 LOCAL_SET (dst
, scm_current_module ());
2192 /* resolve dst:8 mod:8 sym:8
2194 * Resolve SYM in MOD, and place the resulting variable in DST.
2196 VM_DEFINE_OP (59, resolve
, "resolve", OP1 (U8_U8_U8_U8
) | OP_DST
)
2198 scm_t_uint8 dst
, mod
, sym
;
2200 SCM_UNPACK_RTL_8_8_8 (op
, dst
, mod
, sym
);
2203 LOCAL_SET (dst
, scm_module_lookup (LOCAL_REF (mod
), LOCAL_REF (sym
)));
2208 /* resolve-module dst:8 name:8 public:8
2210 * Resolve a module with name NAME, placing it in DST. If PUBLIC is
2211 * nonzero, resolve the public interface, otherwise use the private
2214 VM_DEFINE_OP (60, resolve_module
, "resolve-module", OP1 (U8_U8_U8_U8
) | OP_DST
)
2216 scm_t_uint8 dst
, name
, public;
2219 SCM_UNPACK_RTL_8_8_8 (op
, dst
, name
, public);
2222 mod
= scm_resolve_module (LOCAL_REF (name
));
2224 mod
= scm_module_public_interface (mod
);
2225 LOCAL_SET (dst
, mod
);
2230 /* define sym:12 val:12
2232 * Look up a binding for SYM in the current module, creating it if
2233 * necessary. Set its value to VAL.
2235 VM_DEFINE_OP (61, define
, "define", OP1 (U8_U12_U12
))
2237 scm_t_uint16 sym
, val
;
2238 SCM_UNPACK_RTL_12_12 (op
, sym
, val
);
2240 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
2244 /* toplevel-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
2246 * Load a SCM value. The SCM value will be fetched from memory,
2247 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2248 * VAR-OFFSET is a signed value. Up to here, toplevel-ref is like
2251 * Then, if the loaded value is a variable, the value of the variable
2252 * is placed in DST, and control flow continues.
2254 * Otherwise, we have to resolve the variable. In that case we load
2255 * the module from MOD-OFFSET, just as we loaded the variable.
2256 * Usually the module gets set when the closure is created. The name
2257 * is an offset to a symbol.
2259 * We use the module and the string to resolve the variable, raising
2260 * an error if it is unbound, unbox it into DST, and cache the
2261 * resolved variable so that we will hit the cache next time.
2263 VM_DEFINE_OP (62, toplevel_ref
, "toplevel-ref", OP4 (U8_U24
, S32
, S32
, N32
) | OP_DST
)
2266 scm_t_int32 var_offset
;
2267 scm_t_uint32
* var_loc_u32
;
2271 SCM_UNPACK_RTL_24 (op
, dst
);
2273 var_loc_u32
= ip
+ var_offset
;
2274 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2275 var_loc
= (SCM
*) var_loc_u32
;
2278 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2281 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2282 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2283 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2284 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2288 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2289 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2291 mod
= *((SCM
*) mod_loc
);
2292 sym
= *((SCM
*) sym_loc
);
2294 var
= scm_module_lookup (mod
, sym
);
2295 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2300 LOCAL_SET (dst
, VARIABLE_REF (var
));
2304 /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
2306 * Set a top-level variable from a variable cache cell. The variable
2307 * is resolved as in toplevel-ref.
2309 VM_DEFINE_OP (63, toplevel_set
, "toplevel-set!", OP4 (U8_U24
, S32
, S32
, N32
))
2312 scm_t_int32 var_offset
;
2313 scm_t_uint32
* var_loc_u32
;
2317 SCM_UNPACK_RTL_24 (op
, src
);
2319 var_loc_u32
= ip
+ var_offset
;
2320 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2321 var_loc
= (SCM
*) var_loc_u32
;
2324 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2327 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2328 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2329 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2330 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2334 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2335 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2337 mod
= *((SCM
*) mod_loc
);
2338 sym
= *((SCM
*) sym_loc
);
2340 var
= scm_module_lookup (mod
, sym
);
2345 VARIABLE_SET (var
, LOCAL_REF (src
));
2349 /* module-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
2351 * Like toplevel-ref, except MOD-OFFSET points at the name of a module
2352 * instead of the module itself.
2354 VM_DEFINE_OP (64, module_ref
, "module-ref", OP4 (U8_U24
, S32
, N32
, N32
) | OP_DST
)
2357 scm_t_int32 var_offset
;
2358 scm_t_uint32
* var_loc_u32
;
2362 SCM_UNPACK_RTL_24 (op
, dst
);
2364 var_loc_u32
= ip
+ var_offset
;
2365 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2366 var_loc
= (SCM
*) var_loc_u32
;
2369 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2372 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2373 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2374 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2375 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2379 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2380 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2382 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2383 sym
= *((SCM
*) sym_loc
);
2385 if (scm_is_true (SCM_CAR (modname
)))
2386 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2388 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2390 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2395 LOCAL_SET (dst
, VARIABLE_REF (var
));
2399 /* module-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
2401 * Like toplevel-set!, except MOD-OFFSET points at the name of a module
2402 * instead of the module itself.
2404 VM_DEFINE_OP (65, module_set
, "module-set!", OP4 (U8_U24
, S32
, N32
, N32
))
2407 scm_t_int32 var_offset
;
2408 scm_t_uint32
* var_loc_u32
;
2412 SCM_UNPACK_RTL_24 (op
, src
);
2414 var_loc_u32
= ip
+ var_offset
;
2415 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2416 var_loc
= (SCM
*) var_loc_u32
;
2419 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2422 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2423 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2424 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2425 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2429 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2430 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2432 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2433 sym
= *((SCM
*) sym_loc
);
2435 if (scm_is_true (SCM_CAR (modname
)))
2436 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2438 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2443 VARIABLE_SET (var
, LOCAL_REF (src
));
2450 * The dynamic environment
2453 /* prompt tag:24 flags:8 handler-offset:24
2455 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2456 * handler at HANDLER-OFFSET words from the current IP. The handler
2457 * will expect a multiple-value return.
2459 VM_DEFINE_OP (66, prompt
, "prompt", OP2 (U8_U24
, U8_L24
))
2464 scm_t_uint8 escape_only_p
;
2465 scm_t_dynstack_prompt_flags flags
;
2467 SCM_UNPACK_RTL_24 (op
, tag
);
2468 escape_only_p
= ip
[1] & 0xff;
2470 offset
>>= 8; /* Sign extension */
2472 /* Push the prompt onto the dynamic stack. */
2473 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2474 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2476 fp
, vp
->sp
, ip
+ offset
, ®isters
);
2483 /* wind winder:12 unwinder:12
2485 * Push wind and unwind procedures onto the dynamic stack. Note that
2486 * neither are actually called; the compiler should emit calls to wind
2487 * and unwind for the normal dynamic-wind control flow. Also note that
2488 * the compiler should have inserted checks that they wind and unwind
2489 * procs are thunks, if it could not prove that to be the case.
2491 VM_DEFINE_OP (67, wind
, "wind", OP1 (U8_U12_U12
))
2493 scm_t_uint16 winder
, unwinder
;
2494 SCM_UNPACK_RTL_12_12 (op
, winder
, unwinder
);
2495 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2496 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2500 /* abort tag:24 _:8 from:24
2502 * Return a number of values to a prompt handler. The values are
2503 * expected in a frame pushed on at FROM.
2505 VM_DEFINE_OP (68, abort
, "abort", OP2 (U8_U24
, X8_U24
))
2508 scm_t_uint32 tag
, from
, nvalues
;
2511 SCM_UNPACK_RTL_24 (op
, tag
);
2512 SCM_UNPACK_RTL_24 (ip
[1], from
);
2513 base
= (fp
- 1) + from
+ 3;
2514 nvalues
= FRAME_LOCALS_COUNT () - from
- 3;
2517 vm_abort (vm
, LOCAL_REF (tag
), base
, nvalues
, ®isters
);
2519 /* vm_abort should not return */
2528 * A normal exit from the dynamic extent of an expression. Pop the top
2529 * entry off of the dynamic stack.
2531 VM_DEFINE_OP (69, unwind
, "unwind", OP1 (U8_X24
))
2533 scm_dynstack_pop (¤t_thread
->dynstack
);
2537 /* push-fluid fluid:12 value:12
2539 * Dynamically bind N fluids to values. The fluids are expected to be
2540 * allocated in a continguous range on the stack, starting from
2541 * FLUID-BASE. The values do not have this restriction.
2543 VM_DEFINE_OP (70, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2545 scm_t_uint32 fluid
, value
;
2547 SCM_UNPACK_RTL_12_12 (op
, fluid
, value
);
2549 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2550 fp
[fluid
], fp
[value
],
2551 current_thread
->dynamic_state
);
2557 * Leave the dynamic extent of a with-fluids expression, restoring the
2558 * fluids to their previous values.
2560 VM_DEFINE_OP (71, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2562 /* This function must not allocate. */
2563 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2564 current_thread
->dynamic_state
);
2568 /* fluid-ref dst:12 src:12
2570 * Reference the fluid in SRC, and place the value in DST.
2572 VM_DEFINE_OP (72, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2574 scm_t_uint16 dst
, src
;
2578 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2579 fluid
= LOCAL_REF (src
);
2580 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2581 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2582 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2584 /* Punt dynstate expansion and error handling to the C proc. */
2586 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2590 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2591 if (scm_is_eq (val
, SCM_UNDEFINED
))
2592 val
= SCM_I_FLUID_DEFAULT (fluid
);
2593 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2594 vm_error_unbound_fluid (program
, fluid
));
2595 LOCAL_SET (dst
, val
);
2601 /* fluid-set fluid:12 val:12
2603 * Set the value of the fluid in DST to the value in SRC.
2605 VM_DEFINE_OP (73, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2611 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2612 fluid
= LOCAL_REF (a
);
2613 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2614 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2615 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2617 /* Punt dynstate expansion and error handling to the C proc. */
2619 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2622 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2631 * Strings, symbols, and keywords
2634 /* string-length dst:12 src:12
2636 * Store the length of the string in SRC in DST.
2638 VM_DEFINE_OP (74, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2641 if (SCM_LIKELY (scm_is_string (str
)))
2642 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2646 RETURN (scm_string_length (str
));
2650 /* string-ref dst:8 src:8 idx:8
2652 * Fetch the character at position IDX in the string in SRC, and store
2655 VM_DEFINE_OP (75, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2657 scm_t_signed_bits i
= 0;
2659 if (SCM_LIKELY (scm_is_string (str
)
2660 && SCM_I_INUMP (idx
)
2661 && ((i
= SCM_I_INUM (idx
)) >= 0)
2662 && i
< scm_i_string_length (str
)))
2663 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2667 RETURN (scm_string_ref (str
, idx
));
2671 /* No string-set! instruction, as there is no good fast path there. */
2673 /* string-to-number dst:12 src:12
2675 * Parse a string in SRC to a number, and store in DST.
2677 VM_DEFINE_OP (76, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2679 scm_t_uint16 dst
, src
;
2681 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2684 scm_string_to_number (LOCAL_REF (src
),
2685 SCM_UNDEFINED
/* radix = 10 */));
2689 /* string-to-symbol dst:12 src:12
2691 * Parse a string in SRC to a symbol, and store in DST.
2693 VM_DEFINE_OP (77, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2695 scm_t_uint16 dst
, src
;
2697 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2699 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2703 /* symbol->keyword dst:12 src:12
2705 * Make a keyword from the symbol in SRC, and store it in DST.
2707 VM_DEFINE_OP (78, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2709 scm_t_uint16 dst
, src
;
2710 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2712 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2722 /* cons dst:8 car:8 cdr:8
2724 * Cons CAR and CDR, and store the result in DST.
2726 VM_DEFINE_OP (79, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2729 RETURN (scm_cons (x
, y
));
2732 /* car dst:12 src:12
2734 * Place the car of SRC in DST.
2736 VM_DEFINE_OP (80, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2739 VM_VALIDATE_PAIR (x
, "car");
2740 RETURN (SCM_CAR (x
));
2743 /* cdr dst:12 src:12
2745 * Place the cdr of SRC in DST.
2747 VM_DEFINE_OP (81, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2750 VM_VALIDATE_PAIR (x
, "cdr");
2751 RETURN (SCM_CDR (x
));
2754 /* set-car! pair:12 car:12
2756 * Set the car of DST to SRC.
2758 VM_DEFINE_OP (82, set_car
, "set-car!", OP1 (U8_U12_U12
))
2762 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2765 VM_VALIDATE_PAIR (x
, "set-car!");
2770 /* set-cdr! pair:12 cdr:12
2772 * Set the cdr of DST to SRC.
2774 VM_DEFINE_OP (83, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2778 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2781 VM_VALIDATE_PAIR (x
, "set-car!");
2790 * Numeric operations
2793 /* add dst:8 a:8 b:8
2795 * Add A to B, and place the result in DST.
2797 VM_DEFINE_OP (84, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2799 BINARY_INTEGER_OP (+, scm_sum
);
2802 /* add1 dst:12 src:12
2804 * Add 1 to the value in SRC, and place the result in DST.
2806 VM_DEFINE_OP (85, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2810 /* Check for overflow. */
2811 if (SCM_LIKELY ((scm_t_intptr
) SCM_UNPACK (x
) < INUM_MAX
))
2815 /* Add the integers without untagging. */
2816 result
= SCM_PACK ((scm_t_intptr
) SCM_UNPACK (x
)
2817 + (scm_t_intptr
) SCM_UNPACK (SCM_I_MAKINUM (1))
2820 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2825 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2828 /* sub dst:8 a:8 b:8
2830 * Subtract B from A, and place the result in DST.
2832 VM_DEFINE_OP (86, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2834 BINARY_INTEGER_OP (-, scm_difference
);
2837 /* sub1 dst:12 src:12
2839 * Subtract 1 from SRC, and place the result in DST.
2841 VM_DEFINE_OP (87, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2845 /* Check for underflow. */
2846 if (SCM_LIKELY ((scm_t_intptr
) SCM_UNPACK (x
) > INUM_MIN
))
2850 /* Substract the integers without untagging. */
2851 result
= SCM_PACK ((scm_t_intptr
) SCM_UNPACK (x
)
2852 - (scm_t_intptr
) SCM_UNPACK (SCM_I_MAKINUM (1))
2855 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2860 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2863 /* mul dst:8 a:8 b:8
2865 * Multiply A and B, and place the result in DST.
2867 VM_DEFINE_OP (88, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2871 RETURN (scm_product (x
, y
));
2874 /* div dst:8 a:8 b:8
2876 * Divide A by B, and place the result in DST.
2878 VM_DEFINE_OP (89, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2882 RETURN (scm_divide (x
, y
));
2885 /* quo dst:8 a:8 b:8
2887 * Divide A by B, and place the quotient in DST.
2889 VM_DEFINE_OP (90, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2893 RETURN (scm_quotient (x
, y
));
2896 /* rem dst:8 a:8 b:8
2898 * Divide A by B, and place the remainder in DST.
2900 VM_DEFINE_OP (91, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2904 RETURN (scm_remainder (x
, y
));
2907 /* mod dst:8 a:8 b:8
2909 * Place the modulo of A by B in DST.
2911 VM_DEFINE_OP (92, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2915 RETURN (scm_modulo (x
, y
));
2918 /* ash dst:8 a:8 b:8
2920 * Shift A arithmetically by B bits, and place the result in DST.
2922 VM_DEFINE_OP (93, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2925 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2927 if (SCM_I_INUM (y
) < 0)
2928 /* Right shift, will be a fixnum. */
2929 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) >> -SCM_I_INUM (y
)));
2931 /* Left shift. See comments in scm_ash. */
2933 scm_t_signed_bits nn
, bits_to_shift
;
2935 nn
= SCM_I_INUM (x
);
2936 bits_to_shift
= SCM_I_INUM (y
);
2938 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2940 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2942 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2948 RETURN (scm_ash (x
, y
));
2951 /* logand dst:8 a:8 b:8
2953 * Place the bitwise AND of A and B into DST.
2955 VM_DEFINE_OP (94, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2958 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2959 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) & SCM_I_INUM (y
)));
2961 RETURN (scm_logand (x
, y
));
2964 /* logior dst:8 a:8 b:8
2966 * Place the bitwise inclusive OR of A with B in DST.
2968 VM_DEFINE_OP (95, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2971 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2972 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) | SCM_I_INUM (y
)));
2974 RETURN (scm_logior (x
, y
));
2977 /* logxor dst:8 a:8 b:8
2979 * Place the bitwise exclusive OR of A with B in DST.
2981 VM_DEFINE_OP (96, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2984 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2985 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2987 RETURN (scm_logxor (x
, y
));
2990 /* vector-length dst:12 src:12
2992 * Store the length of the vector in SRC in DST.
2994 VM_DEFINE_OP (97, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2997 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2998 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
3002 RETURN (scm_vector_length (vect
));
3006 /* vector-ref dst:8 src:8 idx:8
3008 * Fetch the item at position IDX in the vector in SRC, and store it
3011 VM_DEFINE_OP (98, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3013 scm_t_signed_bits i
= 0;
3015 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
3016 && SCM_I_INUMP (idx
)
3017 && ((i
= SCM_I_INUM (idx
)) >= 0)
3018 && i
< SCM_I_VECTOR_LENGTH (vect
)))
3019 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
3023 RETURN (scm_vector_ref (vect
, idx
));
3027 /* constant-vector-ref dst:8 src:8 idx:8
3029 * Fill DST with the item IDX elements into the vector at SRC. Useful
3030 * for building data types using vectors.
3032 VM_DEFINE_OP (99, constant_vector_ref
, "constant-vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3034 scm_t_uint8 dst
, src
, idx
;
3037 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3038 v
= LOCAL_REF (src
);
3039 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
3040 && idx
< SCM_I_VECTOR_LENGTH (v
)))
3041 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
3043 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
3047 /* vector-set! dst:8 idx:8 src:8
3049 * Store SRC into the vector DST at index IDX.
3051 VM_DEFINE_OP (100, vector_set
, "vector-set", OP1 (U8_U8_U8_U8
))
3053 scm_t_uint8 dst
, idx_var
, src
;
3055 scm_t_signed_bits i
= 0;
3057 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx_var
, src
);
3058 vect
= LOCAL_REF (dst
);
3059 idx
= LOCAL_REF (idx_var
);
3060 val
= LOCAL_REF (src
);
3062 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
3063 && SCM_I_INUMP (idx
)
3064 && ((i
= SCM_I_INUM (idx
)) >= 0)
3065 && i
< SCM_I_VECTOR_LENGTH (vect
)))
3066 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
3070 scm_vector_set_x (vect
, idx
, val
);
3082 /* struct-vtable dst:12 src:12
3084 * Store the vtable of SRC into DST.
3086 VM_DEFINE_OP (101, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
3089 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
3090 RETURN (SCM_STRUCT_VTABLE (obj
));
3093 /* allocate-struct dst:8 vtable:8 nfields:8
3095 * Allocate a new struct with VTABLE, and place it in DST. The struct
3096 * will be constructed with space for NFIELDS fields, which should
3097 * correspond to the field count of the VTABLE.
3099 VM_DEFINE_OP (102, allocate_struct
, "allocate-struct", OP1 (U8_U8_U8_U8
) | OP_DST
)
3101 scm_t_uint8 dst
, vtable
, nfields
;
3104 SCM_UNPACK_RTL_8_8_8 (op
, dst
, vtable
, nfields
);
3107 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
3108 LOCAL_SET (dst
, ret
);
3113 /* struct-ref dst:8 src:8 idx:8
3115 * Fetch the item at slot IDX in the struct in SRC, and store it
3118 VM_DEFINE_OP (103, struct_ref
, "struct-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3122 if (SCM_LIKELY (SCM_STRUCTP (obj
)
3123 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3124 SCM_VTABLE_FLAG_SIMPLE
)
3125 && SCM_I_INUMP (pos
)))
3128 scm_t_bits index
, len
;
3130 /* True, an inum is a signed value, but cast to unsigned it will
3131 certainly be more than the length, so we will fall through if
3132 index is negative. */
3133 index
= SCM_I_INUM (pos
);
3134 vtable
= SCM_STRUCT_VTABLE (obj
);
3135 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3137 if (SCM_LIKELY (index
< len
))
3139 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3140 RETURN (SCM_PACK (data
[index
]));
3145 RETURN (scm_struct_ref (obj
, pos
));
3148 /* struct-set! dst:8 idx:8 src:8
3150 * Store SRC into the struct DST at slot IDX.
3152 VM_DEFINE_OP (104, struct_set
, "struct-set!", OP1 (U8_U8_U8_U8
))
3154 scm_t_uint8 dst
, idx
, src
;
3157 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3158 obj
= LOCAL_REF (dst
);
3159 pos
= LOCAL_REF (idx
);
3160 val
= LOCAL_REF (src
);
3162 if (SCM_LIKELY (SCM_STRUCTP (obj
)
3163 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3164 SCM_VTABLE_FLAG_SIMPLE
)
3165 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3166 SCM_VTABLE_FLAG_SIMPLE_RW
)
3167 && SCM_I_INUMP (pos
)))
3170 scm_t_bits index
, len
;
3172 /* See above regarding index being >= 0. */
3173 index
= SCM_I_INUM (pos
);
3174 vtable
= SCM_STRUCT_VTABLE (obj
);
3175 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3176 if (SCM_LIKELY (index
< len
))
3178 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3179 data
[index
] = SCM_UNPACK (val
);
3185 scm_struct_set_x (obj
, pos
, val
);
3189 /* class-of dst:12 type:12
3191 * Store the vtable of SRC into DST.
3193 VM_DEFINE_OP (105, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
3196 if (SCM_INSTANCEP (obj
))
3197 RETURN (SCM_CLASS_OF (obj
));
3199 RETURN (scm_class_of (obj
));
3202 /* slot-ref dst:8 src:8 idx:8
3204 * Fetch the item at slot IDX in the struct in SRC, and store it in
3205 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3206 * index into the stack.
3208 VM_DEFINE_OP (106, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3210 scm_t_uint8 dst
, src
, idx
;
3211 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3213 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
3217 /* slot-set! dst:8 idx:8 src:8
3219 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3220 * IDX is an 8-bit immediate value, not an index into the stack.
3222 VM_DEFINE_OP (107, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
3224 scm_t_uint8 dst
, idx
, src
;
3225 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3226 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
3234 * Arrays, packed uniform arrays, and bytevectors.
3237 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3239 * Load the contiguous typed array located at OFFSET 32-bit words away
3240 * from the instruction pointer, and store into DST. LEN is a byte
3241 * length. OFFSET is signed.
3243 VM_DEFINE_OP (108, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
3245 scm_t_uint8 dst
, type
, shape
;
3249 SCM_UNPACK_RTL_8_8_8 (op
, dst
, type
, shape
);
3253 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
3259 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3261 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3263 VM_DEFINE_OP (109, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
3265 scm_t_uint16 dst
, type
, fill
, bounds
;
3266 SCM_UNPACK_RTL_12_12 (op
, dst
, type
);
3267 SCM_UNPACK_RTL_12_12 (ip
[1], fill
, bounds
);
3269 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
3270 LOCAL_REF (bounds
)));
3274 /* bv-u8-ref dst:8 src:8 idx:8
3275 * bv-s8-ref dst:8 src:8 idx:8
3276 * bv-u16-ref dst:8 src:8 idx:8
3277 * bv-s16-ref dst:8 src:8 idx:8
3278 * bv-u32-ref dst:8 src:8 idx:8
3279 * bv-s32-ref dst:8 src:8 idx:8
3280 * bv-u64-ref dst:8 src:8 idx:8
3281 * bv-s64-ref dst:8 src:8 idx:8
3282 * bv-f32-ref dst:8 src:8 idx:8
3283 * bv-f64-ref dst:8 src:8 idx:8
3285 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3286 * it in DST. All accesses use native endianness.
3288 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3290 scm_t_signed_bits i; \
3291 const scm_t_ ## type *int_ptr; \
3294 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3295 i = SCM_I_INUM (idx); \
3296 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3298 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3300 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3301 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3302 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3306 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3310 #define BV_INT_REF(stem, type, size) \
3312 scm_t_signed_bits i; \
3313 const scm_t_ ## type *int_ptr; \
3316 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3317 i = SCM_I_INUM (idx); \
3318 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3320 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3322 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3323 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3325 scm_t_ ## type x = *int_ptr; \
3326 if (SCM_FIXABLE (x)) \
3327 RETURN (SCM_I_MAKINUM (x)); \
3331 RETURN (scm_from_ ## type (x)); \
3337 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3341 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3343 scm_t_signed_bits i; \
3344 const type *float_ptr; \
3347 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3348 i = SCM_I_INUM (idx); \
3349 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3352 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3354 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3355 && (ALIGNED_P (float_ptr, type)))) \
3356 RETURN (scm_from_double (*float_ptr)); \
3358 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3361 VM_DEFINE_OP (110, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3362 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
3364 VM_DEFINE_OP (111, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3365 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
3367 VM_DEFINE_OP (112, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3368 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
3370 VM_DEFINE_OP (113, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3371 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
3373 VM_DEFINE_OP (114, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3374 #if SIZEOF_VOID_P > 4
3375 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
3377 BV_INT_REF (u32
, uint32
, 4);
3380 VM_DEFINE_OP (115, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3381 #if SIZEOF_VOID_P > 4
3382 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
3384 BV_INT_REF (s32
, int32
, 4);
3387 VM_DEFINE_OP (116, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3388 BV_INT_REF (u64
, uint64
, 8);
3390 VM_DEFINE_OP (117, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3391 BV_INT_REF (s64
, int64
, 8);
3393 VM_DEFINE_OP (118, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3394 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
3396 VM_DEFINE_OP (119, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3397 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
3399 /* bv-u8-set! dst:8 idx:8 src:8
3400 * bv-s8-set! dst:8 idx:8 src:8
3401 * bv-u16-set! dst:8 idx:8 src:8
3402 * bv-s16-set! dst:8 idx:8 src:8
3403 * bv-u32-set! dst:8 idx:8 src:8
3404 * bv-s32-set! dst:8 idx:8 src:8
3405 * bv-u64-set! dst:8 idx:8 src:8
3406 * bv-s64-set! dst:8 idx:8 src:8
3407 * bv-f32-set! dst:8 idx:8 src:8
3408 * bv-f64-set! dst:8 idx:8 src:8
3410 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3411 * values are written using native endianness.
3413 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3415 scm_t_uint8 dst, idx, src; \
3416 scm_t_signed_bits i, j = 0; \
3417 SCM bv, scm_idx, val; \
3418 scm_t_ ## type *int_ptr; \
3420 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3421 bv = LOCAL_REF (dst); \
3422 scm_idx = LOCAL_REF (idx); \
3423 val = LOCAL_REF (src); \
3424 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3425 i = SCM_I_INUM (scm_idx); \
3426 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3428 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3430 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3431 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3432 && (SCM_I_INUMP (val)) \
3433 && ((j = SCM_I_INUM (val)) >= min) \
3435 *int_ptr = (scm_t_ ## type) j; \
3439 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3444 #define BV_INT_SET(stem, type, size) \
3446 scm_t_uint8 dst, idx, src; \
3447 scm_t_signed_bits i; \
3448 SCM bv, scm_idx, val; \
3449 scm_t_ ## type *int_ptr; \
3451 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3452 bv = LOCAL_REF (dst); \
3453 scm_idx = LOCAL_REF (idx); \
3454 val = LOCAL_REF (src); \
3455 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3456 i = SCM_I_INUM (scm_idx); \
3457 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3459 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3461 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3462 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3463 *int_ptr = scm_to_ ## type (val); \
3467 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3472 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3474 scm_t_uint8 dst, idx, src; \
3475 scm_t_signed_bits i; \
3476 SCM bv, scm_idx, val; \
3479 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3480 bv = LOCAL_REF (dst); \
3481 scm_idx = LOCAL_REF (idx); \
3482 val = LOCAL_REF (src); \
3483 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3484 i = SCM_I_INUM (scm_idx); \
3485 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3487 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3489 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3490 && (ALIGNED_P (float_ptr, type)))) \
3491 *float_ptr = scm_to_double (val); \
3495 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3500 VM_DEFINE_OP (120, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3501 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3503 VM_DEFINE_OP (121, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3504 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3506 VM_DEFINE_OP (122, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3507 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3509 VM_DEFINE_OP (123, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3510 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3512 VM_DEFINE_OP (124, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3513 #if SIZEOF_VOID_P > 4
3514 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3516 BV_INT_SET (u32
, uint32
, 4);
3519 VM_DEFINE_OP (125, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3520 #if SIZEOF_VOID_P > 4
3521 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3523 BV_INT_SET (s32
, int32
, 4);
3526 VM_DEFINE_OP (126, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3527 BV_INT_SET (u64
, uint64
, 8);
3529 VM_DEFINE_OP (127, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3530 BV_INT_SET (s64
, int64
, 8);
3532 VM_DEFINE_OP (128, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3533 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3535 VM_DEFINE_OP (129, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3536 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3538 END_DISPATCH_SWITCH
;
3540 vm_error_bad_instruction
:
3541 vm_error_bad_instruction (op
);
3543 abort (); /* never reached */
3547 #undef ABORT_CONTINUATION_HOOK
3552 #undef BEGIN_DISPATCH_SWITCH
3553 #undef BINARY_INTEGER_OP
3554 #undef BR_ARITHMETIC
3558 #undef BV_FIXABLE_INT_REF
3559 #undef BV_FIXABLE_INT_SET
3564 #undef CACHE_REGISTER
3565 #undef CHECK_OVERFLOW
3566 #undef END_DISPATCH_SWITCH
3567 #undef FREE_VARIABLE_REF
3576 #undef POP_CONTINUATION_HOOK
3577 #undef PUSH_CONTINUATION_HOOK
3578 #undef RESTORE_CONTINUATION_HOOK
3580 #undef RETURN_ONE_VALUE
3581 #undef RETURN_VALUE_LIST
3585 #undef SYNC_BEFORE_GC
3587 #undef SYNC_REGISTER
3588 #undef VARIABLE_BOUNDP
3591 #undef VM_CHECK_FREE_VARIABLE
3592 #undef VM_CHECK_OBJECT
3593 #undef VM_CHECK_UNDERFLOW
3595 #undef VM_INSTRUCTION_TO_LABEL
3597 #undef VM_VALIDATE_BYTEVECTOR
3598 #undef VM_VALIDATE_PAIR
3599 #undef VM_VALIDATE_STRUCT
3602 (defun renumber-ops ()
3603 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3606 (let ((counter -1)) (goto-char (point-min))
3607 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3609 (number-to-string (setq counter (1+ counter)))