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
489 #undef FREE_VARIABLE_REF
501 #undef RETURN_ONE_VALUE
502 #undef RETURN_VALUE_LIST
504 #undef SYNC_BEFORE_GC
507 #undef VARIABLE_BOUNDP
511 #undef VM_INSTRUCTION_TO_LABEL
518 This is Guile's new virtual machine. When I say "new", I mean
519 relative to the current virtual machine. At some point it will
520 become "the" virtual machine, and we'll delete this paragraph. As
521 such, the rest of the comments speak as if there's only one VM.
527 /* The VM has three state bits: the instruction pointer (IP), the frame
528 pointer (FP), and the top-of-stack pointer (SP). We cache the first
529 two of these in machine registers, local to the VM, because they are
530 used extensively by the VM. As the SP is used more by code outside
531 the VM than by the VM itself, we don't bother caching it locally.
533 Since the FP changes infrequently, relative to the IP, we keep vp->fp
534 in sync with the local FP. This would be a big lose for the IP,
535 though, so instead of updating vp->ip all the time, we call SYNC_IP
536 whenever we would need to know the IP of the top frame. In practice,
537 we need to SYNC_IP whenever we call out of the VM to a function that
538 would like to walk the stack, perhaps as the result of an
542 vp->ip = (scm_t_uint8 *) (ip)
544 #define SYNC_REGISTER() \
546 #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
547 #define SYNC_ALL() /* FP already saved */ \
550 #define CHECK_OVERFLOW(sp) \
552 if (SCM_UNLIKELY ((sp) >= stack_limit)) \
553 vm_error_stack_overflow (vp); \
556 /* Reserve stack space for a frame. Will check that there is sufficient
557 stack space for N locals, not including the procedure, in addition to
558 4 words to set up the next frame. Invoke after preparing the new
559 frame and setting the fp and ip. */
560 #define ALLOC_FRAME(n) \
562 SCM *new_sp = vp->sp = fp - 1 + n; \
563 CHECK_OVERFLOW (new_sp + 4); \
566 /* Reset the current frame to hold N locals. Used when we know that no
567 stack expansion is needed. */
568 #define RESET_FRAME(n) \
570 vp->sp = fp - 1 + n; \
573 /* Compute the number of locals in the frame. This is equal to the
574 number of actual arguments when a function is first called. */
575 #define FRAME_LOCALS_COUNT() \
578 /* Restore registers after returning from a frame. */
579 #define RESTORE_FRAME() \
584 #define CACHE_REGISTER() \
586 ip = (scm_t_uint32 *) vp->ip; \
590 #ifdef HAVE_LABELS_AS_VALUES
591 # define BEGIN_DISPATCH_SWITCH /* */
592 # define END_DISPATCH_SWITCH /* */
599 goto *jump_table[op & 0xff]; \
602 # define VM_DEFINE_OP(opcode, tag, name, meta) \
605 # define BEGIN_DISPATCH_SWITCH \
611 # define END_DISPATCH_SWITCH \
613 goto vm_error_bad_instruction; \
622 # define VM_DEFINE_OP(opcode, tag, name, meta) \
627 #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
628 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
630 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
631 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
632 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
633 #define FREE_VARIABLE_REF(i) SCM_RTL_PROGRAM_FREE_VARIABLE_REF (SCM_FRAME_PROGRAM (fp), i)
635 #define RETURN_ONE_VALUE(ret) \
638 SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
639 VM_HANDLE_INTERRUPTS; \
640 ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
642 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
644 POP_CONTINUATION_HOOK (sp, 1); \
648 /* While we could generate the list-unrolling code here, it's fine for
649 now to just tail-call (apply values vals). */
650 #define RETURN_VALUE_LIST(vals_) \
653 VM_HANDLE_INTERRUPTS; \
654 fp[-1] = rtl_apply; \
655 fp[0] = rtl_values; \
658 ip = (scm_t_uint32 *) rtl_apply_code; \
662 #define BR_NARGS(rel) \
663 scm_t_uint16 expected; \
664 SCM_UNPACK_RTL_24 (op, expected); \
665 if (FRAME_LOCALS_COUNT() rel expected) \
667 scm_t_int32 offset = ip[1]; \
668 offset >>= 8; /* Sign-extending shift. */ \
673 #define BR_UNARY(x, exp) \
676 SCM_UNPACK_RTL_24 (op, test); \
677 x = LOCAL_REF (test); \
678 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
680 scm_t_int32 offset = ip[1]; \
681 offset >>= 8; /* Sign-extending shift. */ \
683 VM_HANDLE_INTERRUPTS; \
688 #define BR_BINARY(x, y, exp) \
691 SCM_UNPACK_RTL_12_12 (op, a, b); \
694 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
696 scm_t_int32 offset = ip[1]; \
697 offset >>= 8; /* Sign-extending shift. */ \
699 VM_HANDLE_INTERRUPTS; \
704 #define BR_ARITHMETIC(crel,srel) \
708 SCM_UNPACK_RTL_12_12 (op, a, b); \
711 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
713 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
714 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
715 if (x_bits crel y_bits) \
717 scm_t_int32 offset = ip[1]; \
718 offset >>= 8; /* Sign-extending shift. */ \
720 VM_HANDLE_INTERRUPTS; \
728 if (scm_is_true (srel (x, y))) \
730 scm_t_int32 offset = ip[1]; \
731 offset >>= 8; /* Sign-extending shift. */ \
733 VM_HANDLE_INTERRUPTS; \
741 scm_t_uint16 dst, src; \
743 SCM_UNPACK_RTL_12_12 (op, dst, src); \
745 #define ARGS2(a1, a2) \
746 scm_t_uint8 dst, src1, src2; \
748 SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
749 a1 = LOCAL_REF (src1); \
750 a2 = LOCAL_REF (src2)
752 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
754 /* The maximum/minimum tagged integers. */
755 #define INUM_MAX (INTPTR_MAX - 1)
756 #define INUM_MIN (INTPTR_MIN + scm_tc2_int)
758 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
761 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
763 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
764 if (SCM_FIXABLE (n)) \
765 RETURN (SCM_I_MAKINUM (n)); \
768 RETURN (SFUNC (x, y)); \
771 #define VM_VALIDATE_PAIR(x, proc) \
772 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
774 #define VM_VALIDATE_STRUCT(obj, proc) \
775 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
777 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
778 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
780 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
781 #define ALIGNED_P(ptr, type) \
782 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
785 RTL_VM_NAME (SCM vm
, SCM program
, SCM
*argv
, size_t nargs_
)
787 /* Instruction pointer: A pointer to the opcode that is currently
789 register scm_t_uint32
*ip IP_REG
;
791 /* Frame pointer: A pointer into the stack, off of which we index
792 arguments and local variables. Pushed at function calls, popped on
794 register SCM
*fp FP_REG
;
796 /* Current opcode: A cache of *ip. */
797 register scm_t_uint32 op
;
799 /* Cached variables. */
800 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
801 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
802 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
803 scm_i_jmp_buf registers
; /* used for prompts */
805 #ifdef HAVE_LABELS_AS_VALUES
806 static const void **jump_table_pointer
= NULL
;
807 register const void **jump_table JT_REG
;
809 if (SCM_UNLIKELY (!jump_table_pointer
))
812 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
813 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
814 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
815 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
816 FOR_EACH_VM_OPERATION(INIT
);
820 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
821 load instruction at each instruction dispatch. */
822 jump_table
= jump_table_pointer
;
825 if (SCM_I_SETJMP (registers
))
827 /* Non-local return. The values are on the stack, on a new frame
828 set up to call `values' to return the values to the handler.
829 Cache the VM registers back from the vp, and dispatch to the
832 Note, at this point, we must assume that any variable local to
833 vm_engine that can be assigned *has* been assigned. So we need
834 to pull all our state back from the ip/fp/sp.
837 ABORT_CONTINUATION_HOOK (fp
, FRAME_LOCALS_COUNT());
841 /* Load previous VM registers. */
844 VM_HANDLE_INTERRUPTS
;
850 /* Check that we have enough space: 4 words for the boot
851 continuation, 4 + nargs for the procedure application, and 4 for
852 setting up a new frame. */
854 CHECK_OVERFLOW (vp
->sp
+ 4 + 4 + nargs_
+ 4);
856 /* Since it's possible to receive the arguments on the stack itself,
857 and indeed the regular VM invokes us that way, shuffle up the
861 for (i
= nargs_
- 1; i
>= 0; i
--)
862 base
[8 + i
] = argv
[i
];
865 /* Initial frame, saving previous fp and ip, with the boot
867 base
[0] = SCM_PACK (fp
); /* dynamic link */
868 base
[1] = SCM_PACK (0); /* the boot continuation does not return to scheme */
869 base
[2] = SCM_PACK (ip
); /* ra */
870 base
[3] = rtl_boot_continuation
;
872 ip
= rtl_boot_single_value_continuation_code
;
873 if (ip
- 1 != rtl_boot_multiple_value_continuation_code
)
876 /* MV-call frame, function & arguments */
877 base
[4] = SCM_PACK (fp
); /* dynamic link */
878 base
[5] = SCM_PACK (ip
- 1); /* in RTL programs, MVRA precedes RA by one */
879 base
[6] = SCM_PACK (ip
); /* ra */
881 fp
= vp
->fp
= &base
[8];
882 RESET_FRAME (nargs_
);
886 while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
889 SCM proc
= SCM_FRAME_PROGRAM (fp
);
891 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
893 fp
[-1] = SCM_STRUCT_PROCEDURE (proc
);
896 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
898 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
900 /* Shuffle args up, place smob in local 0. */
901 CHECK_OVERFLOW (vp
->sp
+ 1);
904 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
907 fp
[-1] = SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
;
912 vm_error_wrong_type_apply (proc
);
917 ret
= VM_NAME (vm
, fp
[-1], fp
, FRAME_LOCALS_COUNT ());
919 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
920 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
922 RETURN_ONE_VALUE (ret
);
927 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
930 BEGIN_DISPATCH_SWITCH
;
941 * Bring the VM to a halt, returning the single value from r0.
943 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
945 SCM ret
= LOCAL_REF (0);
947 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
948 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
949 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
956 * Bring the VM to a halt, returning all the values on the stack.
958 VM_DEFINE_OP (1, halt_values
, "halt/values", OP1 (U8_X24
))
967 n
= FRAME_LOCALS_COUNT ();
969 ret
= scm_cons (base
[n
], ret
);
971 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
972 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
973 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
975 return scm_values (ret
);
978 /* call from:24 _:8 proc:24 _:8 nargs:24 arg0:24 0:8 ...
980 * Call a procedure. Push a call frame on at FROM, saving the return
981 * address and the fp. Parse out NARGS, and push the procedure and
982 * arguments. All arguments except for RETURN-LOC are 24-bit values.
983 * FROM, PROC, and NARGS are in the upper 24 bits of the words. The
984 * ARGN... are in the lower 24 bits, with the upper 8 bits being 0.
986 * The MVRA of the new frame is set to point to the next instruction
987 * after the end of the `call' instruction. The word following that
990 VM_DEFINE_OP (2, call
, "call", OP3 (U8_U24
, X8_U24
, X8_R24
))
992 scm_t_uint32 from
, proc
, nargs
, n
;
995 SCM_UNPACK_RTL_24 (op
, from
);
996 SCM_UNPACK_RTL_24 (ip
[1], proc
);
997 SCM_UNPACK_RTL_24 (ip
[2], nargs
);
999 VM_HANDLE_INTERRUPTS
;
1001 fp
= vp
->fp
= old_fp
+ from
+ 4;
1002 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1003 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 3 + nargs
);
1004 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 4 + nargs
);
1005 fp
[-1] = old_fp
[proc
];
1006 ALLOC_FRAME (nargs
);
1008 for (n
= 0; n
< nargs
; n
++)
1009 LOCAL_SET (n
, old_fp
[ip
[3 + n
]]);
1011 PUSH_CONTINUATION_HOOK ();
1014 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1017 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1021 /* call/values from:24 _:8 proc:24
1023 * Call a procedure, with the values already pushed above a call frame
1024 * at FROM. This instruction is used to handle MV returns in the case
1025 * that we can't inline the handler.
1027 * As with `call', the next instruction after the call/values will be
1028 * the MVRA, and the word after that instruction is the RA.
1030 VM_DEFINE_OP (3, call_values
, "call/values", OP2 (U8_U24
, X8_U24
))
1032 scm_t_uint32 from
, proc
;
1035 SCM_UNPACK_RTL_24 (op
, from
);
1036 SCM_UNPACK_RTL_24 (ip
[1], proc
);
1038 VM_HANDLE_INTERRUPTS
;
1040 fp
= vp
->fp
= old_fp
+ from
+ 4;
1041 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1042 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 2);
1043 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 3);
1044 fp
[-1] = old_fp
[proc
];
1046 PUSH_CONTINUATION_HOOK ();
1049 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1052 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1056 /* tail-call nargs:24 _:8 proc:24
1058 * Tail-call a procedure. Requires that all of the arguments have
1059 * already been shuffled into position.
1061 VM_DEFINE_OP (4, tail_call
, "tail-call", OP2 (U8_U24
, X8_U24
))
1063 scm_t_uint32 nargs
, proc
;
1065 SCM_UNPACK_RTL_24 (op
, nargs
);
1066 SCM_UNPACK_RTL_24 (ip
[1], proc
);
1068 VM_HANDLE_INTERRUPTS
;
1070 fp
[-1] = LOCAL_REF (proc
);
1071 /* No need to check for overflow, as the compiler has already
1072 ensured that this frame has enough space. */
1073 RESET_FRAME (nargs
);
1077 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1080 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1088 VM_DEFINE_OP (5, return, "return", OP1 (U8_U24
))
1091 SCM_UNPACK_RTL_24 (op
, src
);
1092 RETURN_ONE_VALUE (LOCAL_REF (src
));
1095 /* return-values nvalues:24
1097 * Return a number of values from a call frame. This opcode
1098 * corresponds to an application of `values' in tail position. As
1099 * with tail calls, we expect that the NVALUES values have already
1100 * been shuffled down to a contiguous array starting at slot 0.
1102 VM_DEFINE_OP (6, return_values
, "return/values", OP1 (U8_U24
))
1105 SCM_UNPACK_RTL_24 (op
, nargs
);
1106 RESET_FRAME (nargs
);
1107 fp
[-1] = rtl_values
;
1115 * Specialized call stubs
1118 /* subr-call ptr-idx:24
1120 * Call a subr, passing all locals in this frame as arguments. Fetch
1121 * the foreign pointer from PTR-IDX, a free variable. Return from the
1122 * calling frame. This instruction is part of the trampolines
1123 * created in gsubr.c, and is not generated by the compiler.
1125 VM_DEFINE_OP (7, subr_call
, "subr-call", OP1 (U8_U24
))
1127 scm_t_uint32 ptr_idx
;
1131 SCM_UNPACK_RTL_24 (op
, ptr_idx
);
1133 pointer
= FREE_VARIABLE_REF (ptr_idx
);
1134 subr
= SCM_POINTER_VALUE (pointer
);
1136 VM_HANDLE_INTERRUPTS
;
1139 switch (FRAME_LOCALS_COUNT ())
1148 ret
= subr (fp
[0], fp
[1]);
1151 ret
= subr (fp
[0], fp
[1], fp
[2]);
1154 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3]);
1157 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4]);
1160 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
1163 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
1166 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
1169 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
1172 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
1178 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1180 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1181 /* multiple values returned to continuation */
1182 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1184 RETURN_ONE_VALUE (ret
);
1187 /* foreign-call cif-idx:12 ptr-idx:12
1189 * Call a foreign function. Fetch the CIF and foreign pointer from
1190 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1191 * frame. Arguments are taken from the stack. This instruction is
1192 * part of the trampolines created by the FFI, and is not generated by
1195 VM_DEFINE_OP (8, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
1197 scm_t_uint16 cif_idx
, ptr_idx
;
1198 SCM cif
, pointer
, ret
;
1200 SCM_UNPACK_RTL_12_12 (op
, cif_idx
, ptr_idx
);
1202 cif
= FREE_VARIABLE_REF (cif_idx
);
1203 pointer
= FREE_VARIABLE_REF (ptr_idx
);
1206 VM_HANDLE_INTERRUPTS
;
1208 // FIXME: separate args
1209 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), fp
);
1211 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1213 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1214 /* multiple values returned to continuation */
1215 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1217 RETURN_ONE_VALUE (ret
);
1220 /* continuation-call contregs:24
1222 * Return to a continuation, nonlocally. The arguments to the
1223 * continuation are taken from the stack. CONTREGS is a free variable
1224 * containing the reified continuation. This instruction is part of
1225 * the implementation of undelimited continuations, and is not
1226 * generated by the compiler.
1228 VM_DEFINE_OP (9, continuation_call
, "continuation-call", OP1 (U8_U24
))
1231 scm_t_uint32 contregs_idx
;
1233 SCM_UNPACK_RTL_24 (op
, contregs_idx
);
1235 contregs
= FREE_VARIABLE_REF (contregs_idx
);
1238 scm_i_check_continuation (contregs
);
1239 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
1240 scm_i_contregs_vm_cont (contregs
),
1241 FRAME_LOCALS_COUNT (), fp
);
1242 scm_i_reinstate_continuation (contregs
);
1248 /* compose-continuation cont:24
1250 * Compose a partial continution with the current continuation. The
1251 * arguments to the continuation are taken from the stack. CONT is a
1252 * free variable containing the reified continuation. This
1253 * instruction is part of the implementation of partial continuations,
1254 * and is not generated by the compiler.
1256 VM_DEFINE_OP (10, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
1259 scm_t_uint32 cont_idx
;
1261 SCM_UNPACK_RTL_24 (op
, cont_idx
);
1262 vmcont
= LOCAL_REF (cont_idx
);
1265 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
1266 vm_error_continuation_not_rewindable (vmcont
));
1267 vm_reinstate_partial_continuation (vm
, vmcont
, FRAME_LOCALS_COUNT (), fp
,
1268 ¤t_thread
->dynstack
,
1276 * Tail-apply the procedure in local slot 0 to the rest of the
1277 * arguments. This instruction is part of the implementation of
1278 * `apply', and is not generated by the compiler.
1280 VM_DEFINE_OP (11, apply
, "apply", OP1 (U8_X24
))
1282 int i
, list_idx
, list_len
, nargs
;
1285 VM_HANDLE_INTERRUPTS
;
1287 VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
1288 nargs
= FRAME_LOCALS_COUNT ();
1289 list_idx
= nargs
- 1;
1290 list
= LOCAL_REF (list_idx
);
1291 list_len
= scm_ilength (list
);
1293 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
1295 nargs
= nargs
- 2 + list_len
;
1296 ALLOC_FRAME (nargs
);
1298 for (i
= 0; i
< list_idx
; i
++)
1301 /* Null out these slots, just in case there are less than 2 elements
1303 fp
[list_idx
- 1] = SCM_UNDEFINED
;
1304 fp
[list_idx
] = SCM_UNDEFINED
;
1306 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
1307 fp
[list_idx
- 1 + i
] = SCM_CAR (list
);
1311 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1314 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1320 * Capture the current continuation, and tail-apply the procedure in
1321 * local slot 0 to it. This instruction is part of the implementation
1322 * of `call/cc', and is not generated by the compiler.
1324 VM_DEFINE_OP (12, call_cc
, "call/cc", OP1 (U8_X24
))
1328 scm_t_dynstack
*dynstack
;
1330 VM_HANDLE_INTERRUPTS
;
1333 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
1334 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1335 SCM_FRAME_DYNAMIC_LINK (fp
),
1336 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1337 SCM_FRAME_RETURN_ADDRESS (fp
),
1338 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1341 cont
= scm_i_make_continuation (®isters
, vm
, vm_cont
);
1349 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1352 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1361 * Return all values on the stack to the current continuation.
1362 * This instruction is part of the implementation of
1363 * `values', and is not generated by the compiler.
1365 VM_DEFINE_OP (13, values
, "values", OP1 (U8_X24
))
1369 int nargs
= FRAME_LOCALS_COUNT ();
1372 /* We don't do much; it's the caller that's responsible for
1373 shuffling values and resetting the stack. */
1375 VM_HANDLE_INTERRUPTS
;
1376 ip
= SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp
);
1377 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1379 /* Clear stack frame. */
1380 base
[-1] = SCM_BOOL_F
;
1381 base
[-2] = SCM_BOOL_F
;
1382 base
[-3] = SCM_BOOL_F
;
1383 base
[-4] = SCM_BOOL_F
;
1385 POP_CONTINUATION_HOOK (base
, nargs
);
1394 * Function prologues
1397 /* br-if-nargs-ne expected:24 _:8 offset:24
1398 * br-if-nargs-lt expected:24 _:8 offset:24
1399 * br-if-nargs-gt expected:24 _:8 offset:24
1401 * If the number of actual arguments is not equal, less than, or greater
1402 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1403 * the current instruction pointer.
1405 VM_DEFINE_OP (14, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1409 VM_DEFINE_OP (15, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1413 VM_DEFINE_OP (16, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1418 /* assert-nargs-ee expected:24
1419 * assert-nargs-ge expected:24
1420 * assert-nargs-le expected:24
1422 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1423 * respectively, signal an error.
1425 VM_DEFINE_OP (17, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1427 scm_t_uint32 expected
;
1428 SCM_UNPACK_RTL_24 (op
, expected
);
1429 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1430 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1433 VM_DEFINE_OP (18, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1435 scm_t_uint32 expected
;
1436 SCM_UNPACK_RTL_24 (op
, expected
);
1437 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1438 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1441 VM_DEFINE_OP (19, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1443 scm_t_uint32 expected
;
1444 SCM_UNPACK_RTL_24 (op
, expected
);
1445 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1446 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1450 /* reserve-locals nlocals:24
1452 * Ensure that there is space on the stack for NLOCALS local variables,
1453 * setting them all to SCM_UNDEFINED, except those nargs values that
1454 * were passed as arguments.
1456 VM_DEFINE_OP (20, reserve_locals
, "reserve-locals", OP1 (U8_U24
))
1458 scm_t_uint32 nlocals
, nargs
;
1459 SCM_UNPACK_RTL_24 (op
, nlocals
);
1461 nargs
= FRAME_LOCALS_COUNT ();
1462 ALLOC_FRAME (nlocals
);
1463 while (nlocals
-- > nargs
)
1464 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1469 /* assert-nargs-ee/locals expected:12 nlocals:12
1471 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1472 * number of locals reserved is EXPECTED + NLOCALS.
1474 VM_DEFINE_OP (21, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1476 scm_t_uint16 expected
, nlocals
;
1477 SCM_UNPACK_RTL_12_12 (op
, expected
, nlocals
);
1478 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1479 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1480 ALLOC_FRAME (expected
+ nlocals
);
1482 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1487 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1488 * _:8 ntotal:24 kw-offset:32
1490 * Find the last positional argument, and shuffle all the rest above
1491 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1492 * load the constant at KW-OFFSET words from the current IP, and use it
1493 * to bind keyword arguments. If HAS-REST, collect all shuffled
1494 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1495 * the arguments that we shuffled up.
1497 * A macro-mega-instruction.
1499 VM_DEFINE_OP (22, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1501 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1502 scm_t_int32 kw_offset
;
1505 char allow_other_keys
, has_rest
;
1507 SCM_UNPACK_RTL_24 (op
, nreq
);
1508 allow_other_keys
= ip
[1] & 0x1;
1509 has_rest
= ip
[1] & 0x2;
1510 SCM_UNPACK_RTL_24 (ip
[1], nreq_and_opt
);
1511 SCM_UNPACK_RTL_24 (ip
[2], ntotal
);
1513 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1514 VM_ASSERT (!(kw_bits
& 0x7), abort());
1515 kw
= SCM_PACK (kw_bits
);
1517 nargs
= FRAME_LOCALS_COUNT ();
1519 /* look in optionals for first keyword or last positional */
1520 /* starting after the last required positional arg */
1522 while (/* while we have args */
1524 /* and we still have positionals to fill */
1525 && npositional
< nreq_and_opt
1526 /* and we haven't reached a keyword yet */
1527 && !scm_is_keyword (LOCAL_REF (npositional
)))
1528 /* bind this optional arg (by leaving it in place) */
1530 nkw
= nargs
- npositional
;
1531 /* shuffle non-positional arguments above ntotal */
1532 ALLOC_FRAME (ntotal
+ nkw
);
1535 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1536 /* and fill optionals & keyword args with SCM_UNDEFINED */
1539 LOCAL_SET (n
++, SCM_UNDEFINED
);
1541 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1542 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1544 /* Now bind keywords, in the order given. */
1545 for (n
= 0; n
< nkw
; n
++)
1546 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1549 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1550 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1552 SCM si
= SCM_CDAR (walk
);
1553 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1554 LOCAL_REF (ntotal
+ n
+ 1));
1557 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1558 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1559 LOCAL_REF (ntotal
+ n
)));
1563 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1564 LOCAL_REF (ntotal
+ n
)));
1571 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1572 LOCAL_SET (nreq_and_opt
, rest
);
1575 RESET_FRAME (ntotal
);
1582 * Collect any arguments at or above DST into a list, and store that
1585 VM_DEFINE_OP (23, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1587 scm_t_uint32 dst
, nargs
;
1590 SCM_UNPACK_RTL_24 (op
, dst
);
1591 nargs
= FRAME_LOCALS_COUNT ();
1593 while (nargs
-- > dst
)
1595 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1596 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1599 LOCAL_SET (dst
, rest
);
1601 RESET_FRAME (dst
+ 1);
1606 /* drop-values nlocals:24
1608 * Reset the stack pointer to only have space for NLOCALS values.
1609 * Used after extracting values from an MV return.
1611 VM_DEFINE_OP (24, drop_values
, "drop-values", OP1 (U8_U24
))
1615 SCM_UNPACK_RTL_24 (op
, nlocals
);
1617 RESET_FRAME (nlocals
);
1626 * Branching instructions
1631 * Add OFFSET, a signed 24-bit number, to the current instruction
1634 VM_DEFINE_OP (25, br
, "br", OP1 (U8_L24
))
1636 scm_t_int32 offset
= op
;
1637 offset
>>= 8; /* Sign-extending shift. */
1641 /* br-if-true test:24 invert:1 _:7 offset:24
1643 * If the value in TEST is true for the purposes of Scheme, add
1644 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1646 VM_DEFINE_OP (26, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1648 BR_UNARY (x
, scm_is_true (x
));
1651 /* br-if-null test:24 invert:1 _:7 offset:24
1653 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1654 * signed 24-bit number, to the current instruction pointer.
1656 VM_DEFINE_OP (27, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1658 BR_UNARY (x
, scm_is_null (x
));
1661 /* br-if-nil test:24 invert:1 _:7 offset:24
1663 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1664 * number, to the current instruction pointer.
1666 VM_DEFINE_OP (28, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1668 BR_UNARY (x
, scm_is_lisp_false (x
));
1671 /* br-if-pair test:24 invert:1 _:7 offset:24
1673 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1674 * to the current instruction pointer.
1676 VM_DEFINE_OP (29, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1678 BR_UNARY (x
, scm_is_pair (x
));
1681 /* br-if-struct test:24 invert:1 _:7 offset:24
1683 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1684 * number, to the current instruction pointer.
1686 VM_DEFINE_OP (30, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1688 BR_UNARY (x
, SCM_STRUCTP (x
));
1691 /* br-if-char test:24 invert:1 _:7 offset:24
1693 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1694 * to the current instruction pointer.
1696 VM_DEFINE_OP (31, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1698 BR_UNARY (x
, SCM_CHARP (x
));
1701 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1703 * If the value in TEST has the TC7 given in the second word, add
1704 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1706 VM_DEFINE_OP (32, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1708 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1711 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1713 * If the value in A is eq? to the value in B, add OFFSET, a signed
1714 * 24-bit number, to the current instruction pointer.
1716 VM_DEFINE_OP (33, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1718 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1721 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1723 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1724 * 24-bit number, to the current instruction pointer.
1726 VM_DEFINE_OP (34, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1730 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1731 && scm_is_true (scm_eqv_p (x
, y
))));
1734 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1736 * If the value in A is equal? to the value in B, add OFFSET, a signed
1737 * 24-bit number, to the current instruction pointer.
1739 // FIXME: should sync_ip before calling out?
1740 VM_DEFINE_OP (35, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1744 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1745 && scm_is_true (scm_equal_p (x
, y
))));
1748 /* br-if-= a:12 b:12 _:8 offset:24
1750 * If the value in A is = to the value in B, add OFFSET, a signed
1751 * 24-bit number, to the current instruction pointer.
1753 VM_DEFINE_OP (36, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, X8_L24
))
1755 BR_ARITHMETIC (==, scm_num_eq_p
);
1758 /* br-if-< a:12 b:12 _:8 offset:24
1760 * If the value in A is < to the value in B, add OFFSET, a signed
1761 * 24-bit number, to the current instruction pointer.
1763 VM_DEFINE_OP (37, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, X8_L24
))
1765 BR_ARITHMETIC (<, scm_less_p
);
1768 /* br-if-<= a:12 b:12 _:8 offset:24
1770 * If the value in A is <= to the value in B, add OFFSET, a signed
1771 * 24-bit number, to the current instruction pointer.
1773 VM_DEFINE_OP (38, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, X8_L24
))
1775 BR_ARITHMETIC (<=, scm_leq_p
);
1778 /* br-if-> a:12 b:12 _:8 offset:24
1780 * If the value in A is > to the value in B, add OFFSET, a signed
1781 * 24-bit number, to the current instruction pointer.
1783 VM_DEFINE_OP (39, br_if_gt
, "br-if->", OP2 (U8_U12_U12
, X8_L24
))
1785 BR_ARITHMETIC (>, scm_gr_p
);
1788 /* br-if->= a:12 b:12 _:8 offset:24
1790 * If the value in A is >= to the value in B, add OFFSET, a signed
1791 * 24-bit number, to the current instruction pointer.
1793 VM_DEFINE_OP (40, br_if_ge
, "br-if->=", OP2 (U8_U12_U12
, X8_L24
))
1795 BR_ARITHMETIC (>=, scm_geq_p
);
1802 * Lexical binding instructions
1805 /* mov dst:12 src:12
1807 * Copy a value from one local slot to another.
1809 VM_DEFINE_OP (41, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1814 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1815 LOCAL_SET (dst
, LOCAL_REF (src
));
1820 /* long-mov dst:24 _:8 src:24
1822 * Copy a value from one local slot to another.
1824 VM_DEFINE_OP (42, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1829 SCM_UNPACK_RTL_24 (op
, dst
);
1830 SCM_UNPACK_RTL_24 (ip
[1], src
);
1831 LOCAL_SET (dst
, LOCAL_REF (src
));
1836 /* box dst:12 src:12
1838 * Create a new variable holding SRC, and place it in DST.
1840 VM_DEFINE_OP (43, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1842 scm_t_uint16 dst
, src
;
1843 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1844 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1850 * Create a new unbound variable, and place it in DST. Used in the
1851 * general implementation of `letrec', in those cases that fix-letrec
1854 VM_DEFINE_OP (44, empty_box
, "empty-box", OP1 (U8_U24
) | OP_DST
)
1857 SCM_UNPACK_RTL_24 (op
, dst
);
1858 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (SCM_UNDEFINED
)));
1862 /* box-ref dst:12 src:12
1864 * Unpack the variable at SRC into DST, asserting that the variable is
1867 VM_DEFINE_OP (45, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1869 scm_t_uint16 dst
, src
;
1871 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1872 var
= LOCAL_REF (src
);
1873 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1874 if (SCM_UNLIKELY (!VARIABLE_BOUNDP (var
)))
1877 /* Attempt to provide the variable name in the error message. */
1879 var_name
= scm_module_reverse_lookup (scm_current_module (), var
);
1880 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), scm_is_true (var_name
) ? var_name
: var
);
1882 LOCAL_SET (dst
, VARIABLE_REF (var
));
1886 /* box-set! dst:12 src:12
1888 * Set the contents of the variable at DST to SET.
1890 VM_DEFINE_OP (46, box_set
, "box-set!", OP1 (U8_U12_U12
) | OP_DST
)
1892 scm_t_uint16 dst
, src
;
1894 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1895 var
= LOCAL_REF (dst
);
1896 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1897 VARIABLE_SET (var
, LOCAL_REF (src
));
1901 /* free-ref dst:12 src:12
1903 * Load free variable SRC into local slot DST.
1905 VM_DEFINE_OP (47, free_ref
, "free-ref", OP1 (U8_U12_U12
) | OP_DST
)
1907 scm_t_uint16 dst
, src
;
1908 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1909 CHECK_FREE_VARIABLE (src
);
1910 LOCAL_SET (dst
, FREE_VARIABLE_REF (src
));
1914 /* make-closure dst:24 offset:32 _:8 nfree:24 free0:24 0:8 ...
1916 * Make a new closure, and write it to DST. The code for the closure
1917 * will be found at OFFSET words from the current IP. OFFSET is a
1918 * signed 32-bit integer. The registers for the NFREE free variables
1921 VM_DEFINE_OP (48, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_R24
) | OP_DST
)
1923 scm_t_uint32 dst
, nfree
, n
;
1927 SCM_UNPACK_RTL_24 (op
, dst
);
1929 SCM_UNPACK_RTL_24 (ip
[2], nfree
);
1931 // FIXME: Assert range of nfree?
1932 closure
= scm_words (scm_tc7_rtl_program
| (nfree
<< 16), nfree
+ 2);
1933 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1934 for (n
= 0; n
< nfree
; n
++)
1935 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure
, n
, LOCAL_REF (ip
[n
+ 3]));
1936 LOCAL_SET (dst
, closure
);
1940 /* fix-closure dst:24 _:8 nfree:24 free0:24 0:8 ...
1942 * "Fix" a closure. This is used for lambda expressions bound in a
1943 * <fix>, but which are not always called in tail position. In that
1944 * case we allocate the closures first, then destructively update their
1945 * free variables to point to each other. NFREE and the locals FREE0...
1946 * are as in make-closure.
1948 VM_DEFINE_OP (49, fix_closure
, "fix-closure", OP2 (U8_U24
, X8_R24
))
1950 scm_t_uint32 dst
, nfree
, n
;
1953 SCM_UNPACK_RTL_24 (op
, dst
);
1954 SCM_UNPACK_RTL_24 (ip
[1], nfree
);
1955 closure
= LOCAL_REF (dst
);
1956 for (n
= 0; n
< nfree
; n
++)
1957 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure
, n
, LOCAL_REF (ip
[n
+ 2]));
1965 * Immediates and statically allocated non-immediates
1968 /* make-short-immediate dst:8 low-bits:16
1970 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1973 VM_DEFINE_OP (50, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1978 SCM_UNPACK_RTL_8_16 (op
, dst
, val
);
1979 LOCAL_SET (dst
, SCM_PACK (val
));
1983 /* make-long-immediate dst:24 low-bits:32
1985 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1988 VM_DEFINE_OP (51, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1993 SCM_UNPACK_RTL_24 (op
, dst
);
1995 LOCAL_SET (dst
, SCM_PACK (val
));
1999 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
2001 * Make an immediate with HIGH-BITS and LOW-BITS.
2003 VM_DEFINE_OP (52, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
2008 SCM_UNPACK_RTL_24 (op
, dst
);
2009 #if SIZEOF_SCM_T_BITS > 4
2014 ASSERT (ip
[1] == 0);
2017 LOCAL_SET (dst
, SCM_PACK (val
));
2021 /* make-non-immediate dst:24 offset:32
2023 * Load a pointer to statically allocated memory into DST. The
2024 * object's memory is will be found OFFSET 32-bit words away from the
2025 * current instruction pointer. OFFSET is a signed value. The
2026 * intention here is that the compiler would produce an object file
2027 * containing the words of a non-immediate object, and this
2028 * instruction creates a pointer to that memory, effectively
2029 * resurrecting that object.
2031 * Whether the object is mutable or immutable depends on where it was
2032 * allocated by the compiler, and loaded by the loader.
2034 VM_DEFINE_OP (53, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
2039 scm_t_bits unpacked
;
2041 SCM_UNPACK_RTL_24 (op
, dst
);
2044 unpacked
= (scm_t_bits
) loc
;
2046 VM_ASSERT (!(unpacked
& 0x7), abort());
2048 LOCAL_SET (dst
, SCM_PACK (unpacked
));
2053 /* static-ref dst:24 offset:32
2055 * Load a SCM value into DST. The SCM value will be fetched from
2056 * memory, OFFSET 32-bit words away from the current instruction
2057 * pointer. OFFSET is a signed value.
2059 * The intention is for this instruction to be used to load constants
2060 * that the compiler is unable to statically allocate, like symbols.
2061 * These values would be initialized when the object file loads.
2063 VM_DEFINE_OP (54, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
2068 scm_t_uintptr loc_bits
;
2070 SCM_UNPACK_RTL_24 (op
, dst
);
2073 loc_bits
= (scm_t_uintptr
) loc
;
2074 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2076 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
2081 /* static-set! src:24 offset:32
2083 * Store a SCM value into memory, OFFSET 32-bit words away from the
2084 * current instruction pointer. OFFSET is a signed value.
2086 VM_DEFINE_OP (55, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
2092 SCM_UNPACK_RTL_24 (op
, src
);
2095 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2097 *((SCM
*) loc
) = LOCAL_REF (src
);
2102 /* link-procedure! src:24 offset:32
2104 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2105 * words away from the current instruction pointer. OFFSET is a
2108 VM_DEFINE_OP (56, link_procedure
, "link-procedure!", OP2 (U8_U24
, L32
))
2114 SCM_UNPACK_RTL_24 (op
, src
);
2118 SCM_SET_CELL_WORD_1 (LOCAL_REF (src
), (scm_t_bits
) loc
);
2126 * Mutable top-level bindings
2129 /* There are three slightly different ways to resolve toplevel
2132 1. A toplevel reference outside of a function. These need to be
2133 looked up when the expression is evaluated -- no later, and no
2134 before. They are looked up relative to the module that is
2135 current when the expression is evaluated. For example:
2139 The "resolve" instruction resolves the variable (box), and then
2140 access is via box-ref or box-set!.
2142 2. A toplevel reference inside a function. These are looked up
2143 relative to the module that was current when the function was
2144 defined. Unlike code at the toplevel, which is usually run only
2145 once, these bindings benefit from memoized lookup, in which the
2146 variable resulting from the lookup is cached in the function.
2148 (lambda () (if (foo) a b))
2150 Although one can use resolve and box-ref, the toplevel-ref and
2151 toplevel-set! instructions are better for references.
2153 3. A reference to an identifier with respect to a particular
2154 module. This can happen for primitive references, and
2155 references residualized by macro expansions. These can be
2156 cached or not, depending on whether they are in a lambda or not.
2161 For these, one can use resolve-module, resolve, and the box
2162 interface, though there is also module-ref as a shortcut.
2165 /* current-module dst:24
2167 * Store the current module in DST.
2169 VM_DEFINE_OP (57, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
2173 SCM_UNPACK_RTL_24 (op
, dst
);
2176 LOCAL_SET (dst
, scm_current_module ());
2181 /* resolve dst:8 mod:8 sym:8
2183 * Resolve SYM in MOD, and place the resulting variable in DST.
2185 VM_DEFINE_OP (58, resolve
, "resolve", OP1 (U8_U8_U8_U8
) | OP_DST
)
2187 scm_t_uint8 dst
, mod
, sym
;
2189 SCM_UNPACK_RTL_8_8_8 (op
, dst
, mod
, sym
);
2192 LOCAL_SET (dst
, scm_module_lookup (LOCAL_REF (mod
), LOCAL_REF (sym
)));
2197 /* resolve-module dst:8 name:8 public:8
2199 * Resolve a module with name NAME, placing it in DST. If PUBLIC is
2200 * nonzero, resolve the public interface, otherwise use the private
2203 VM_DEFINE_OP (59, resolve_module
, "resolve-module", OP1 (U8_U8_U8_U8
) | OP_DST
)
2205 scm_t_uint8 dst
, name
, public;
2208 SCM_UNPACK_RTL_8_8_8 (op
, dst
, name
, public);
2211 mod
= scm_resolve_module (LOCAL_REF (name
));
2213 mod
= scm_module_public_interface (mod
);
2214 LOCAL_SET (dst
, mod
);
2219 /* define sym:12 val:12
2221 * Look up a binding for SYM in the current module, creating it if
2222 * necessary. Set its value to VAL.
2224 VM_DEFINE_OP (60, define
, "define", OP1 (U8_U12_U12
))
2226 scm_t_uint16 sym
, val
;
2227 SCM_UNPACK_RTL_12_12 (op
, sym
, val
);
2229 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
2233 /* toplevel-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
2235 * Load a SCM value. The SCM value will be fetched from memory,
2236 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2237 * VAR-OFFSET is a signed value. Up to here, toplevel-ref is like
2240 * Then, if the loaded value is a variable, the value of the variable
2241 * is placed in DST, and control flow continues.
2243 * Otherwise, we have to resolve the variable. In that case we load
2244 * the module from MOD-OFFSET, just as we loaded the variable.
2245 * Usually the module gets set when the closure is created. The name
2246 * is an offset to a symbol.
2248 * We use the module and the string to resolve the variable, raising
2249 * an error if it is unbound, unbox it into DST, and cache the
2250 * resolved variable so that we will hit the cache next time.
2252 VM_DEFINE_OP (61, toplevel_ref
, "toplevel-ref", OP4 (U8_U24
, S32
, S32
, N32
) | OP_DST
)
2255 scm_t_int32 var_offset
;
2256 scm_t_uint32
* var_loc_u32
;
2260 SCM_UNPACK_RTL_24 (op
, dst
);
2262 var_loc_u32
= ip
+ var_offset
;
2263 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2264 var_loc
= (SCM
*) var_loc_u32
;
2267 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2270 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2271 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2272 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2273 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2277 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2278 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2280 mod
= *((SCM
*) mod_loc
);
2281 sym
= *((SCM
*) sym_loc
);
2283 var
= scm_module_lookup (mod
, sym
);
2284 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2289 LOCAL_SET (dst
, VARIABLE_REF (var
));
2293 /* toplevel-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
2295 * Set a top-level variable from a variable cache cell. The variable
2296 * is resolved as in toplevel-ref.
2298 VM_DEFINE_OP (62, toplevel_set
, "toplevel-set!", OP4 (U8_U24
, S32
, S32
, N32
))
2301 scm_t_int32 var_offset
;
2302 scm_t_uint32
* var_loc_u32
;
2306 SCM_UNPACK_RTL_24 (op
, src
);
2308 var_loc_u32
= ip
+ var_offset
;
2309 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2310 var_loc
= (SCM
*) var_loc_u32
;
2313 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2316 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2317 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2318 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2319 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2323 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2324 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2326 mod
= *((SCM
*) mod_loc
);
2327 sym
= *((SCM
*) sym_loc
);
2329 var
= scm_module_lookup (mod
, sym
);
2334 VARIABLE_SET (var
, LOCAL_REF (src
));
2338 /* module-ref dst:24 var-offset:32 mod-offset:32 sym-offset:32
2340 * Like toplevel-ref, except MOD-OFFSET points at the name of a module
2341 * instead of the module itself.
2343 VM_DEFINE_OP (63, module_ref
, "module-ref", OP4 (U8_U24
, S32
, N32
, N32
) | OP_DST
)
2346 scm_t_int32 var_offset
;
2347 scm_t_uint32
* var_loc_u32
;
2351 SCM_UNPACK_RTL_24 (op
, dst
);
2353 var_loc_u32
= ip
+ var_offset
;
2354 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2355 var_loc
= (SCM
*) var_loc_u32
;
2358 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2361 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2362 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2363 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2364 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2368 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2369 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2371 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2372 sym
= *((SCM
*) sym_loc
);
2374 if (scm_is_true (SCM_CAR (modname
)))
2375 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2377 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2379 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2384 LOCAL_SET (dst
, VARIABLE_REF (var
));
2388 /* module-set! src:24 var-offset:32 mod-offset:32 sym-offset:32
2390 * Like toplevel-set!, except MOD-OFFSET points at the name of a module
2391 * instead of the module itself.
2393 VM_DEFINE_OP (64, module_set
, "module-set!", OP4 (U8_U24
, S32
, N32
, N32
))
2396 scm_t_int32 var_offset
;
2397 scm_t_uint32
* var_loc_u32
;
2401 SCM_UNPACK_RTL_24 (op
, src
);
2403 var_loc_u32
= ip
+ var_offset
;
2404 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2405 var_loc
= (SCM
*) var_loc_u32
;
2408 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2411 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2412 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2413 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2414 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2418 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2419 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2421 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2422 sym
= *((SCM
*) sym_loc
);
2424 if (scm_is_true (SCM_CAR (modname
)))
2425 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2427 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2432 VARIABLE_SET (var
, LOCAL_REF (src
));
2439 * The dynamic environment
2442 /* prompt tag:24 flags:8 handler-offset:24
2444 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2445 * handler at HANDLER-OFFSET words from the current IP. The handler
2446 * will expect a multiple-value return.
2448 VM_DEFINE_OP (65, prompt
, "prompt", OP2 (U8_U24
, U8_L24
))
2453 scm_t_uint8 escape_only_p
;
2454 scm_t_dynstack_prompt_flags flags
;
2456 SCM_UNPACK_RTL_24 (op
, tag
);
2457 escape_only_p
= ip
[1] & 0xff;
2459 offset
>>= 8; /* Sign extension */
2461 /* Push the prompt onto the dynamic stack. */
2462 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2463 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2465 fp
, vp
->sp
, ip
+ offset
, ®isters
);
2472 /* wind winder:12 unwinder:12
2474 * Push wind and unwind procedures onto the dynamic stack. Note that
2475 * neither are actually called; the compiler should emit calls to wind
2476 * and unwind for the normal dynamic-wind control flow. Also note that
2477 * the compiler should have inserted checks that they wind and unwind
2478 * procs are thunks, if it could not prove that to be the case.
2480 VM_DEFINE_OP (66, wind
, "wind", OP1 (U8_U12_U12
))
2482 scm_t_uint16 winder
, unwinder
;
2483 SCM_UNPACK_RTL_12_12 (op
, winder
, unwinder
);
2484 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2485 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2489 /* abort tag:24 _:8 nvalues:24 val0:24 0:8 val1:24 0:8 ...
2491 * Return a number of values to a prompt handler. The values VAL0,
2492 * VAL1, etc are 24-bit values, in the lower 24 bits of their words.
2493 * The upper 8 bits are 0.
2495 VM_DEFINE_OP (67, abort
, "abort", OP2 (U8_U24
, X8_R24
))
2498 scm_t_uint32 tag
, nvalues
;
2500 SCM_UNPACK_RTL_24 (op
, tag
);
2501 SCM_UNPACK_RTL_24 (ip
[1], nvalues
);
2504 vm_abort (vm
, LOCAL_REF (tag
), nvalues
, &ip
[2], ®isters
);
2506 /* vm_abort should not return */
2515 * A normal exit from the dynamic extent of an expression. Pop the top
2516 * entry off of the dynamic stack.
2518 VM_DEFINE_OP (68, unwind
, "unwind", OP1 (U8_X24
))
2520 scm_dynstack_pop (¤t_thread
->dynstack
);
2524 /* push-fluid fluid:12 value:12
2526 * Dynamically bind N fluids to values. The fluids are expected to be
2527 * allocated in a continguous range on the stack, starting from
2528 * FLUID-BASE. The values do not have this restriction.
2530 VM_DEFINE_OP (69, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2532 scm_t_uint32 fluid
, value
;
2534 SCM_UNPACK_RTL_12_12 (op
, fluid
, value
);
2536 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2537 fp
[fluid
], fp
[value
],
2538 current_thread
->dynamic_state
);
2544 * Leave the dynamic extent of a with-fluids expression, restoring the
2545 * fluids to their previous values.
2547 VM_DEFINE_OP (70, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2549 /* This function must not allocate. */
2550 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2551 current_thread
->dynamic_state
);
2555 /* fluid-ref dst:12 src:12
2557 * Reference the fluid in SRC, and place the value in DST.
2559 VM_DEFINE_OP (71, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2561 scm_t_uint16 dst
, src
;
2565 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2566 fluid
= LOCAL_REF (src
);
2567 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2568 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2569 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2571 /* Punt dynstate expansion and error handling to the C proc. */
2573 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2577 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2578 if (scm_is_eq (val
, SCM_UNDEFINED
))
2579 val
= SCM_I_FLUID_DEFAULT (fluid
);
2580 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2581 vm_error_unbound_fluid (program
, fluid
));
2582 LOCAL_SET (dst
, val
);
2588 /* fluid-set fluid:12 val:12
2590 * Set the value of the fluid in DST to the value in SRC.
2592 VM_DEFINE_OP (72, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2598 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2599 fluid
= LOCAL_REF (a
);
2600 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2601 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2602 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2604 /* Punt dynstate expansion and error handling to the C proc. */
2606 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2609 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2618 * Strings, symbols, and keywords
2621 /* string-length dst:12 src:12
2623 * Store the length of the string in SRC in DST.
2625 VM_DEFINE_OP (73, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2628 if (SCM_LIKELY (scm_is_string (str
)))
2629 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2633 RETURN (scm_string_length (str
));
2637 /* string-ref dst:8 src:8 idx:8
2639 * Fetch the character at position IDX in the string in SRC, and store
2642 VM_DEFINE_OP (74, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2644 scm_t_signed_bits i
= 0;
2646 if (SCM_LIKELY (scm_is_string (str
)
2647 && SCM_I_INUMP (idx
)
2648 && ((i
= SCM_I_INUM (idx
)) >= 0)
2649 && i
< scm_i_string_length (str
)))
2650 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2654 RETURN (scm_string_ref (str
, idx
));
2658 /* No string-set! instruction, as there is no good fast path there. */
2660 /* string-to-number dst:12 src:12
2662 * Parse a string in SRC to a number, and store in DST.
2664 VM_DEFINE_OP (75, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2666 scm_t_uint16 dst
, src
;
2668 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2671 scm_string_to_number (LOCAL_REF (src
),
2672 SCM_UNDEFINED
/* radix = 10 */));
2676 /* string-to-symbol dst:12 src:12
2678 * Parse a string in SRC to a symbol, and store in DST.
2680 VM_DEFINE_OP (76, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2682 scm_t_uint16 dst
, src
;
2684 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2686 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2690 /* symbol->keyword dst:12 src:12
2692 * Make a keyword from the symbol in SRC, and store it in DST.
2694 VM_DEFINE_OP (77, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2696 scm_t_uint16 dst
, src
;
2697 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2699 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2709 /* cons dst:8 car:8 cdr:8
2711 * Cons CAR and CDR, and store the result in DST.
2713 VM_DEFINE_OP (78, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2716 RETURN (scm_cons (x
, y
));
2719 /* car dst:12 src:12
2721 * Place the car of SRC in DST.
2723 VM_DEFINE_OP (79, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2726 VM_VALIDATE_PAIR (x
, "car");
2727 RETURN (SCM_CAR (x
));
2730 /* cdr dst:12 src:12
2732 * Place the cdr of SRC in DST.
2734 VM_DEFINE_OP (80, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2737 VM_VALIDATE_PAIR (x
, "cdr");
2738 RETURN (SCM_CDR (x
));
2741 /* set-car! pair:12 car:12
2743 * Set the car of DST to SRC.
2745 VM_DEFINE_OP (81, set_car
, "set-car!", OP1 (U8_U12_U12
))
2749 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2752 VM_VALIDATE_PAIR (x
, "set-car!");
2757 /* set-cdr! pair:12 cdr:12
2759 * Set the cdr of DST to SRC.
2761 VM_DEFINE_OP (82, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2765 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2768 VM_VALIDATE_PAIR (x
, "set-car!");
2777 * Numeric operations
2780 /* add dst:8 a:8 b:8
2782 * Add A to B, and place the result in DST.
2784 VM_DEFINE_OP (83, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2786 BINARY_INTEGER_OP (+, scm_sum
);
2789 /* add1 dst:12 src:12
2791 * Add 1 to the value in SRC, and place the result in DST.
2793 VM_DEFINE_OP (84, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2797 /* Check for overflow. */
2798 if (SCM_LIKELY ((scm_t_intptr
) SCM_UNPACK (x
) < INUM_MAX
))
2802 /* Add the integers without untagging. */
2803 result
= SCM_PACK ((scm_t_intptr
) SCM_UNPACK (x
)
2804 + (scm_t_intptr
) SCM_UNPACK (SCM_I_MAKINUM (1))
2807 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2812 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2815 /* sub dst:8 a:8 b:8
2817 * Subtract B from A, and place the result in DST.
2819 VM_DEFINE_OP (85, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2821 BINARY_INTEGER_OP (-, scm_difference
);
2824 /* sub1 dst:12 src:12
2826 * Subtract 1 from SRC, and place the result in DST.
2828 VM_DEFINE_OP (86, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2832 /* Check for underflow. */
2833 if (SCM_LIKELY ((scm_t_intptr
) SCM_UNPACK (x
) > INUM_MIN
))
2837 /* Substract the integers without untagging. */
2838 result
= SCM_PACK ((scm_t_intptr
) SCM_UNPACK (x
)
2839 - (scm_t_intptr
) SCM_UNPACK (SCM_I_MAKINUM (1))
2842 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2847 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2850 /* mul dst:8 a:8 b:8
2852 * Multiply A and B, and place the result in DST.
2854 VM_DEFINE_OP (87, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2858 RETURN (scm_product (x
, y
));
2861 /* div dst:8 a:8 b:8
2863 * Divide A by B, and place the result in DST.
2865 VM_DEFINE_OP (88, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2869 RETURN (scm_divide (x
, y
));
2872 /* quo dst:8 a:8 b:8
2874 * Divide A by B, and place the quotient in DST.
2876 VM_DEFINE_OP (89, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2880 RETURN (scm_quotient (x
, y
));
2883 /* rem dst:8 a:8 b:8
2885 * Divide A by B, and place the remainder in DST.
2887 VM_DEFINE_OP (90, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2891 RETURN (scm_remainder (x
, y
));
2894 /* mod dst:8 a:8 b:8
2896 * Place the modulo of A by B in DST.
2898 VM_DEFINE_OP (91, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2902 RETURN (scm_modulo (x
, y
));
2905 /* ash dst:8 a:8 b:8
2907 * Shift A arithmetically by B bits, and place the result in DST.
2909 VM_DEFINE_OP (92, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2912 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2914 if (SCM_I_INUM (y
) < 0)
2915 /* Right shift, will be a fixnum. */
2916 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) >> -SCM_I_INUM (y
)));
2918 /* Left shift. See comments in scm_ash. */
2920 scm_t_signed_bits nn
, bits_to_shift
;
2922 nn
= SCM_I_INUM (x
);
2923 bits_to_shift
= SCM_I_INUM (y
);
2925 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2927 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2929 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2935 RETURN (scm_ash (x
, y
));
2938 /* logand dst:8 a:8 b:8
2940 * Place the bitwise AND of A and B into DST.
2942 VM_DEFINE_OP (93, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2945 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2946 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) & SCM_I_INUM (y
)));
2948 RETURN (scm_logand (x
, y
));
2951 /* logior dst:8 a:8 b:8
2953 * Place the bitwise inclusive OR of A with B in DST.
2955 VM_DEFINE_OP (94, logior
, "logior", 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_logior (x
, y
));
2964 /* logxor dst:8 a:8 b:8
2966 * Place the bitwise exclusive OR of A with B in DST.
2968 VM_DEFINE_OP (95, logxor
, "logxor", 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_logxor (x
, y
));
2977 /* vector-length dst:12 src:12
2979 * Store the length of the vector in SRC in DST.
2981 VM_DEFINE_OP (96, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2984 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2985 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2989 RETURN (scm_vector_length (vect
));
2993 /* vector-ref dst:8 src:8 idx:8
2995 * Fetch the item at position IDX in the vector in SRC, and store it
2998 VM_DEFINE_OP (97, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3000 scm_t_signed_bits i
= 0;
3002 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
3003 && SCM_I_INUMP (idx
)
3004 && ((i
= SCM_I_INUM (idx
)) >= 0)
3005 && i
< SCM_I_VECTOR_LENGTH (vect
)))
3006 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
3010 RETURN (scm_vector_ref (vect
, idx
));
3014 /* constant-vector-ref dst:8 src:8 idx:8
3016 * Fill DST with the item IDX elements into the vector at SRC. Useful
3017 * for building data types using vectors.
3019 VM_DEFINE_OP (98, constant_vector_ref
, "constant-vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3021 scm_t_uint8 dst
, src
, idx
;
3024 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3025 v
= LOCAL_REF (src
);
3026 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
3027 && idx
< SCM_I_VECTOR_LENGTH (v
)))
3028 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
3030 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
3034 /* vector-set! dst:8 idx:8 src:8
3036 * Store SRC into the vector DST at index IDX.
3038 VM_DEFINE_OP (99, vector_set
, "vector-set", OP1 (U8_U8_U8_U8
))
3040 scm_t_uint8 dst
, idx_var
, src
;
3042 scm_t_signed_bits i
= 0;
3044 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx_var
, src
);
3045 vect
= LOCAL_REF (dst
);
3046 idx
= LOCAL_REF (idx_var
);
3047 val
= LOCAL_REF (src
);
3049 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
3050 && SCM_I_INUMP (idx
)
3051 && ((i
= SCM_I_INUM (idx
)) >= 0)
3052 && i
< SCM_I_VECTOR_LENGTH (vect
)))
3053 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
3057 scm_vector_set_x (vect
, idx
, val
);
3069 /* struct-vtable dst:12 src:12
3071 * Store the vtable of SRC into DST.
3073 VM_DEFINE_OP (100, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
3076 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
3077 RETURN (SCM_STRUCT_VTABLE (obj
));
3080 /* make-struct dst:12 vtable:12 _:8 n-init:24 init0:24 0:8 ...
3082 * Make a new struct with VTABLE, and place it in DST. The struct
3083 * will be constructed with N-INIT initializers, which are located in
3084 * the locals given by INIT0.... The format of INIT0... is as in the
3085 * "call" opcode: unsigned 24-bit values, with 0 in the high byte.
3087 VM_DEFINE_OP (101, make_struct
, "make-struct", OP2 (U8_U12_U12
, X8_R24
))
3090 scm_t_uint16 dst
, vtable_r
;
3091 scm_t_uint32 n_init
, n
;
3094 SCM_UNPACK_RTL_12_12 (op
, dst
, vtable_r
);
3095 vtable
= LOCAL_REF (vtable_r
);
3096 SCM_UNPACK_RTL_24 (ip
[1], n_init
);
3100 if (SCM_LIKELY (SCM_STRUCTP (vtable
)
3101 && SCM_VTABLE_FLAG_IS_SET (vtable
, SCM_VTABLE_FLAG_SIMPLE
)
3102 && (SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
)
3104 && !SCM_VTABLE_INSTANCE_FINALIZER (vtable
)))
3106 /* Verily, we are making a simple struct with the right number of
3107 initializers, and no finalizer. */
3108 ret
= scm_words ((scm_t_bits
)SCM_STRUCT_DATA (vtable
) | scm_tc3_struct
,
3110 SCM_SET_CELL_WORD_1 (ret
, (scm_t_bits
)SCM_CELL_OBJECT_LOC (ret
, 2));
3112 for (n
= 0; n
< n_init
; n
++)
3113 SCM_STRUCT_DATA (ret
)[n
] = SCM_UNPACK (LOCAL_REF (ip
[n
+ 1]));
3116 ret
= scm_c_make_structvs (vtable
, fp
, &ip
[1], n_init
);
3118 LOCAL_SET (dst
, ret
);
3125 /* struct-ref dst:8 src:8 idx:8
3127 * Fetch the item at slot IDX in the struct in SRC, and store it
3130 VM_DEFINE_OP (102, struct_ref
, "struct-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3134 if (SCM_LIKELY (SCM_STRUCTP (obj
)
3135 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3136 SCM_VTABLE_FLAG_SIMPLE
)
3137 && SCM_I_INUMP (pos
)))
3140 scm_t_bits index
, len
;
3142 /* True, an inum is a signed value, but cast to unsigned it will
3143 certainly be more than the length, so we will fall through if
3144 index is negative. */
3145 index
= SCM_I_INUM (pos
);
3146 vtable
= SCM_STRUCT_VTABLE (obj
);
3147 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3149 if (SCM_LIKELY (index
< len
))
3151 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3152 RETURN (SCM_PACK (data
[index
]));
3157 RETURN (scm_struct_ref (obj
, pos
));
3160 /* struct-set! dst:8 idx:8 src:8
3162 * Store SRC into the struct DST at slot IDX.
3164 VM_DEFINE_OP (103, struct_set
, "struct-set!", OP1 (U8_U8_U8_U8
))
3166 scm_t_uint8 dst
, idx
, src
;
3169 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3170 obj
= LOCAL_REF (dst
);
3171 pos
= LOCAL_REF (idx
);
3172 val
= LOCAL_REF (src
);
3174 if (SCM_LIKELY (SCM_STRUCTP (obj
)
3175 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3176 SCM_VTABLE_FLAG_SIMPLE
)
3177 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3178 SCM_VTABLE_FLAG_SIMPLE_RW
)
3179 && SCM_I_INUMP (pos
)))
3182 scm_t_bits index
, len
;
3184 /* See above regarding index being >= 0. */
3185 index
= SCM_I_INUM (pos
);
3186 vtable
= SCM_STRUCT_VTABLE (obj
);
3187 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3188 if (SCM_LIKELY (index
< len
))
3190 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3191 data
[index
] = SCM_UNPACK (val
);
3197 scm_struct_set_x (obj
, pos
, val
);
3201 /* class-of dst:12 type:12
3203 * Store the vtable of SRC into DST.
3205 VM_DEFINE_OP (104, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
3208 if (SCM_INSTANCEP (obj
))
3209 RETURN (SCM_CLASS_OF (obj
));
3211 RETURN (scm_class_of (obj
));
3214 /* slot-ref dst:8 src:8 idx:8
3216 * Fetch the item at slot IDX in the struct in SRC, and store it in
3217 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3218 * index into the stack.
3220 VM_DEFINE_OP (105, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3222 scm_t_uint8 dst
, src
, idx
;
3223 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3225 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
3229 /* slot-set! dst:8 idx:8 src:8
3231 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3232 * IDX is an 8-bit immediate value, not an index into the stack.
3234 VM_DEFINE_OP (106, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
3236 scm_t_uint8 dst
, idx
, src
;
3237 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3238 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
3246 * Arrays, packed uniform arrays, and bytevectors.
3249 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3251 * Load the contiguous typed array located at OFFSET 32-bit words away
3252 * from the instruction pointer, and store into DST. LEN is a byte
3253 * length. OFFSET is signed.
3255 VM_DEFINE_OP (107, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
3257 scm_t_uint8 dst
, type
, shape
;
3261 SCM_UNPACK_RTL_8_8_8 (op
, dst
, type
, shape
);
3265 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
3271 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3273 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3275 VM_DEFINE_OP (108, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
3277 scm_t_uint16 dst
, type
, fill
, bounds
;
3278 SCM_UNPACK_RTL_12_12 (op
, dst
, type
);
3279 SCM_UNPACK_RTL_12_12 (ip
[1], fill
, bounds
);
3281 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
3282 LOCAL_REF (bounds
)));
3286 /* bv-u8-ref dst:8 src:8 idx:8
3287 * bv-s8-ref dst:8 src:8 idx:8
3288 * bv-u16-ref dst:8 src:8 idx:8
3289 * bv-s16-ref dst:8 src:8 idx:8
3290 * bv-u32-ref dst:8 src:8 idx:8
3291 * bv-s32-ref dst:8 src:8 idx:8
3292 * bv-u64-ref dst:8 src:8 idx:8
3293 * bv-s64-ref dst:8 src:8 idx:8
3294 * bv-f32-ref dst:8 src:8 idx:8
3295 * bv-f64-ref dst:8 src:8 idx:8
3297 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3298 * it in DST. All accesses use native endianness.
3300 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3302 scm_t_signed_bits i; \
3303 const scm_t_ ## type *int_ptr; \
3306 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3307 i = SCM_I_INUM (idx); \
3308 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3310 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3312 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3313 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3314 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3318 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3322 #define BV_INT_REF(stem, type, size) \
3324 scm_t_signed_bits i; \
3325 const scm_t_ ## type *int_ptr; \
3328 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3329 i = SCM_I_INUM (idx); \
3330 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3332 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3334 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3335 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3337 scm_t_ ## type x = *int_ptr; \
3338 if (SCM_FIXABLE (x)) \
3339 RETURN (SCM_I_MAKINUM (x)); \
3343 RETURN (scm_from_ ## type (x)); \
3349 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3353 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3355 scm_t_signed_bits i; \
3356 const type *float_ptr; \
3359 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3360 i = SCM_I_INUM (idx); \
3361 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3364 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3366 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3367 && (ALIGNED_P (float_ptr, type)))) \
3368 RETURN (scm_from_double (*float_ptr)); \
3370 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3373 VM_DEFINE_OP (109, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3374 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
3376 VM_DEFINE_OP (110, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3377 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
3379 VM_DEFINE_OP (111, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3380 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
3382 VM_DEFINE_OP (112, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3383 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
3385 VM_DEFINE_OP (113, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3386 #if SIZEOF_VOID_P > 4
3387 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
3389 BV_INT_REF (u32
, uint32
, 4);
3392 VM_DEFINE_OP (114, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3393 #if SIZEOF_VOID_P > 4
3394 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
3396 BV_INT_REF (s32
, int32
, 4);
3399 VM_DEFINE_OP (115, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3400 BV_INT_REF (u64
, uint64
, 8);
3402 VM_DEFINE_OP (116, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3403 BV_INT_REF (s64
, int64
, 8);
3405 VM_DEFINE_OP (117, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3406 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
3408 VM_DEFINE_OP (118, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3409 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
3411 /* bv-u8-set! dst:8 idx:8 src:8
3412 * bv-s8-set! dst:8 idx:8 src:8
3413 * bv-u16-set! dst:8 idx:8 src:8
3414 * bv-s16-set! dst:8 idx:8 src:8
3415 * bv-u32-set! dst:8 idx:8 src:8
3416 * bv-s32-set! dst:8 idx:8 src:8
3417 * bv-u64-set! dst:8 idx:8 src:8
3418 * bv-s64-set! dst:8 idx:8 src:8
3419 * bv-f32-set! dst:8 idx:8 src:8
3420 * bv-f64-set! dst:8 idx:8 src:8
3422 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3423 * values are written using native endianness.
3425 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3427 scm_t_uint8 dst, idx, src; \
3428 scm_t_signed_bits i, j = 0; \
3429 SCM bv, scm_idx, val; \
3430 scm_t_ ## type *int_ptr; \
3432 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3433 bv = LOCAL_REF (dst); \
3434 scm_idx = LOCAL_REF (idx); \
3435 val = LOCAL_REF (src); \
3436 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3437 i = SCM_I_INUM (scm_idx); \
3438 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3440 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3442 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3443 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3444 && (SCM_I_INUMP (val)) \
3445 && ((j = SCM_I_INUM (val)) >= min) \
3447 *int_ptr = (scm_t_ ## type) j; \
3451 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3456 #define BV_INT_SET(stem, type, size) \
3458 scm_t_uint8 dst, idx, src; \
3459 scm_t_signed_bits i; \
3460 SCM bv, scm_idx, val; \
3461 scm_t_ ## type *int_ptr; \
3463 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3464 bv = LOCAL_REF (dst); \
3465 scm_idx = LOCAL_REF (idx); \
3466 val = LOCAL_REF (src); \
3467 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3468 i = SCM_I_INUM (scm_idx); \
3469 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3471 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3473 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3474 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3475 *int_ptr = scm_to_ ## type (val); \
3479 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3484 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3486 scm_t_uint8 dst, idx, src; \
3487 scm_t_signed_bits i; \
3488 SCM bv, scm_idx, val; \
3491 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3492 bv = LOCAL_REF (dst); \
3493 scm_idx = LOCAL_REF (idx); \
3494 val = LOCAL_REF (src); \
3495 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3496 i = SCM_I_INUM (scm_idx); \
3497 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3499 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3501 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3502 && (ALIGNED_P (float_ptr, type)))) \
3503 *float_ptr = scm_to_double (val); \
3507 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3512 VM_DEFINE_OP (119, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3513 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3515 VM_DEFINE_OP (120, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3516 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3518 VM_DEFINE_OP (121, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3519 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3521 VM_DEFINE_OP (122, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3522 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3524 VM_DEFINE_OP (123, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3525 #if SIZEOF_VOID_P > 4
3526 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3528 BV_INT_SET (u32
, uint32
, 4);
3531 VM_DEFINE_OP (124, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3532 #if SIZEOF_VOID_P > 4
3533 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3535 BV_INT_SET (s32
, int32
, 4);
3538 VM_DEFINE_OP (125, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3539 BV_INT_SET (u64
, uint64
, 8);
3541 VM_DEFINE_OP (126, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3542 BV_INT_SET (s64
, int64
, 8);
3544 VM_DEFINE_OP (127, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3545 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3547 VM_DEFINE_OP (128, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3548 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3550 END_DISPATCH_SWITCH
;
3552 vm_error_bad_instruction
:
3553 vm_error_bad_instruction (op
);
3555 abort (); /* never reached */
3559 #undef ABORT_CONTINUATION_HOOK
3564 #undef BEGIN_DISPATCH_SWITCH
3565 #undef BINARY_INTEGER_OP
3566 #undef BR_ARITHMETIC
3570 #undef BV_FIXABLE_INT_REF
3571 #undef BV_FIXABLE_INT_SET
3576 #undef CACHE_REGISTER
3577 #undef CHECK_OVERFLOW
3578 #undef END_DISPATCH_SWITCH
3579 #undef FREE_VARIABLE_REF
3588 #undef POP_CONTINUATION_HOOK
3589 #undef PUSH_CONTINUATION_HOOK
3590 #undef RESTORE_CONTINUATION_HOOK
3592 #undef RETURN_ONE_VALUE
3593 #undef RETURN_VALUE_LIST
3597 #undef SYNC_BEFORE_GC
3599 #undef SYNC_REGISTER
3600 #undef VARIABLE_BOUNDP
3603 #undef VM_CHECK_FREE_VARIABLE
3604 #undef VM_CHECK_OBJECT
3605 #undef VM_CHECK_UNDERFLOW
3607 #undef VM_INSTRUCTION_TO_LABEL
3609 #undef VM_VALIDATE_BYTEVECTOR
3610 #undef VM_VALIDATE_PAIR
3611 #undef VM_VALIDATE_STRUCT
3614 (defun renumber-ops ()
3615 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3618 (let ((counter -1)) (goto-char (point-min))
3619 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3621 (number-to-string (setq counter (1+ counter)))