1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013,
2 * 2014 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
20 /* This file is included in vm.c multiple times. */
23 #define UNPACK_8_8_8(op,a,b,c) \
26 a = (op >> 8) & 0xff; \
27 b = (op >> 16) & 0xff; \
32 #define UNPACK_8_16(op,a,b) \
35 a = (op >> 8) & 0xff; \
40 #define UNPACK_16_8(op,a,b) \
43 a = (op >> 8) & 0xffff; \
48 #define UNPACK_12_12(op,a,b) \
51 a = (op >> 8) & 0xfff; \
56 #define UNPACK_24(op,a) \
64 /* Assign some registers by hand. There used to be a bigger list here,
65 but it was never tested, and in the case of x86-32, was a source of
66 compilation failures. It can be revived if it's useful, but my naive
67 hope is that simply annotating the locals with "register" will be a
68 sufficient hint to the compiler. */
70 # if defined __x86_64__
71 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
72 well. Tell it to keep the jump table in a r12, which is
74 # define JT_REG asm ("r12")
88 #define VM_ASSERT(condition, handler) \
90 if (SCM_UNLIKELY (!(condition))) \
97 #ifdef VM_ENABLE_ASSERTIONS
98 # define ASSERT(condition) VM_ASSERT (condition, abort())
100 # define ASSERT(condition)
104 #define RUN_HOOK(exp) \
106 if (SCM_UNLIKELY (vp->trace_level > 0)) \
114 #define RUN_HOOK(exp)
116 #define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
117 #define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
119 #define APPLY_HOOK() \
121 #define PUSH_CONTINUATION_HOOK() \
122 RUN_HOOK0 (push_continuation)
123 #define POP_CONTINUATION_HOOK(old_fp) \
124 RUN_HOOK1 (pop_continuation, old_fp)
125 #define NEXT_HOOK() \
127 #define ABORT_CONTINUATION_HOOK() \
130 #define VM_HANDLE_INTERRUPTS \
131 SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ())
136 The VM has three state bits: the instruction pointer (IP), the frame
137 pointer (FP), and the top-of-stack pointer (SP). We cache the first
138 two of these in machine registers, local to the VM, because they are
139 used extensively by the VM. As the SP is used more by code outside
140 the VM than by the VM itself, we don't bother caching it locally.
142 Since the FP changes infrequently, relative to the IP, we keep vp->fp
143 in sync with the local FP. This would be a big lose for the IP,
144 though, so instead of updating vp->ip all the time, we call SYNC_IP
145 whenever we would need to know the IP of the top frame. In practice,
146 we need to SYNC_IP whenever we call out of the VM to a function that
147 would like to walk the stack, perhaps as the result of an
150 One more thing. We allow the stack to move, when it expands.
151 Therefore if you call out to a C procedure that could call Scheme
152 code, or otherwise push anything on the stack, you will need to
153 CACHE_FP afterwards to restore the possibly-changed FP. */
155 #define SYNC_IP() vp->ip = (ip)
157 #define CACHE_FP() fp = (vp->fp)
158 #define CACHE_REGISTER() \
165 /* Reserve stack space for a frame. Will check that there is sufficient
166 stack space for N locals, including the procedure. Invoke after
167 preparing the new frame and setting the fp and ip.
169 If there is not enough space for this frame, we try to expand the
170 stack, possibly relocating it somewhere else in the address space.
171 Because of the possible relocation, no pointer into the stack besides
172 FP is valid across an ALLOC_FRAME call. Be careful! */
173 #define ALLOC_FRAME(n) \
175 SCM *new_sp = LOCAL_ADDRESS (n - 1); \
176 if (new_sp > vp->sp_max_since_gc) \
178 if (SCM_UNLIKELY (new_sp >= vp->stack_limit)) \
181 vm_expand_stack (vp, new_sp); \
185 vp->sp_max_since_gc = vp->sp = new_sp; \
191 /* Reset the current frame to hold N locals. Used when we know that no
192 stack expansion is needed. */
193 #define RESET_FRAME(n) \
195 vp->sp = LOCAL_ADDRESS (n - 1); \
196 if (vp->sp > vp->sp_max_since_gc) \
197 vp->sp_max_since_gc = vp->sp; \
200 /* Compute the number of locals in the frame. At a call, this is equal
201 to the number of actual arguments when a function is first called,
202 plus one for the function. */
203 #define FRAME_LOCALS_COUNT_FROM(slot) \
204 (vp->sp + 1 - LOCAL_ADDRESS (slot))
205 #define FRAME_LOCALS_COUNT() \
206 FRAME_LOCALS_COUNT_FROM (0)
208 /* Restore registers after returning from a frame. */
209 #define RESTORE_FRAME() \
214 #ifdef HAVE_LABELS_AS_VALUES
215 # define BEGIN_DISPATCH_SWITCH /* */
216 # define END_DISPATCH_SWITCH /* */
223 goto *jump_table[op & 0xff]; \
226 # define VM_DEFINE_OP(opcode, tag, name, meta) \
229 # define BEGIN_DISPATCH_SWITCH \
235 # define END_DISPATCH_SWITCH \
244 # define VM_DEFINE_OP(opcode, tag, name, meta) \
249 #define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
250 #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
251 #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
253 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
254 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
255 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
257 #define RETURN_ONE_VALUE(ret) \
261 VM_HANDLE_INTERRUPTS; \
263 ip = SCM_FRAME_RETURN_ADDRESS (fp); \
264 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
266 old_fp[-1] = SCM_BOOL_F; \
267 old_fp[-2] = SCM_BOOL_F; \
269 SCM_FRAME_LOCAL (old_fp, 1) = val; \
270 vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
271 POP_CONTINUATION_HOOK (old_fp); \
275 /* While we could generate the list-unrolling code here, it's fine for
276 now to just tail-call (apply values vals). */
277 #define RETURN_VALUE_LIST(vals_) \
280 VM_HANDLE_INTERRUPTS; \
281 fp[0] = vm_builtin_apply; \
282 fp[1] = vm_builtin_values; \
285 ip = (scm_t_uint32 *) vm_builtin_apply_code; \
286 goto op_tail_apply; \
289 #define BR_NARGS(rel) \
290 scm_t_uint32 expected; \
291 UNPACK_24 (op, expected); \
292 if (FRAME_LOCALS_COUNT() rel expected) \
294 scm_t_int32 offset = ip[1]; \
295 offset >>= 8; /* Sign-extending shift. */ \
300 #define BR_UNARY(x, exp) \
303 UNPACK_24 (op, test); \
304 x = LOCAL_REF (test); \
305 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
307 scm_t_int32 offset = ip[1]; \
308 offset >>= 8; /* Sign-extending shift. */ \
310 VM_HANDLE_INTERRUPTS; \
315 #define BR_BINARY(x, y, exp) \
318 UNPACK_12_12 (op, a, b); \
321 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
323 scm_t_int32 offset = ip[1]; \
324 offset >>= 8; /* Sign-extending shift. */ \
326 VM_HANDLE_INTERRUPTS; \
331 #define BR_ARITHMETIC(crel,srel) \
335 UNPACK_12_12 (op, a, b); \
338 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
340 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
341 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
342 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
344 scm_t_int32 offset = ip[1]; \
345 offset >>= 8; /* Sign-extending shift. */ \
347 VM_HANDLE_INTERRUPTS; \
358 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
360 scm_t_int32 offset = ip[1]; \
361 offset >>= 8; /* Sign-extending shift. */ \
363 VM_HANDLE_INTERRUPTS; \
371 scm_t_uint16 dst, src; \
373 UNPACK_12_12 (op, dst, src); \
375 #define ARGS2(a1, a2) \
376 scm_t_uint8 dst, src1, src2; \
378 UNPACK_8_8_8 (op, dst, src1, src2); \
379 a1 = LOCAL_REF (src1); \
380 a2 = LOCAL_REF (src2)
382 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
383 #define RETURN_EXP(exp) \
384 do { SCM __x; SYNC_IP (); __x = exp; CACHE_FP (); RETURN (__x); } while (0)
386 /* The maximum/minimum tagged integers. */
388 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
390 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
392 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
393 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
395 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
398 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
400 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
401 if (SCM_FIXABLE (n)) \
402 RETURN (SCM_I_MAKINUM (n)); \
404 RETURN_EXP (SFUNC (x, y)); \
407 #define VM_VALIDATE_PAIR(x, proc) \
408 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
410 #define VM_VALIDATE_STRUCT(obj, proc) \
411 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
413 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
414 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
416 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
417 #define ALIGNED_P(ptr, type) \
418 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
421 VM_NAME (scm_i_thread
*thread
, struct scm_vm
*vp
,
422 scm_i_jmp_buf
*registers
, int resume
)
424 /* Instruction pointer: A pointer to the opcode that is currently
426 register scm_t_uint32
*ip IP_REG
;
428 /* Frame pointer: A pointer into the stack, off of which we index
429 arguments and local variables. Pushed at function calls, popped on
431 register SCM
*fp FP_REG
;
433 /* Current opcode: A cache of *ip. */
434 register scm_t_uint32 op
;
436 #ifdef HAVE_LABELS_AS_VALUES
437 static const void *jump_table_
[256] = {
438 #define LABEL_ADDR(opcode, tag, name, meta) &&op_##tag,
439 FOR_EACH_VM_OPERATION(LABEL_ADDR
)
442 register const void **jump_table JT_REG
;
443 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
444 load instruction at each instruction dispatch. */
445 jump_table
= jump_table_
;
448 /* Load VM registers. */
451 VM_HANDLE_INTERRUPTS
;
453 /* Usually a call to the VM happens on application, with the boot
454 continuation on the next frame. Sometimes it happens after a
455 non-local exit however; in that case the VM state is all set up,
456 and we have but to jump to the next opcode. */
457 if (SCM_UNLIKELY (resume
))
461 while (!SCM_PROGRAM_P (LOCAL_REF (0)))
463 SCM proc
= LOCAL_REF (0);
465 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
467 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
470 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
472 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
474 /* Shuffle args up. */
477 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
479 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
484 vm_error_wrong_type_apply (proc
);
488 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
494 BEGIN_DISPATCH_SWITCH
;
505 * Bring the VM to a halt, returning all the values from the stack.
507 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
509 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
511 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
520 for (n
= nvals
; n
> 0; n
--)
521 ret
= scm_inline_cons (thread
, LOCAL_REF (4 + n
- 1), ret
);
522 ret
= scm_values (ret
);
525 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
526 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
527 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
532 /* call proc:24 _:8 nlocals:24
534 * Call a procedure. PROC is the local corresponding to a procedure.
535 * The two values below PROC will be overwritten by the saved call
536 * frame data. The new frame will have space for NLOCALS locals: one
537 * for the procedure, and the rest for the arguments which should
538 * already have been pushed on.
540 * When the call returns, execution proceeds with the next
541 * instruction. There may be any number of values on the return
542 * stack; the precise number can be had by subtracting the address of
543 * PROC from the post-call SP.
545 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
547 scm_t_uint32 proc
, nlocals
;
550 UNPACK_24 (op
, proc
);
551 UNPACK_24 (ip
[1], nlocals
);
553 VM_HANDLE_INTERRUPTS
;
555 PUSH_CONTINUATION_HOOK ();
558 fp
= vp
->fp
= old_fp
+ proc
;
559 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
560 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
562 RESET_FRAME (nlocals
);
564 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
567 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
574 /* call-label proc:24 _:8 nlocals:24 label:32
576 * Call a procedure in the same compilation unit.
578 * This instruction is just like "call", except that instead of
579 * dereferencing PROC to find the call target, the call target is
580 * known to be at LABEL, a signed 32-bit offset in 32-bit units from
581 * the current IP. Since PROC is not dereferenced, it may be some
582 * other representation of the closure.
584 VM_DEFINE_OP (2, call_label
, "call-label", OP3 (U8_U24
, X8_U24
, L32
))
586 scm_t_uint32 proc
, nlocals
;
590 UNPACK_24 (op
, proc
);
591 UNPACK_24 (ip
[1], nlocals
);
594 VM_HANDLE_INTERRUPTS
;
596 PUSH_CONTINUATION_HOOK ();
599 fp
= vp
->fp
= old_fp
+ proc
;
600 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
601 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 3);
603 RESET_FRAME (nlocals
);
612 /* tail-call nlocals:24
614 * Tail-call a procedure. Requires that the procedure and all of the
615 * arguments have already been shuffled into position. Will reset the
618 VM_DEFINE_OP (3, tail_call
, "tail-call", OP1 (U8_U24
))
620 scm_t_uint32 nlocals
;
622 UNPACK_24 (op
, nlocals
);
624 VM_HANDLE_INTERRUPTS
;
626 RESET_FRAME (nlocals
);
628 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
631 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
638 /* tail-call-label nlocals:24 label:32
640 * Tail-call a known procedure. As call is to call-label, tail-call
641 * is to tail-call-label.
643 VM_DEFINE_OP (4, tail_call_label
, "tail-call-label", OP2 (U8_U24
, L32
))
645 scm_t_uint32 nlocals
;
648 UNPACK_24 (op
, nlocals
);
651 VM_HANDLE_INTERRUPTS
;
653 RESET_FRAME (nlocals
);
662 /* tail-call/shuffle from:24
664 * Tail-call a procedure. The procedure should already be set to slot
665 * 0. The rest of the args are taken from the frame, starting at
666 * FROM, shuffled down to start at slot 0. This is part of the
667 * implementation of the call-with-values builtin.
669 VM_DEFINE_OP (5, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
671 scm_t_uint32 n
, from
, nlocals
;
673 UNPACK_24 (op
, from
);
675 VM_HANDLE_INTERRUPTS
;
677 VM_ASSERT (from
> 0, abort ());
678 nlocals
= FRAME_LOCALS_COUNT ();
680 for (n
= 0; from
+ n
< nlocals
; n
++)
681 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
685 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
688 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
695 /* receive dst:12 proc:12 _:8 nlocals:24
697 * Receive a single return value from a call whose procedure was in
698 * PROC, asserting that the call actually returned at least one
699 * value. Afterwards, resets the frame to NLOCALS locals.
701 VM_DEFINE_OP (6, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
703 scm_t_uint16 dst
, proc
;
704 scm_t_uint32 nlocals
;
705 UNPACK_12_12 (op
, dst
, proc
);
706 UNPACK_24 (ip
[1], nlocals
);
707 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
708 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
709 RESET_FRAME (nlocals
);
713 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
715 * Receive a return of multiple values from a call whose procedure was
716 * in PROC. If fewer than NVALUES values were returned, signal an
717 * error. Unless ALLOW-EXTRA? is true, require that the number of
718 * return values equals NVALUES exactly. After receive-values has
719 * run, the values can be copied down via `mov'.
721 VM_DEFINE_OP (7, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
723 scm_t_uint32 proc
, nvalues
;
724 UNPACK_24 (op
, proc
);
725 UNPACK_24 (ip
[1], nvalues
);
727 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
728 vm_error_not_enough_values ());
730 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
731 vm_error_wrong_number_of_values (nvalues
));
739 VM_DEFINE_OP (8, return, "return", OP1 (U8_U24
))
743 RETURN_ONE_VALUE (LOCAL_REF (src
));
746 /* return-values _:24
748 * Return a number of values from a call frame. This opcode
749 * corresponds to an application of `values' in tail position. As
750 * with tail calls, we expect that the values have already been
751 * shuffled down to a contiguous array starting at slot 1.
752 * We also expect the frame has already been reset.
754 VM_DEFINE_OP (9, return_values
, "return-values", OP1 (U8_X24
))
758 VM_HANDLE_INTERRUPTS
;
761 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
762 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
764 /* Clear stack frame. */
765 old_fp
[-1] = SCM_BOOL_F
;
766 old_fp
[-2] = SCM_BOOL_F
;
768 POP_CONTINUATION_HOOK (old_fp
);
777 * Specialized call stubs
780 /* subr-call ptr-idx:24
782 * Call a subr, passing all locals in this frame as arguments. Fetch
783 * the foreign pointer from PTR-IDX, a free variable. Return from the
784 * calling frame. This instruction is part of the trampolines
785 * created in gsubr.c, and is not generated by the compiler.
787 VM_DEFINE_OP (10, subr_call
, "subr-call", OP1 (U8_U24
))
789 scm_t_uint32 ptr_idx
;
793 UNPACK_24 (op
, ptr_idx
);
795 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
796 subr
= SCM_POINTER_VALUE (pointer
);
800 switch (FRAME_LOCALS_COUNT_FROM (1))
809 ret
= subr (fp
[1], fp
[2]);
812 ret
= subr (fp
[1], fp
[2], fp
[3]);
815 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
818 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
821 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
824 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
827 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
830 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
833 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
841 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
842 /* multiple values returned to continuation */
843 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
845 RETURN_ONE_VALUE (ret
);
848 /* foreign-call cif-idx:12 ptr-idx:12
850 * Call a foreign function. Fetch the CIF and foreign pointer from
851 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
852 * frame. Arguments are taken from the stack. This instruction is
853 * part of the trampolines created by the FFI, and is not generated by
856 VM_DEFINE_OP (11, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
858 scm_t_uint16 cif_idx
, ptr_idx
;
859 SCM closure
, cif
, pointer
, ret
;
861 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
863 closure
= LOCAL_REF (0);
864 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
865 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
869 // FIXME: separate args
870 ret
= scm_i_foreign_call (scm_inline_cons (thread
, cif
, pointer
),
875 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
876 /* multiple values returned to continuation */
877 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
879 RETURN_ONE_VALUE (ret
);
882 /* continuation-call contregs:24
884 * Return to a continuation, nonlocally. The arguments to the
885 * continuation are taken from the stack. CONTREGS is a free variable
886 * containing the reified continuation. This instruction is part of
887 * the implementation of undelimited continuations, and is not
888 * generated by the compiler.
890 VM_DEFINE_OP (12, continuation_call
, "continuation-call", OP1 (U8_U24
))
893 scm_t_uint32 contregs_idx
;
895 UNPACK_24 (op
, contregs_idx
);
898 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
901 scm_i_check_continuation (contregs
);
902 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
903 scm_i_contregs_vm_cont (contregs
),
904 FRAME_LOCALS_COUNT_FROM (1),
906 scm_i_reinstate_continuation (contregs
);
912 /* compose-continuation cont:24
914 * Compose a partial continution with the current continuation. The
915 * arguments to the continuation are taken from the stack. CONT is a
916 * free variable containing the reified continuation. This
917 * instruction is part of the implementation of partial continuations,
918 * and is not generated by the compiler.
920 VM_DEFINE_OP (13, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
923 scm_t_uint32 cont_idx
;
925 UNPACK_24 (op
, cont_idx
);
926 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
929 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
930 vm_error_continuation_not_rewindable (vmcont
));
931 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
941 * Tail-apply the procedure in local slot 0 to the rest of the
942 * arguments. This instruction is part of the implementation of
943 * `apply', and is not generated by the compiler.
945 VM_DEFINE_OP (14, tail_apply
, "tail-apply", OP1 (U8_X24
))
947 int i
, list_idx
, list_len
, nlocals
;
950 VM_HANDLE_INTERRUPTS
;
952 nlocals
= FRAME_LOCALS_COUNT ();
953 // At a minimum, there should be apply, f, and the list.
954 VM_ASSERT (nlocals
>= 3, abort ());
955 list_idx
= nlocals
- 1;
956 list
= LOCAL_REF (list_idx
);
957 list_len
= scm_ilength (list
);
959 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
961 nlocals
= nlocals
- 2 + list_len
;
962 ALLOC_FRAME (nlocals
);
964 for (i
= 1; i
< list_idx
; i
++)
965 LOCAL_SET (i
- 1, LOCAL_REF (i
));
967 /* Null out these slots, just in case there are less than 2 elements
969 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
970 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
972 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
973 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
975 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
978 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
987 * Capture the current continuation, and tail-apply the procedure in
988 * local slot 1 to it. This instruction is part of the implementation
989 * of `call/cc', and is not generated by the compiler.
991 VM_DEFINE_OP (15, call_cc
, "call/cc", OP1 (U8_X24
))
994 scm_t_dynstack
*dynstack
;
997 VM_HANDLE_INTERRUPTS
;
1000 dynstack
= scm_dynstack_capture_all (&thread
->dynstack
);
1001 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1002 SCM_FRAME_DYNAMIC_LINK (fp
),
1003 SCM_FRAME_PREVIOUS_SP (fp
),
1004 SCM_FRAME_RETURN_ADDRESS (fp
),
1007 /* FIXME: Seems silly to capture the registers here, when they are
1008 already captured in the registers local, which here we are
1009 copying out to the heap; and likewise, the setjmp(®isters)
1010 code already has the non-local return handler. But oh
1012 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
1016 LOCAL_SET (0, LOCAL_REF (1));
1017 LOCAL_SET (1, cont
);
1020 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
1023 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
1032 ABORT_CONTINUATION_HOOK ();
1039 * Abort to a prompt handler. The tag is expected in r1, and the rest
1040 * of the values in the frame are returned to the prompt handler.
1041 * This corresponds to a tail application of abort-to-prompt.
1043 VM_DEFINE_OP (16, abort
, "abort", OP1 (U8_X24
))
1045 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1047 ASSERT (nlocals
>= 2);
1048 /* FIXME: Really we should capture the caller's registers. Until
1049 then, manually advance the IP so that when the prompt resumes,
1050 it continues with the next instruction. */
1053 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1054 SCM_EOL
, LOCAL_ADDRESS (0), registers
);
1056 /* vm_abort should not return */
1060 /* builtin-ref dst:12 idx:12
1062 * Load a builtin stub by index into DST.
1064 VM_DEFINE_OP (17, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1066 scm_t_uint16 dst
, idx
;
1068 UNPACK_12_12 (op
, dst
, idx
);
1069 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1078 * Function prologues
1081 /* br-if-nargs-ne expected:24 _:8 offset:24
1082 * br-if-nargs-lt expected:24 _:8 offset:24
1083 * br-if-nargs-gt expected:24 _:8 offset:24
1085 * If the number of actual arguments is not equal, less than, or greater
1086 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1087 * the current instruction pointer.
1089 VM_DEFINE_OP (18, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1093 VM_DEFINE_OP (19, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1097 VM_DEFINE_OP (20, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1102 /* assert-nargs-ee expected:24
1103 * assert-nargs-ge expected:24
1104 * assert-nargs-le expected:24
1106 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1107 * respectively, signal an error.
1109 VM_DEFINE_OP (21, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1111 scm_t_uint32 expected
;
1112 UNPACK_24 (op
, expected
);
1113 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1114 vm_error_wrong_num_args (LOCAL_REF (0)));
1117 VM_DEFINE_OP (22, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1119 scm_t_uint32 expected
;
1120 UNPACK_24 (op
, expected
);
1121 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1122 vm_error_wrong_num_args (LOCAL_REF (0)));
1125 VM_DEFINE_OP (23, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1127 scm_t_uint32 expected
;
1128 UNPACK_24 (op
, expected
);
1129 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1130 vm_error_wrong_num_args (LOCAL_REF (0)));
1134 /* alloc-frame nlocals:24
1136 * Ensure that there is space on the stack for NLOCALS local variables,
1137 * setting them all to SCM_UNDEFINED, except those nargs values that
1138 * were passed as arguments and procedure.
1140 VM_DEFINE_OP (24, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1142 scm_t_uint32 nlocals
, nargs
;
1143 UNPACK_24 (op
, nlocals
);
1145 nargs
= FRAME_LOCALS_COUNT ();
1146 ALLOC_FRAME (nlocals
);
1147 while (nlocals
-- > nargs
)
1148 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1153 /* reset-frame nlocals:24
1155 * Like alloc-frame, but doesn't check that the stack is big enough.
1156 * Used to reset the frame size to something less than the size that
1157 * was previously set via alloc-frame.
1159 VM_DEFINE_OP (25, reset_frame
, "reset-frame", OP1 (U8_U24
))
1161 scm_t_uint32 nlocals
;
1162 UNPACK_24 (op
, nlocals
);
1163 RESET_FRAME (nlocals
);
1167 /* assert-nargs-ee/locals expected:12 nlocals:12
1169 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1170 * number of locals reserved is EXPECTED + NLOCALS.
1172 VM_DEFINE_OP (26, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1174 scm_t_uint16 expected
, nlocals
;
1175 UNPACK_12_12 (op
, expected
, nlocals
);
1176 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1177 vm_error_wrong_num_args (LOCAL_REF (0)));
1178 ALLOC_FRAME (expected
+ nlocals
);
1180 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1185 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1187 * Find the first positional argument after NREQ. If it is greater
1188 * than NPOS, jump to OFFSET.
1190 * This instruction is only emitted for functions with multiple
1191 * clauses, and an earlier clause has keywords and no rest arguments.
1192 * See "Case-lambda" in the manual, for more on how case-lambda
1193 * chooses the clause to apply.
1195 VM_DEFINE_OP (27, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1197 scm_t_uint32 nreq
, npos
;
1199 UNPACK_24 (op
, nreq
);
1200 UNPACK_24 (ip
[1], npos
);
1202 /* We can only have too many positionals if there are more
1203 arguments than NPOS. */
1204 if (FRAME_LOCALS_COUNT() > npos
)
1207 for (n
= nreq
; n
< npos
; n
++)
1208 if (scm_is_keyword (LOCAL_REF (n
)))
1210 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1212 scm_t_int32 offset
= ip
[2];
1213 offset
>>= 8; /* Sign-extending shift. */
1220 /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
1222 * flags := allow-other-keys:1 has-rest:1 _:6
1224 * Find the last positional argument, and shuffle all the rest above
1225 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1226 * load the constant at KW-OFFSET words from the current IP, and use it
1227 * to bind keyword arguments. If HAS-REST, collect all shuffled
1228 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1229 * the arguments that we shuffled up.
1231 * A macro-mega-instruction.
1233 VM_DEFINE_OP (28, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1235 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1236 scm_t_int32 kw_offset
;
1239 char allow_other_keys
, has_rest
;
1241 UNPACK_24 (op
, nreq
);
1242 allow_other_keys
= ip
[1] & 0x1;
1243 has_rest
= ip
[1] & 0x2;
1244 UNPACK_24 (ip
[1], nreq_and_opt
);
1245 UNPACK_24 (ip
[2], ntotal
);
1247 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1248 VM_ASSERT (!(kw_bits
& 0x7), abort());
1249 kw
= SCM_PACK (kw_bits
);
1251 nargs
= FRAME_LOCALS_COUNT ();
1253 /* look in optionals for first keyword or last positional */
1254 /* starting after the last required positional arg */
1256 while (/* while we have args */
1258 /* and we still have positionals to fill */
1259 && npositional
< nreq_and_opt
1260 /* and we haven't reached a keyword yet */
1261 && !scm_is_keyword (LOCAL_REF (npositional
)))
1262 /* bind this optional arg (by leaving it in place) */
1264 nkw
= nargs
- npositional
;
1265 /* shuffle non-positional arguments above ntotal */
1266 ALLOC_FRAME (ntotal
+ nkw
);
1269 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1270 /* and fill optionals & keyword args with SCM_UNDEFINED */
1273 LOCAL_SET (n
++, SCM_UNDEFINED
);
1275 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1276 vm_error_kwargs_length_not_even (LOCAL_REF (0)));
1278 /* Now bind keywords, in the order given. */
1279 for (n
= 0; n
< nkw
; n
++)
1280 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1283 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1284 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1286 SCM si
= SCM_CDAR (walk
);
1287 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1288 LOCAL_REF (ntotal
+ n
+ 1));
1291 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1292 vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0),
1293 LOCAL_REF (ntotal
+ n
)));
1297 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (LOCAL_REF (0),
1298 LOCAL_REF (ntotal
+ n
)));
1305 rest
= scm_inline_cons (thread
, LOCAL_REF (ntotal
+ n
), rest
);
1306 LOCAL_SET (nreq_and_opt
, rest
);
1309 RESET_FRAME (ntotal
);
1316 * Collect any arguments at or above DST into a list, and store that
1319 VM_DEFINE_OP (29, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1321 scm_t_uint32 dst
, nargs
;
1324 UNPACK_24 (op
, dst
);
1325 nargs
= FRAME_LOCALS_COUNT ();
1329 ALLOC_FRAME (dst
+ 1);
1331 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1335 while (nargs
-- > dst
)
1337 rest
= scm_inline_cons (thread
, LOCAL_REF (nargs
), rest
);
1338 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1341 RESET_FRAME (dst
+ 1);
1344 LOCAL_SET (dst
, rest
);
1353 * Branching instructions
1358 * Add OFFSET, a signed 24-bit number, to the current instruction
1361 VM_DEFINE_OP (30, br
, "br", OP1 (U8_L24
))
1363 scm_t_int32 offset
= op
;
1364 offset
>>= 8; /* Sign-extending shift. */
1366 VM_HANDLE_INTERRUPTS
;
1370 /* br-if-true test:24 invert:1 _:7 offset:24
1372 * If the value in TEST is true for the purposes of Scheme, add
1373 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1375 VM_DEFINE_OP (31, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1377 BR_UNARY (x
, scm_is_true (x
));
1380 /* br-if-null test:24 invert:1 _:7 offset:24
1382 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1383 * signed 24-bit number, to the current instruction pointer.
1385 VM_DEFINE_OP (32, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1387 BR_UNARY (x
, scm_is_null (x
));
1390 /* br-if-nil test:24 invert:1 _:7 offset:24
1392 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1393 * number, to the current instruction pointer.
1395 VM_DEFINE_OP (33, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1397 BR_UNARY (x
, scm_is_lisp_false (x
));
1400 /* br-if-pair test:24 invert:1 _:7 offset:24
1402 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1403 * to the current instruction pointer.
1405 VM_DEFINE_OP (34, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1407 BR_UNARY (x
, scm_is_pair (x
));
1410 /* br-if-struct test:24 invert:1 _:7 offset:24
1412 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1413 * number, to the current instruction pointer.
1415 VM_DEFINE_OP (35, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1417 BR_UNARY (x
, SCM_STRUCTP (x
));
1420 /* br-if-char test:24 invert:1 _:7 offset:24
1422 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1423 * to the current instruction pointer.
1425 VM_DEFINE_OP (36, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1427 BR_UNARY (x
, SCM_CHARP (x
));
1430 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1432 * If the value in TEST has the TC7 given in the second word, add
1433 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1435 VM_DEFINE_OP (37, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1437 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1440 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1442 * If the value in A is eq? to the value in B, add OFFSET, a signed
1443 * 24-bit number, to the current instruction pointer.
1445 VM_DEFINE_OP (38, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1447 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1450 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1452 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1453 * 24-bit number, to the current instruction pointer.
1455 VM_DEFINE_OP (39, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1459 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1460 && scm_is_true (scm_eqv_p (x
, y
))));
1463 // FIXME: remove, have compiler inline eqv test instead
1464 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1466 * If the value in A is equal? to the value in B, add OFFSET, a signed
1467 * 24-bit number, to the current instruction pointer.
1469 // FIXME: Should sync_ip before calling out and cache_fp before coming
1470 // back! Another reason to remove this opcode!
1471 VM_DEFINE_OP (40, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1475 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1476 && scm_is_true (scm_equal_p (x
, y
))));
1479 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1481 * If the value in A is = to the value in B, add OFFSET, a signed
1482 * 24-bit number, to the current instruction pointer.
1484 VM_DEFINE_OP (41, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1486 BR_ARITHMETIC (==, scm_num_eq_p
);
1489 /* br-if-< a:12 b:12 invert:1 _:7 offset:24
1491 * If the value in A is < to the value in B, add OFFSET, a signed
1492 * 24-bit number, to the current instruction pointer.
1494 VM_DEFINE_OP (42, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1496 BR_ARITHMETIC (<, scm_less_p
);
1499 /* br-if-<= a:12 b:12 invert:1 _:7 offset:24
1501 * If the value in A is <= to the value in B, add OFFSET, a signed
1502 * 24-bit number, to the current instruction pointer.
1504 VM_DEFINE_OP (43, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1506 BR_ARITHMETIC (<=, scm_leq_p
);
1513 * Lexical binding instructions
1516 /* mov dst:12 src:12
1518 * Copy a value from one local slot to another.
1520 VM_DEFINE_OP (44, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1525 UNPACK_12_12 (op
, dst
, src
);
1526 LOCAL_SET (dst
, LOCAL_REF (src
));
1531 /* long-mov dst:24 _:8 src:24
1533 * Copy a value from one local slot to another.
1535 VM_DEFINE_OP (45, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1540 UNPACK_24 (op
, dst
);
1541 UNPACK_24 (ip
[1], src
);
1542 LOCAL_SET (dst
, LOCAL_REF (src
));
1547 /* box dst:12 src:12
1549 * Create a new variable holding SRC, and place it in DST.
1551 VM_DEFINE_OP (46, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1553 scm_t_uint16 dst
, src
;
1554 UNPACK_12_12 (op
, dst
, src
);
1555 LOCAL_SET (dst
, scm_inline_cell (thread
, scm_tc7_variable
,
1556 SCM_UNPACK (LOCAL_REF (src
))));
1560 /* box-ref dst:12 src:12
1562 * Unpack the variable at SRC into DST, asserting that the variable is
1565 VM_DEFINE_OP (47, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1567 scm_t_uint16 dst
, src
;
1569 UNPACK_12_12 (op
, dst
, src
);
1570 var
= LOCAL_REF (src
);
1571 VM_ASSERT (SCM_VARIABLEP (var
),
1572 vm_error_not_a_variable ("variable-ref", var
));
1573 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (var
));
1574 LOCAL_SET (dst
, VARIABLE_REF (var
));
1578 /* box-set! dst:12 src:12
1580 * Set the contents of the variable at DST to SET.
1582 VM_DEFINE_OP (48, box_set
, "box-set!", OP1 (U8_U12_U12
))
1584 scm_t_uint16 dst
, src
;
1586 UNPACK_12_12 (op
, dst
, src
);
1587 var
= LOCAL_REF (dst
);
1588 VM_ASSERT (SCM_VARIABLEP (var
),
1589 vm_error_not_a_variable ("variable-set!", var
));
1590 VARIABLE_SET (var
, LOCAL_REF (src
));
1594 /* make-closure dst:24 offset:32 _:8 nfree:24
1596 * Make a new closure, and write it to DST. The code for the closure
1597 * will be found at OFFSET words from the current IP. OFFSET is a
1598 * signed 32-bit integer. Space for NFREE free variables will be
1601 VM_DEFINE_OP (49, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1603 scm_t_uint32 dst
, nfree
, n
;
1607 UNPACK_24 (op
, dst
);
1609 UNPACK_24 (ip
[2], nfree
);
1611 // FIXME: Assert range of nfree?
1612 closure
= scm_inline_words (thread
, scm_tc7_program
| (nfree
<< 16),
1614 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1615 // FIXME: Elide these initializations?
1616 for (n
= 0; n
< nfree
; n
++)
1617 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1618 LOCAL_SET (dst
, closure
);
1622 /* free-ref dst:12 src:12 _:8 idx:24
1624 * Load free variable IDX from the closure SRC into local slot DST.
1626 VM_DEFINE_OP (50, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1628 scm_t_uint16 dst
, src
;
1630 UNPACK_12_12 (op
, dst
, src
);
1631 UNPACK_24 (ip
[1], idx
);
1632 /* CHECK_FREE_VARIABLE (src); */
1633 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1637 /* free-set! dst:12 src:12 _:8 idx:24
1639 * Set free variable IDX from the closure DST to SRC.
1641 VM_DEFINE_OP (51, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1643 scm_t_uint16 dst
, src
;
1645 UNPACK_12_12 (op
, dst
, src
);
1646 UNPACK_24 (ip
[1], idx
);
1647 /* CHECK_FREE_VARIABLE (src); */
1648 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1656 * Immediates and statically allocated non-immediates
1659 /* make-short-immediate dst:8 low-bits:16
1661 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1664 VM_DEFINE_OP (52, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1669 UNPACK_8_16 (op
, dst
, val
);
1670 LOCAL_SET (dst
, SCM_PACK (val
));
1674 /* make-long-immediate dst:24 low-bits:32
1676 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1679 VM_DEFINE_OP (53, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
) | OP_DST
)
1684 UNPACK_24 (op
, dst
);
1686 LOCAL_SET (dst
, SCM_PACK (val
));
1690 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1692 * Make an immediate with HIGH-BITS and LOW-BITS.
1694 VM_DEFINE_OP (54, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1699 UNPACK_24 (op
, dst
);
1700 #if SIZEOF_SCM_T_BITS > 4
1705 ASSERT (ip
[1] == 0);
1708 LOCAL_SET (dst
, SCM_PACK (val
));
1712 /* make-non-immediate dst:24 offset:32
1714 * Load a pointer to statically allocated memory into DST. The
1715 * object's memory is will be found OFFSET 32-bit words away from the
1716 * current instruction pointer. OFFSET is a signed value. The
1717 * intention here is that the compiler would produce an object file
1718 * containing the words of a non-immediate object, and this
1719 * instruction creates a pointer to that memory, effectively
1720 * resurrecting that object.
1722 * Whether the object is mutable or immutable depends on where it was
1723 * allocated by the compiler, and loaded by the loader.
1725 VM_DEFINE_OP (55, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1730 scm_t_bits unpacked
;
1732 UNPACK_24 (op
, dst
);
1735 unpacked
= (scm_t_bits
) loc
;
1737 VM_ASSERT (!(unpacked
& 0x7), abort());
1739 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1744 /* static-ref dst:24 offset:32
1746 * Load a SCM value into DST. The SCM value will be fetched from
1747 * memory, OFFSET 32-bit words away from the current instruction
1748 * pointer. OFFSET is a signed value.
1750 * The intention is for this instruction to be used to load constants
1751 * that the compiler is unable to statically allocate, like symbols.
1752 * These values would be initialized when the object file loads.
1754 VM_DEFINE_OP (56, static_ref
, "static-ref", OP2 (U8_U24
, S32
) | OP_DST
)
1759 scm_t_uintptr loc_bits
;
1761 UNPACK_24 (op
, dst
);
1764 loc_bits
= (scm_t_uintptr
) loc
;
1765 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1767 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1772 /* static-set! src:24 offset:32
1774 * Store a SCM value into memory, OFFSET 32-bit words away from the
1775 * current instruction pointer. OFFSET is a signed value.
1777 VM_DEFINE_OP (57, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1783 UNPACK_24 (op
, src
);
1786 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1788 *((SCM
*) loc
) = LOCAL_REF (src
);
1793 /* static-patch! _:24 dst-offset:32 src-offset:32
1795 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1796 * are signed 32-bit values, indicating a memory address as a number
1797 * of 32-bit words away from the current instruction pointer.
1799 VM_DEFINE_OP (58, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1801 scm_t_int32 dst_offset
, src_offset
;
1808 dst_loc
= (void **) (ip
+ dst_offset
);
1809 src
= ip
+ src_offset
;
1810 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1820 * Mutable top-level bindings
1823 /* There are three slightly different ways to resolve toplevel
1826 1. A toplevel reference outside of a function. These need to be
1827 looked up when the expression is evaluated -- no later, and no
1828 before. They are looked up relative to the module that is
1829 current when the expression is evaluated. For example:
1833 The "resolve" instruction resolves the variable (box), and then
1834 access is via box-ref or box-set!.
1836 2. A toplevel reference inside a function. These are looked up
1837 relative to the module that was current when the function was
1838 defined. Unlike code at the toplevel, which is usually run only
1839 once, these bindings benefit from memoized lookup, in which the
1840 variable resulting from the lookup is cached in the function.
1842 (lambda () (if (foo) a b))
1844 The toplevel-box instruction is equivalent to "resolve", but
1845 caches the resulting variable in statically allocated memory.
1847 3. A reference to an identifier with respect to a particular
1848 module. This can happen for primitive references, and
1849 references residualized by macro expansions. These can always
1850 be cached. Use module-box for these.
1853 /* current-module dst:24
1855 * Store the current module in DST.
1857 VM_DEFINE_OP (59, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1861 UNPACK_24 (op
, dst
);
1864 LOCAL_SET (dst
, scm_current_module ());
1869 /* resolve dst:24 bound?:1 _:7 sym:24
1871 * Resolve SYM in the current module, and place the resulting variable
1874 VM_DEFINE_OP (60, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1880 UNPACK_24 (op
, dst
);
1881 UNPACK_24 (ip
[1], sym
);
1884 var
= scm_lookup (LOCAL_REF (sym
));
1887 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (LOCAL_REF (sym
)));
1888 LOCAL_SET (dst
, var
);
1893 /* define! sym:12 val:12
1895 * Look up a binding for SYM in the current module, creating it if
1896 * necessary. Set its value to VAL.
1898 VM_DEFINE_OP (61, define
, "define!", OP1 (U8_U12_U12
))
1900 scm_t_uint16 sym
, val
;
1901 UNPACK_12_12 (op
, sym
, val
);
1903 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1908 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1910 * Load a SCM value. The SCM value will be fetched from memory,
1911 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1912 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1915 * Then, if the loaded value is a variable, it is placed in DST, and control
1918 * Otherwise, we have to resolve the variable. In that case we load
1919 * the module from MOD-OFFSET, just as we loaded the variable.
1920 * Usually the module gets set when the closure is created. The name
1921 * is an offset to a symbol.
1923 * We use the module and the symbol to resolve the variable, placing it in
1924 * DST, and caching the resolved variable so that we will hit the cache next
1927 VM_DEFINE_OP (62, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1930 scm_t_int32 var_offset
;
1931 scm_t_uint32
* var_loc_u32
;
1935 UNPACK_24 (op
, dst
);
1937 var_loc_u32
= ip
+ var_offset
;
1938 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1939 var_loc
= (SCM
*) var_loc_u32
;
1942 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1945 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1946 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1947 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1948 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1952 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1953 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1955 mod
= *((SCM
*) mod_loc
);
1956 sym
= *((SCM
*) sym_loc
);
1958 /* If the toplevel scope was captured before modules were
1959 booted, use the root module. */
1960 if (scm_is_false (mod
))
1961 mod
= scm_the_root_module ();
1963 var
= scm_module_lookup (mod
, sym
);
1966 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
1971 LOCAL_SET (dst
, var
);
1975 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1977 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1978 * instead of the module itself.
1980 VM_DEFINE_OP (63, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1983 scm_t_int32 var_offset
;
1984 scm_t_uint32
* var_loc_u32
;
1988 UNPACK_24 (op
, dst
);
1990 var_loc_u32
= ip
+ var_offset
;
1991 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1992 var_loc
= (SCM
*) var_loc_u32
;
1995 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1998 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1999 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2000 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2001 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2005 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2006 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2008 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2009 sym
= *((SCM
*) sym_loc
);
2011 if (!scm_module_system_booted_p
)
2014 scm_equal_p (modname
,
2017 scm_from_utf8_symbol ("guile"))));
2018 var
= scm_lookup (sym
);
2020 else if (scm_is_true (SCM_CAR (modname
)))
2021 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2023 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2028 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
2033 LOCAL_SET (dst
, var
);
2040 * The dynamic environment
2043 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2045 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2046 * handler at HANDLER-OFFSET words from the current IP. The handler
2047 * will expect a multiple-value return as if from a call with the
2048 * procedure at PROC-SLOT.
2050 VM_DEFINE_OP (64, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2052 scm_t_uint32 tag
, proc_slot
;
2054 scm_t_uint8 escape_only_p
;
2055 scm_t_dynstack_prompt_flags flags
;
2057 UNPACK_24 (op
, tag
);
2058 escape_only_p
= ip
[1] & 0x1;
2059 UNPACK_24 (ip
[1], proc_slot
);
2061 offset
>>= 8; /* Sign extension */
2063 /* Push the prompt onto the dynamic stack. */
2064 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2065 scm_dynstack_push_prompt (&thread
->dynstack
, flags
,
2067 fp
- vp
->stack_base
,
2068 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2074 /* wind winder:12 unwinder:12
2076 * Push wind and unwind procedures onto the dynamic stack. Note that
2077 * neither are actually called; the compiler should emit calls to wind
2078 * and unwind for the normal dynamic-wind control flow. Also note that
2079 * the compiler should have inserted checks that they wind and unwind
2080 * procs are thunks, if it could not prove that to be the case.
2082 VM_DEFINE_OP (65, wind
, "wind", OP1 (U8_U12_U12
))
2084 scm_t_uint16 winder
, unwinder
;
2085 UNPACK_12_12 (op
, winder
, unwinder
);
2086 scm_dynstack_push_dynwind (&thread
->dynstack
,
2087 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2093 * A normal exit from the dynamic extent of an expression. Pop the top
2094 * entry off of the dynamic stack.
2096 VM_DEFINE_OP (66, unwind
, "unwind", OP1 (U8_X24
))
2098 scm_dynstack_pop (&thread
->dynstack
);
2102 /* push-fluid fluid:12 value:12
2104 * Dynamically bind VALUE to FLUID.
2106 VM_DEFINE_OP (67, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2108 scm_t_uint32 fluid
, value
;
2110 UNPACK_12_12 (op
, fluid
, value
);
2112 scm_dynstack_push_fluid (&thread
->dynstack
,
2113 LOCAL_REF (fluid
), LOCAL_REF (value
),
2114 thread
->dynamic_state
);
2120 * Leave the dynamic extent of a with-fluid* expression, restoring the
2121 * fluid to its previous value.
2123 VM_DEFINE_OP (68, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2125 /* This function must not allocate. */
2126 scm_dynstack_unwind_fluid (&thread
->dynstack
,
2127 thread
->dynamic_state
);
2131 /* fluid-ref dst:12 src:12
2133 * Reference the fluid in SRC, and place the value in DST.
2135 VM_DEFINE_OP (69, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2137 scm_t_uint16 dst
, src
;
2141 UNPACK_12_12 (op
, dst
, src
);
2142 fluid
= LOCAL_REF (src
);
2143 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2144 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2145 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2147 /* Punt dynstate expansion and error handling to the C proc. */
2149 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2153 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2154 if (scm_is_eq (val
, SCM_UNDEFINED
))
2155 val
= SCM_I_FLUID_DEFAULT (fluid
);
2156 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2157 vm_error_unbound_fluid (fluid
));
2158 LOCAL_SET (dst
, val
);
2164 /* fluid-set fluid:12 val:12
2166 * Set the value of the fluid in DST to the value in SRC.
2168 VM_DEFINE_OP (70, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2174 UNPACK_12_12 (op
, a
, b
);
2175 fluid
= LOCAL_REF (a
);
2176 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2177 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2178 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2180 /* Punt dynstate expansion and error handling to the C proc. */
2182 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2185 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2194 * Strings, symbols, and keywords
2197 /* string-length dst:12 src:12
2199 * Store the length of the string in SRC in DST.
2201 VM_DEFINE_OP (71, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2204 if (SCM_LIKELY (scm_is_string (str
)))
2205 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2209 RETURN (scm_string_length (str
));
2213 /* string-ref dst:8 src:8 idx:8
2215 * Fetch the character at position IDX in the string in SRC, and store
2218 VM_DEFINE_OP (72, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2220 scm_t_signed_bits i
= 0;
2222 if (SCM_LIKELY (scm_is_string (str
)
2223 && SCM_I_INUMP (idx
)
2224 && ((i
= SCM_I_INUM (idx
)) >= 0)
2225 && i
< scm_i_string_length (str
)))
2226 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2230 RETURN (scm_string_ref (str
, idx
));
2234 /* No string-set! instruction, as there is no good fast path there. */
2236 /* string->number dst:12 src:12
2238 * Parse a string in SRC to a number, and store in DST.
2240 VM_DEFINE_OP (73, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2242 scm_t_uint16 dst
, src
;
2244 UNPACK_12_12 (op
, dst
, src
);
2247 scm_string_to_number (LOCAL_REF (src
),
2248 SCM_UNDEFINED
/* radix = 10 */));
2252 /* string->symbol dst:12 src:12
2254 * Parse a string in SRC to a symbol, and store in DST.
2256 VM_DEFINE_OP (74, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2258 scm_t_uint16 dst
, src
;
2260 UNPACK_12_12 (op
, dst
, src
);
2262 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2266 /* symbol->keyword dst:12 src:12
2268 * Make a keyword from the symbol in SRC, and store it in DST.
2270 VM_DEFINE_OP (75, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2272 scm_t_uint16 dst
, src
;
2273 UNPACK_12_12 (op
, dst
, src
);
2275 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2285 /* cons dst:8 car:8 cdr:8
2287 * Cons CAR and CDR, and store the result in DST.
2289 VM_DEFINE_OP (76, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2292 RETURN (scm_inline_cons (thread
, x
, y
));
2295 /* car dst:12 src:12
2297 * Place the car of SRC in DST.
2299 VM_DEFINE_OP (77, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2302 VM_VALIDATE_PAIR (x
, "car");
2303 RETURN (SCM_CAR (x
));
2306 /* cdr dst:12 src:12
2308 * Place the cdr of SRC in DST.
2310 VM_DEFINE_OP (78, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2313 VM_VALIDATE_PAIR (x
, "cdr");
2314 RETURN (SCM_CDR (x
));
2317 /* set-car! pair:12 car:12
2319 * Set the car of DST to SRC.
2321 VM_DEFINE_OP (79, set_car
, "set-car!", OP1 (U8_U12_U12
))
2325 UNPACK_12_12 (op
, a
, b
);
2328 VM_VALIDATE_PAIR (x
, "set-car!");
2333 /* set-cdr! pair:12 cdr:12
2335 * Set the cdr of DST to SRC.
2337 VM_DEFINE_OP (80, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2341 UNPACK_12_12 (op
, a
, b
);
2344 VM_VALIDATE_PAIR (x
, "set-car!");
2353 * Numeric operations
2356 /* add dst:8 a:8 b:8
2358 * Add A to B, and place the result in DST.
2360 VM_DEFINE_OP (81, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2362 BINARY_INTEGER_OP (+, scm_sum
);
2365 /* add1 dst:12 src:12
2367 * Add 1 to the value in SRC, and place the result in DST.
2369 VM_DEFINE_OP (82, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2373 /* Check for overflow. We must avoid overflow in the signed
2374 addition below, even if X is not an inum. */
2375 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2379 /* Add 1 to the integer without untagging. */
2380 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2382 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2386 RETURN_EXP (scm_sum (x
, SCM_I_MAKINUM (1)));
2389 /* sub dst:8 a:8 b:8
2391 * Subtract B from A, and place the result in DST.
2393 VM_DEFINE_OP (83, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2395 BINARY_INTEGER_OP (-, scm_difference
);
2398 /* sub1 dst:12 src:12
2400 * Subtract 1 from SRC, and place the result in DST.
2402 VM_DEFINE_OP (84, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2406 /* Check for overflow. We must avoid overflow in the signed
2407 subtraction below, even if X is not an inum. */
2408 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2412 /* Substract 1 from the integer without untagging. */
2413 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2415 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2419 RETURN_EXP (scm_difference (x
, SCM_I_MAKINUM (1)));
2422 /* mul dst:8 a:8 b:8
2424 * Multiply A and B, and place the result in DST.
2426 VM_DEFINE_OP (85, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2429 RETURN_EXP (scm_product (x
, y
));
2432 /* div dst:8 a:8 b:8
2434 * Divide A by B, and place the result in DST.
2436 VM_DEFINE_OP (86, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2439 RETURN_EXP (scm_divide (x
, y
));
2442 /* quo dst:8 a:8 b:8
2444 * Divide A by B, and place the quotient in DST.
2446 VM_DEFINE_OP (87, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2449 RETURN_EXP (scm_quotient (x
, y
));
2452 /* rem dst:8 a:8 b:8
2454 * Divide A by B, and place the remainder in DST.
2456 VM_DEFINE_OP (88, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2459 RETURN_EXP (scm_remainder (x
, y
));
2462 /* mod dst:8 a:8 b:8
2464 * Place the modulo of A by B in DST.
2466 VM_DEFINE_OP (89, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2469 RETURN_EXP (scm_modulo (x
, y
));
2472 /* ash dst:8 a:8 b:8
2474 * Shift A arithmetically by B bits, and place the result in DST.
2476 VM_DEFINE_OP (90, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2479 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2481 if (SCM_I_INUM (y
) < 0)
2482 /* Right shift, will be a fixnum. */
2483 RETURN (SCM_I_MAKINUM
2484 (SCM_SRS (SCM_I_INUM (x
),
2485 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2486 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2488 /* Left shift. See comments in scm_ash. */
2490 scm_t_signed_bits nn
, bits_to_shift
;
2492 nn
= SCM_I_INUM (x
);
2493 bits_to_shift
= SCM_I_INUM (y
);
2495 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2497 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2499 RETURN (SCM_I_MAKINUM (nn
< 0
2500 ? -(-nn
<< bits_to_shift
)
2501 : (nn
<< bits_to_shift
)));
2506 RETURN_EXP (scm_ash (x
, y
));
2509 /* logand dst:8 a:8 b:8
2511 * Place the bitwise AND of A and B into DST.
2513 VM_DEFINE_OP (91, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2516 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2517 /* Compute bitwise AND without untagging */
2518 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2519 RETURN_EXP (scm_logand (x
, y
));
2522 /* logior dst:8 a:8 b:8
2524 * Place the bitwise inclusive OR of A with B in DST.
2526 VM_DEFINE_OP (92, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2529 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2530 /* Compute bitwise OR without untagging */
2531 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2532 RETURN_EXP (scm_logior (x
, y
));
2535 /* logxor dst:8 a:8 b:8
2537 * Place the bitwise exclusive OR of A with B in DST.
2539 VM_DEFINE_OP (93, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2542 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2543 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2544 RETURN_EXP (scm_logxor (x
, y
));
2547 /* make-vector dst:8 length:8 init:8
2549 * Make a vector and write it to DST. The vector will have space for
2550 * LENGTH slots. They will be filled with the value in slot INIT.
2552 VM_DEFINE_OP (94, make_vector
, "make-vector", OP1 (U8_U8_U8_U8
) | OP_DST
)
2554 scm_t_uint8 dst
, init
, length
;
2556 UNPACK_8_8_8 (op
, dst
, length
, init
);
2558 LOCAL_SET (dst
, scm_make_vector (LOCAL_REF (length
), LOCAL_REF (init
)));
2563 /* make-vector/immediate dst:8 length:8 init:8
2565 * Make a short vector of known size and write it to DST. The vector
2566 * will have space for LENGTH slots, an immediate value. They will be
2567 * filled with the value in slot INIT.
2569 VM_DEFINE_OP (95, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2571 scm_t_uint8 dst
, init
;
2572 scm_t_int32 length
, n
;
2575 UNPACK_8_8_8 (op
, dst
, length
, init
);
2577 val
= LOCAL_REF (init
);
2578 vector
= scm_inline_words (thread
, scm_tc7_vector
| (length
<< 8),
2580 for (n
= 0; n
< length
; n
++)
2581 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2582 LOCAL_SET (dst
, vector
);
2586 /* vector-length dst:12 src:12
2588 * Store the length of the vector in SRC in DST.
2590 VM_DEFINE_OP (96, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2593 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2594 vm_error_not_a_vector ("vector-ref", vect
));
2595 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2598 /* vector-ref dst:8 src:8 idx:8
2600 * Fetch the item at position IDX in the vector in SRC, and store it
2603 VM_DEFINE_OP (97, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2605 scm_t_signed_bits i
= 0;
2607 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2608 vm_error_not_a_vector ("vector-ref", vect
));
2609 VM_ASSERT ((SCM_I_INUMP (idx
)
2610 && ((i
= SCM_I_INUM (idx
)) >= 0)
2611 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2612 vm_error_out_of_range ("vector-ref", idx
));
2613 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2616 /* vector-ref/immediate dst:8 src:8 idx:8
2618 * Fill DST with the item IDX elements into the vector at SRC. Useful
2619 * for building data types using vectors.
2621 VM_DEFINE_OP (98, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2623 scm_t_uint8 dst
, src
, idx
;
2626 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2627 v
= LOCAL_REF (src
);
2628 VM_ASSERT (SCM_I_IS_VECTOR (v
),
2629 vm_error_not_a_vector ("vector-ref", v
));
2630 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (v
),
2631 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2632 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2636 /* vector-set! dst:8 idx:8 src:8
2638 * Store SRC into the vector DST at index IDX.
2640 VM_DEFINE_OP (99, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2642 scm_t_uint8 dst
, idx_var
, src
;
2644 scm_t_signed_bits i
= 0;
2646 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2647 vect
= LOCAL_REF (dst
);
2648 idx
= LOCAL_REF (idx_var
);
2649 val
= LOCAL_REF (src
);
2651 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2652 vm_error_not_a_vector ("vector-ref", vect
));
2653 VM_ASSERT ((SCM_I_INUMP (idx
)
2654 && ((i
= SCM_I_INUM (idx
)) >= 0)
2655 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2656 vm_error_out_of_range ("vector-ref", idx
));
2657 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2661 /* vector-set!/immediate dst:8 idx:8 src:8
2663 * Store SRC into the vector DST at index IDX. Here IDX is an
2666 VM_DEFINE_OP (100, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2668 scm_t_uint8 dst
, idx
, src
;
2671 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2672 vect
= LOCAL_REF (dst
);
2673 val
= LOCAL_REF (src
);
2675 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2676 vm_error_not_a_vector ("vector-ref", vect
));
2677 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (vect
),
2678 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2679 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2690 /* struct-vtable dst:12 src:12
2692 * Store the vtable of SRC into DST.
2694 VM_DEFINE_OP (101, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2697 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2698 RETURN (SCM_STRUCT_VTABLE (obj
));
2701 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2703 * Allocate a new struct with VTABLE, and place it in DST. The struct
2704 * will be constructed with space for NFIELDS fields, which should
2705 * correspond to the field count of the VTABLE.
2707 VM_DEFINE_OP (102, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2709 scm_t_uint8 dst
, vtable
, nfields
;
2712 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2715 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2716 LOCAL_SET (dst
, ret
);
2721 /* struct-ref/immediate dst:8 src:8 idx:8
2723 * Fetch the item at slot IDX in the struct in SRC, and store it
2724 * in DST. IDX is an immediate unsigned 8-bit value.
2726 VM_DEFINE_OP (103, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2728 scm_t_uint8 dst
, src
, idx
;
2731 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2733 obj
= LOCAL_REF (src
);
2735 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2736 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2737 SCM_VTABLE_FLAG_SIMPLE
)
2738 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2739 scm_vtable_index_size
)))
2740 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2743 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2746 /* struct-set!/immediate dst:8 idx:8 src:8
2748 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2749 * unsigned 8-bit value.
2751 VM_DEFINE_OP (104, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2753 scm_t_uint8 dst
, idx
, src
;
2756 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2758 obj
= LOCAL_REF (dst
);
2759 val
= LOCAL_REF (src
);
2761 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2762 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2763 SCM_VTABLE_FLAG_SIMPLE
)
2764 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2765 SCM_VTABLE_FLAG_SIMPLE_RW
)
2766 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2767 scm_vtable_index_size
)))
2769 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2774 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2778 /* class-of dst:12 type:12
2780 * Store the vtable of SRC into DST.
2782 VM_DEFINE_OP (105, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2785 if (SCM_INSTANCEP (obj
))
2786 RETURN (SCM_CLASS_OF (obj
));
2788 RETURN (scm_class_of (obj
));
2794 * Arrays, packed uniform arrays, and bytevectors.
2797 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2799 * Load the contiguous typed array located at OFFSET 32-bit words away
2800 * from the instruction pointer, and store into DST. LEN is a byte
2801 * length. OFFSET is signed.
2803 VM_DEFINE_OP (106, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2805 scm_t_uint8 dst
, type
, shape
;
2809 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2813 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2819 /* make-array dst:8 type:8 fill:8 _:8 bounds:24
2821 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2823 VM_DEFINE_OP (107, make_array
, "make-array", OP2 (U8_U8_U8_U8
, X8_U24
) | OP_DST
)
2825 scm_t_uint8 dst
, type
, fill
, bounds
;
2826 UNPACK_8_8_8 (op
, dst
, type
, fill
);
2827 UNPACK_24 (ip
[1], bounds
);
2829 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2830 LOCAL_REF (bounds
)));
2834 /* bv-u8-ref dst:8 src:8 idx:8
2835 * bv-s8-ref dst:8 src:8 idx:8
2836 * bv-u16-ref dst:8 src:8 idx:8
2837 * bv-s16-ref dst:8 src:8 idx:8
2838 * bv-u32-ref dst:8 src:8 idx:8
2839 * bv-s32-ref dst:8 src:8 idx:8
2840 * bv-u64-ref dst:8 src:8 idx:8
2841 * bv-s64-ref dst:8 src:8 idx:8
2842 * bv-f32-ref dst:8 src:8 idx:8
2843 * bv-f64-ref dst:8 src:8 idx:8
2845 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2846 * it in DST. All accesses use native endianness.
2848 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2850 scm_t_signed_bits i; \
2851 const scm_t_ ## type *int_ptr; \
2854 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2855 i = SCM_I_INUM (idx); \
2856 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2858 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2860 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2861 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2862 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2866 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2870 #define BV_INT_REF(stem, type, size) \
2872 scm_t_signed_bits i; \
2873 const scm_t_ ## type *int_ptr; \
2876 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2877 i = SCM_I_INUM (idx); \
2878 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2880 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2882 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2883 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2885 scm_t_ ## type x = *int_ptr; \
2886 if (SCM_FIXABLE (x)) \
2887 RETURN (SCM_I_MAKINUM (x)); \
2891 RETURN (scm_from_ ## type (x)); \
2897 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2901 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2903 scm_t_signed_bits i; \
2904 const type *float_ptr; \
2907 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2908 i = SCM_I_INUM (idx); \
2909 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2912 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2914 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2915 && (ALIGNED_P (float_ptr, type)))) \
2916 RETURN (scm_from_double (*float_ptr)); \
2918 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2921 VM_DEFINE_OP (108, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2922 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2924 VM_DEFINE_OP (109, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2925 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2927 VM_DEFINE_OP (110, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2928 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2930 VM_DEFINE_OP (111, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2931 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2933 VM_DEFINE_OP (112, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2934 #if SIZEOF_VOID_P > 4
2935 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2937 BV_INT_REF (u32
, uint32
, 4);
2940 VM_DEFINE_OP (113, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2941 #if SIZEOF_VOID_P > 4
2942 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2944 BV_INT_REF (s32
, int32
, 4);
2947 VM_DEFINE_OP (114, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2948 BV_INT_REF (u64
, uint64
, 8);
2950 VM_DEFINE_OP (115, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2951 BV_INT_REF (s64
, int64
, 8);
2953 VM_DEFINE_OP (116, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2954 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2956 VM_DEFINE_OP (117, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2957 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2959 /* bv-u8-set! dst:8 idx:8 src:8
2960 * bv-s8-set! dst:8 idx:8 src:8
2961 * bv-u16-set! dst:8 idx:8 src:8
2962 * bv-s16-set! dst:8 idx:8 src:8
2963 * bv-u32-set! dst:8 idx:8 src:8
2964 * bv-s32-set! dst:8 idx:8 src:8
2965 * bv-u64-set! dst:8 idx:8 src:8
2966 * bv-s64-set! dst:8 idx:8 src:8
2967 * bv-f32-set! dst:8 idx:8 src:8
2968 * bv-f64-set! dst:8 idx:8 src:8
2970 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2971 * values are written using native endianness.
2973 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2975 scm_t_uint8 dst, idx, src; \
2976 scm_t_signed_bits i, j = 0; \
2977 SCM bv, scm_idx, val; \
2978 scm_t_ ## type *int_ptr; \
2980 UNPACK_8_8_8 (op, dst, idx, src); \
2981 bv = LOCAL_REF (dst); \
2982 scm_idx = LOCAL_REF (idx); \
2983 val = LOCAL_REF (src); \
2984 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2985 i = SCM_I_INUM (scm_idx); \
2986 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2988 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2990 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2991 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2992 && (SCM_I_INUMP (val)) \
2993 && ((j = SCM_I_INUM (val)) >= min) \
2995 *int_ptr = (scm_t_ ## type) j; \
2999 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3004 #define BV_INT_SET(stem, type, size) \
3006 scm_t_uint8 dst, idx, src; \
3007 scm_t_signed_bits i; \
3008 SCM bv, scm_idx, val; \
3009 scm_t_ ## type *int_ptr; \
3011 UNPACK_8_8_8 (op, dst, idx, src); \
3012 bv = LOCAL_REF (dst); \
3013 scm_idx = LOCAL_REF (idx); \
3014 val = LOCAL_REF (src); \
3015 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3016 i = SCM_I_INUM (scm_idx); \
3017 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3019 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3021 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3022 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3023 *int_ptr = scm_to_ ## type (val); \
3027 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3032 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3034 scm_t_uint8 dst, idx, src; \
3035 scm_t_signed_bits i; \
3036 SCM bv, scm_idx, val; \
3039 UNPACK_8_8_8 (op, dst, idx, src); \
3040 bv = LOCAL_REF (dst); \
3041 scm_idx = LOCAL_REF (idx); \
3042 val = LOCAL_REF (src); \
3043 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3044 i = SCM_I_INUM (scm_idx); \
3045 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3047 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3049 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3050 && (ALIGNED_P (float_ptr, type)))) \
3051 *float_ptr = scm_to_double (val); \
3055 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3060 VM_DEFINE_OP (118, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3061 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3063 VM_DEFINE_OP (119, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3064 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3066 VM_DEFINE_OP (120, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3067 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3069 VM_DEFINE_OP (121, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3070 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3072 VM_DEFINE_OP (122, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3073 #if SIZEOF_VOID_P > 4
3074 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3076 BV_INT_SET (u32
, uint32
, 4);
3079 VM_DEFINE_OP (123, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3080 #if SIZEOF_VOID_P > 4
3081 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3083 BV_INT_SET (s32
, int32
, 4);
3086 VM_DEFINE_OP (124, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3087 BV_INT_SET (u64
, uint64
, 8);
3089 VM_DEFINE_OP (125, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3090 BV_INT_SET (s64
, int64
, 8);
3092 VM_DEFINE_OP (126, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3093 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3095 VM_DEFINE_OP (127, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3096 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3098 /* br-if-logtest a:12 b:12 invert:1 _:7 offset:24
3100 * If the exact integer in A has any bits in common with the exact
3101 * integer in B, add OFFSET, a signed 24-bit number, to the current
3102 * instruction pointer.
3104 VM_DEFINE_OP (128, br_if_logtest
, "br-if-logtest", OP2 (U8_U12_U12
, B1_X7_L24
))
3107 ((SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
3108 ? (SCM_UNPACK (x
) & SCM_UNPACK (y
) & ~scm_tc2_int
)
3109 : scm_is_true (scm_logtest (x
, y
))));
3112 VM_DEFINE_OP (129, unused_129
, NULL
, NOP
)
3113 VM_DEFINE_OP (130, unused_130
, NULL
, NOP
)
3114 VM_DEFINE_OP (131, unused_131
, NULL
, NOP
)
3115 VM_DEFINE_OP (132, unused_132
, NULL
, NOP
)
3116 VM_DEFINE_OP (133, unused_133
, NULL
, NOP
)
3117 VM_DEFINE_OP (134, unused_134
, NULL
, NOP
)
3118 VM_DEFINE_OP (135, unused_135
, NULL
, NOP
)
3119 VM_DEFINE_OP (136, unused_136
, NULL
, NOP
)
3120 VM_DEFINE_OP (137, unused_137
, NULL
, NOP
)
3121 VM_DEFINE_OP (138, unused_138
, NULL
, NOP
)
3122 VM_DEFINE_OP (139, unused_139
, NULL
, NOP
)
3123 VM_DEFINE_OP (140, unused_140
, NULL
, NOP
)
3124 VM_DEFINE_OP (141, unused_141
, NULL
, NOP
)
3125 VM_DEFINE_OP (142, unused_142
, NULL
, NOP
)
3126 VM_DEFINE_OP (143, unused_143
, NULL
, NOP
)
3127 VM_DEFINE_OP (144, unused_144
, NULL
, NOP
)
3128 VM_DEFINE_OP (145, unused_145
, NULL
, NOP
)
3129 VM_DEFINE_OP (146, unused_146
, NULL
, NOP
)
3130 VM_DEFINE_OP (147, unused_147
, NULL
, NOP
)
3131 VM_DEFINE_OP (148, unused_148
, NULL
, NOP
)
3132 VM_DEFINE_OP (149, unused_149
, NULL
, NOP
)
3133 VM_DEFINE_OP (150, unused_150
, NULL
, NOP
)
3134 VM_DEFINE_OP (151, unused_151
, NULL
, NOP
)
3135 VM_DEFINE_OP (152, unused_152
, NULL
, NOP
)
3136 VM_DEFINE_OP (153, unused_153
, NULL
, NOP
)
3137 VM_DEFINE_OP (154, unused_154
, NULL
, NOP
)
3138 VM_DEFINE_OP (155, unused_155
, NULL
, NOP
)
3139 VM_DEFINE_OP (156, unused_156
, NULL
, NOP
)
3140 VM_DEFINE_OP (157, unused_157
, NULL
, NOP
)
3141 VM_DEFINE_OP (158, unused_158
, NULL
, NOP
)
3142 VM_DEFINE_OP (159, unused_159
, NULL
, NOP
)
3143 VM_DEFINE_OP (160, unused_160
, NULL
, NOP
)
3144 VM_DEFINE_OP (161, unused_161
, NULL
, NOP
)
3145 VM_DEFINE_OP (162, unused_162
, NULL
, NOP
)
3146 VM_DEFINE_OP (163, unused_163
, NULL
, NOP
)
3147 VM_DEFINE_OP (164, unused_164
, NULL
, NOP
)
3148 VM_DEFINE_OP (165, unused_165
, NULL
, NOP
)
3149 VM_DEFINE_OP (166, unused_166
, NULL
, NOP
)
3150 VM_DEFINE_OP (167, unused_167
, NULL
, NOP
)
3151 VM_DEFINE_OP (168, unused_168
, NULL
, NOP
)
3152 VM_DEFINE_OP (169, unused_169
, NULL
, NOP
)
3153 VM_DEFINE_OP (170, unused_170
, NULL
, NOP
)
3154 VM_DEFINE_OP (171, unused_171
, NULL
, NOP
)
3155 VM_DEFINE_OP (172, unused_172
, NULL
, NOP
)
3156 VM_DEFINE_OP (173, unused_173
, NULL
, NOP
)
3157 VM_DEFINE_OP (174, unused_174
, NULL
, NOP
)
3158 VM_DEFINE_OP (175, unused_175
, NULL
, NOP
)
3159 VM_DEFINE_OP (176, unused_176
, NULL
, NOP
)
3160 VM_DEFINE_OP (177, unused_177
, NULL
, NOP
)
3161 VM_DEFINE_OP (178, unused_178
, NULL
, NOP
)
3162 VM_DEFINE_OP (179, unused_179
, NULL
, NOP
)
3163 VM_DEFINE_OP (180, unused_180
, NULL
, NOP
)
3164 VM_DEFINE_OP (181, unused_181
, NULL
, NOP
)
3165 VM_DEFINE_OP (182, unused_182
, NULL
, NOP
)
3166 VM_DEFINE_OP (183, unused_183
, NULL
, NOP
)
3167 VM_DEFINE_OP (184, unused_184
, NULL
, NOP
)
3168 VM_DEFINE_OP (185, unused_185
, NULL
, NOP
)
3169 VM_DEFINE_OP (186, unused_186
, NULL
, NOP
)
3170 VM_DEFINE_OP (187, unused_187
, NULL
, NOP
)
3171 VM_DEFINE_OP (188, unused_188
, NULL
, NOP
)
3172 VM_DEFINE_OP (189, unused_189
, NULL
, NOP
)
3173 VM_DEFINE_OP (190, unused_190
, NULL
, NOP
)
3174 VM_DEFINE_OP (191, unused_191
, NULL
, NOP
)
3175 VM_DEFINE_OP (192, unused_192
, NULL
, NOP
)
3176 VM_DEFINE_OP (193, unused_193
, NULL
, NOP
)
3177 VM_DEFINE_OP (194, unused_194
, NULL
, NOP
)
3178 VM_DEFINE_OP (195, unused_195
, NULL
, NOP
)
3179 VM_DEFINE_OP (196, unused_196
, NULL
, NOP
)
3180 VM_DEFINE_OP (197, unused_197
, NULL
, NOP
)
3181 VM_DEFINE_OP (198, unused_198
, NULL
, NOP
)
3182 VM_DEFINE_OP (199, unused_199
, NULL
, NOP
)
3183 VM_DEFINE_OP (200, unused_200
, NULL
, NOP
)
3184 VM_DEFINE_OP (201, unused_201
, NULL
, NOP
)
3185 VM_DEFINE_OP (202, unused_202
, NULL
, NOP
)
3186 VM_DEFINE_OP (203, unused_203
, NULL
, NOP
)
3187 VM_DEFINE_OP (204, unused_204
, NULL
, NOP
)
3188 VM_DEFINE_OP (205, unused_205
, NULL
, NOP
)
3189 VM_DEFINE_OP (206, unused_206
, NULL
, NOP
)
3190 VM_DEFINE_OP (207, unused_207
, NULL
, NOP
)
3191 VM_DEFINE_OP (208, unused_208
, NULL
, NOP
)
3192 VM_DEFINE_OP (209, unused_209
, NULL
, NOP
)
3193 VM_DEFINE_OP (210, unused_210
, NULL
, NOP
)
3194 VM_DEFINE_OP (211, unused_211
, NULL
, NOP
)
3195 VM_DEFINE_OP (212, unused_212
, NULL
, NOP
)
3196 VM_DEFINE_OP (213, unused_213
, NULL
, NOP
)
3197 VM_DEFINE_OP (214, unused_214
, NULL
, NOP
)
3198 VM_DEFINE_OP (215, unused_215
, NULL
, NOP
)
3199 VM_DEFINE_OP (216, unused_216
, NULL
, NOP
)
3200 VM_DEFINE_OP (217, unused_217
, NULL
, NOP
)
3201 VM_DEFINE_OP (218, unused_218
, NULL
, NOP
)
3202 VM_DEFINE_OP (219, unused_219
, NULL
, NOP
)
3203 VM_DEFINE_OP (220, unused_220
, NULL
, NOP
)
3204 VM_DEFINE_OP (221, unused_221
, NULL
, NOP
)
3205 VM_DEFINE_OP (222, unused_222
, NULL
, NOP
)
3206 VM_DEFINE_OP (223, unused_223
, NULL
, NOP
)
3207 VM_DEFINE_OP (224, unused_224
, NULL
, NOP
)
3208 VM_DEFINE_OP (225, unused_225
, NULL
, NOP
)
3209 VM_DEFINE_OP (226, unused_226
, NULL
, NOP
)
3210 VM_DEFINE_OP (227, unused_227
, NULL
, NOP
)
3211 VM_DEFINE_OP (228, unused_228
, NULL
, NOP
)
3212 VM_DEFINE_OP (229, unused_229
, NULL
, NOP
)
3213 VM_DEFINE_OP (230, unused_230
, NULL
, NOP
)
3214 VM_DEFINE_OP (231, unused_231
, NULL
, NOP
)
3215 VM_DEFINE_OP (232, unused_232
, NULL
, NOP
)
3216 VM_DEFINE_OP (233, unused_233
, NULL
, NOP
)
3217 VM_DEFINE_OP (234, unused_234
, NULL
, NOP
)
3218 VM_DEFINE_OP (235, unused_235
, NULL
, NOP
)
3219 VM_DEFINE_OP (236, unused_236
, NULL
, NOP
)
3220 VM_DEFINE_OP (237, unused_237
, NULL
, NOP
)
3221 VM_DEFINE_OP (238, unused_238
, NULL
, NOP
)
3222 VM_DEFINE_OP (239, unused_239
, NULL
, NOP
)
3223 VM_DEFINE_OP (240, unused_240
, NULL
, NOP
)
3224 VM_DEFINE_OP (241, unused_241
, NULL
, NOP
)
3225 VM_DEFINE_OP (242, unused_242
, NULL
, NOP
)
3226 VM_DEFINE_OP (243, unused_243
, NULL
, NOP
)
3227 VM_DEFINE_OP (244, unused_244
, NULL
, NOP
)
3228 VM_DEFINE_OP (245, unused_245
, NULL
, NOP
)
3229 VM_DEFINE_OP (246, unused_246
, NULL
, NOP
)
3230 VM_DEFINE_OP (247, unused_247
, NULL
, NOP
)
3231 VM_DEFINE_OP (248, unused_248
, NULL
, NOP
)
3232 VM_DEFINE_OP (249, unused_249
, NULL
, NOP
)
3233 VM_DEFINE_OP (250, unused_250
, NULL
, NOP
)
3234 VM_DEFINE_OP (251, unused_251
, NULL
, NOP
)
3235 VM_DEFINE_OP (252, unused_252
, NULL
, NOP
)
3236 VM_DEFINE_OP (253, unused_253
, NULL
, NOP
)
3237 VM_DEFINE_OP (254, unused_254
, NULL
, NOP
)
3238 VM_DEFINE_OP (255, unused_255
, NULL
, NOP
)
3240 vm_error_bad_instruction (op
);
3241 abort (); /* never reached */
3244 END_DISPATCH_SWITCH
;
3248 #undef ABORT_CONTINUATION_HOOK
3253 #undef BEGIN_DISPATCH_SWITCH
3254 #undef BINARY_INTEGER_OP
3255 #undef BR_ARITHMETIC
3259 #undef BV_FIXABLE_INT_REF
3260 #undef BV_FIXABLE_INT_SET
3265 #undef CACHE_REGISTER
3266 #undef END_DISPATCH_SWITCH
3267 #undef FREE_VARIABLE_REF
3276 #undef POP_CONTINUATION_HOOK
3277 #undef PUSH_CONTINUATION_HOOK
3279 #undef RETURN_ONE_VALUE
3280 #undef RETURN_VALUE_LIST
3290 #undef VARIABLE_BOUNDP
3293 #undef VM_CHECK_FREE_VARIABLE
3294 #undef VM_CHECK_OBJECT
3295 #undef VM_CHECK_UNDERFLOW
3297 #undef VM_INSTRUCTION_TO_LABEL
3299 #undef VM_VALIDATE_BYTEVECTOR
3300 #undef VM_VALIDATE_PAIR
3301 #undef VM_VALIDATE_STRUCT
3304 (defun renumber-ops ()
3305 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3308 (let ((counter -1)) (goto-char (point-min))
3309 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3311 (number-to-string (setq counter (1+ counter)))