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));
491 BEGIN_DISPATCH_SWITCH
;
502 * Bring the VM to a halt, returning all the values from the stack.
504 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
506 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
508 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
517 for (n
= nvals
; n
> 0; n
--)
518 ret
= scm_inline_cons (thread
, LOCAL_REF (4 + n
- 1), ret
);
519 ret
= scm_values (ret
);
522 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
523 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
524 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
529 /* call proc:24 _:8 nlocals:24
531 * Call a procedure. PROC is the local corresponding to a procedure.
532 * The two values below PROC will be overwritten by the saved call
533 * frame data. The new frame will have space for NLOCALS locals: one
534 * for the procedure, and the rest for the arguments which should
535 * already have been pushed on.
537 * When the call returns, execution proceeds with the next
538 * instruction. There may be any number of values on the return
539 * stack; the precise number can be had by subtracting the address of
540 * PROC from the post-call SP.
542 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
544 scm_t_uint32 proc
, nlocals
;
547 UNPACK_24 (op
, proc
);
548 UNPACK_24 (ip
[1], nlocals
);
550 VM_HANDLE_INTERRUPTS
;
553 fp
= vp
->fp
= old_fp
+ proc
;
554 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
555 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
557 RESET_FRAME (nlocals
);
559 PUSH_CONTINUATION_HOOK ();
562 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
565 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
569 /* call-label proc:24 _:8 nlocals:24 label:32
571 * Call a procedure in the same compilation unit.
573 * This instruction is just like "call", except that instead of
574 * dereferencing PROC to find the call target, the call target is
575 * known to be at LABEL, a signed 32-bit offset in 32-bit units from
576 * the current IP. Since PROC is not dereferenced, it may be some
577 * other representation of the closure.
579 VM_DEFINE_OP (2, call_label
, "call-label", OP3 (U8_U24
, X8_U24
, L32
))
581 scm_t_uint32 proc
, nlocals
;
585 UNPACK_24 (op
, proc
);
586 UNPACK_24 (ip
[1], nlocals
);
589 VM_HANDLE_INTERRUPTS
;
592 fp
= vp
->fp
= old_fp
+ proc
;
593 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
594 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 3);
596 RESET_FRAME (nlocals
);
598 PUSH_CONTINUATION_HOOK ();
604 /* tail-call nlocals:24
606 * Tail-call a procedure. Requires that the procedure and all of the
607 * arguments have already been shuffled into position. Will reset the
610 VM_DEFINE_OP (3, tail_call
, "tail-call", OP1 (U8_U24
))
612 scm_t_uint32 nlocals
;
614 UNPACK_24 (op
, nlocals
);
616 VM_HANDLE_INTERRUPTS
;
618 RESET_FRAME (nlocals
);
622 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
625 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
629 /* tail-call-label nlocals:24 label:32
631 * Tail-call a known procedure. As call is to call-label, tail-call
632 * is to tail-call-label.
634 VM_DEFINE_OP (4, tail_call_label
, "tail-call-label", OP2 (U8_U24
, L32
))
636 scm_t_uint32 nlocals
;
639 UNPACK_24 (op
, nlocals
);
642 VM_HANDLE_INTERRUPTS
;
644 RESET_FRAME (nlocals
);
651 /* tail-call/shuffle from:24
653 * Tail-call a procedure. The procedure should already be set to slot
654 * 0. The rest of the args are taken from the frame, starting at
655 * FROM, shuffled down to start at slot 0. This is part of the
656 * implementation of the call-with-values builtin.
658 VM_DEFINE_OP (5, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
660 scm_t_uint32 n
, from
, nlocals
;
662 UNPACK_24 (op
, from
);
664 VM_HANDLE_INTERRUPTS
;
666 VM_ASSERT (from
> 0, abort ());
667 nlocals
= FRAME_LOCALS_COUNT ();
669 for (n
= 0; from
+ n
< nlocals
; n
++)
670 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
676 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
679 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
683 /* receive dst:12 proc:12 _:8 nlocals:24
685 * Receive a single return value from a call whose procedure was in
686 * PROC, asserting that the call actually returned at least one
687 * value. Afterwards, resets the frame to NLOCALS locals.
689 VM_DEFINE_OP (6, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
691 scm_t_uint16 dst
, proc
;
692 scm_t_uint32 nlocals
;
693 UNPACK_12_12 (op
, dst
, proc
);
694 UNPACK_24 (ip
[1], nlocals
);
695 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
696 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
697 RESET_FRAME (nlocals
);
701 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
703 * Receive a return of multiple values from a call whose procedure was
704 * in PROC. If fewer than NVALUES values were returned, signal an
705 * error. Unless ALLOW-EXTRA? is true, require that the number of
706 * return values equals NVALUES exactly. After receive-values has
707 * run, the values can be copied down via `mov'.
709 VM_DEFINE_OP (7, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
711 scm_t_uint32 proc
, nvalues
;
712 UNPACK_24 (op
, proc
);
713 UNPACK_24 (ip
[1], nvalues
);
715 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
716 vm_error_not_enough_values ());
718 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
719 vm_error_wrong_number_of_values (nvalues
));
727 VM_DEFINE_OP (8, return, "return", OP1 (U8_U24
))
731 RETURN_ONE_VALUE (LOCAL_REF (src
));
734 /* return-values _:24
736 * Return a number of values from a call frame. This opcode
737 * corresponds to an application of `values' in tail position. As
738 * with tail calls, we expect that the values have already been
739 * shuffled down to a contiguous array starting at slot 1.
740 * We also expect the frame has already been reset.
742 VM_DEFINE_OP (9, return_values
, "return-values", OP1 (U8_X24
))
746 VM_HANDLE_INTERRUPTS
;
749 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
750 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
752 /* Clear stack frame. */
753 old_fp
[-1] = SCM_BOOL_F
;
754 old_fp
[-2] = SCM_BOOL_F
;
756 POP_CONTINUATION_HOOK (old_fp
);
765 * Specialized call stubs
768 /* subr-call ptr-idx:24
770 * Call a subr, passing all locals in this frame as arguments. Fetch
771 * the foreign pointer from PTR-IDX, a free variable. Return from the
772 * calling frame. This instruction is part of the trampolines
773 * created in gsubr.c, and is not generated by the compiler.
775 VM_DEFINE_OP (10, subr_call
, "subr-call", OP1 (U8_U24
))
777 scm_t_uint32 ptr_idx
;
781 UNPACK_24 (op
, ptr_idx
);
783 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
784 subr
= SCM_POINTER_VALUE (pointer
);
788 switch (FRAME_LOCALS_COUNT_FROM (1))
797 ret
= subr (fp
[1], fp
[2]);
800 ret
= subr (fp
[1], fp
[2], fp
[3]);
803 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
806 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
809 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
812 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
815 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
818 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
821 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
829 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
830 /* multiple values returned to continuation */
831 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
833 RETURN_ONE_VALUE (ret
);
836 /* foreign-call cif-idx:12 ptr-idx:12
838 * Call a foreign function. Fetch the CIF and foreign pointer from
839 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
840 * frame. Arguments are taken from the stack. This instruction is
841 * part of the trampolines created by the FFI, and is not generated by
844 VM_DEFINE_OP (11, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
846 scm_t_uint16 cif_idx
, ptr_idx
;
847 SCM closure
, cif
, pointer
, ret
;
849 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
851 closure
= LOCAL_REF (0);
852 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
853 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
857 // FIXME: separate args
858 ret
= scm_i_foreign_call (scm_inline_cons (thread
, cif
, pointer
),
863 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
864 /* multiple values returned to continuation */
865 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
867 RETURN_ONE_VALUE (ret
);
870 /* continuation-call contregs:24
872 * Return to a continuation, nonlocally. The arguments to the
873 * continuation are taken from the stack. CONTREGS is a free variable
874 * containing the reified continuation. This instruction is part of
875 * the implementation of undelimited continuations, and is not
876 * generated by the compiler.
878 VM_DEFINE_OP (12, continuation_call
, "continuation-call", OP1 (U8_U24
))
881 scm_t_uint32 contregs_idx
;
883 UNPACK_24 (op
, contregs_idx
);
886 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
889 scm_i_check_continuation (contregs
);
890 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
891 scm_i_contregs_vm_cont (contregs
),
892 FRAME_LOCALS_COUNT_FROM (1),
894 scm_i_reinstate_continuation (contregs
);
900 /* compose-continuation cont:24
902 * Compose a partial continution with the current continuation. The
903 * arguments to the continuation are taken from the stack. CONT is a
904 * free variable containing the reified continuation. This
905 * instruction is part of the implementation of partial continuations,
906 * and is not generated by the compiler.
908 VM_DEFINE_OP (13, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
911 scm_t_uint32 cont_idx
;
913 UNPACK_24 (op
, cont_idx
);
914 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
917 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
918 vm_error_continuation_not_rewindable (vmcont
));
919 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
929 * Tail-apply the procedure in local slot 0 to the rest of the
930 * arguments. This instruction is part of the implementation of
931 * `apply', and is not generated by the compiler.
933 VM_DEFINE_OP (14, tail_apply
, "tail-apply", OP1 (U8_X24
))
935 int i
, list_idx
, list_len
, nlocals
;
938 VM_HANDLE_INTERRUPTS
;
940 nlocals
= FRAME_LOCALS_COUNT ();
941 // At a minimum, there should be apply, f, and the list.
942 VM_ASSERT (nlocals
>= 3, abort ());
943 list_idx
= nlocals
- 1;
944 list
= LOCAL_REF (list_idx
);
945 list_len
= scm_ilength (list
);
947 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
949 nlocals
= nlocals
- 2 + list_len
;
950 ALLOC_FRAME (nlocals
);
952 for (i
= 1; i
< list_idx
; i
++)
953 LOCAL_SET (i
- 1, LOCAL_REF (i
));
955 /* Null out these slots, just in case there are less than 2 elements
957 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
958 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
960 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
961 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
965 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
968 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
974 * Capture the current continuation, and tail-apply the procedure in
975 * local slot 1 to it. This instruction is part of the implementation
976 * of `call/cc', and is not generated by the compiler.
978 VM_DEFINE_OP (15, call_cc
, "call/cc", OP1 (U8_X24
))
981 scm_t_dynstack
*dynstack
;
984 VM_HANDLE_INTERRUPTS
;
987 dynstack
= scm_dynstack_capture_all (&thread
->dynstack
);
988 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
989 SCM_FRAME_DYNAMIC_LINK (fp
),
990 SCM_FRAME_PREVIOUS_SP (fp
),
991 SCM_FRAME_RETURN_ADDRESS (fp
),
994 /* FIXME: Seems silly to capture the registers here, when they are
995 already captured in the registers local, which here we are
996 copying out to the heap; and likewise, the setjmp(®isters)
997 code already has the non-local return handler. But oh
999 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
1003 LOCAL_SET (0, LOCAL_REF (1));
1004 LOCAL_SET (1, cont
);
1009 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
1012 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
1018 ABORT_CONTINUATION_HOOK ();
1025 * Abort to a prompt handler. The tag is expected in r1, and the rest
1026 * of the values in the frame are returned to the prompt handler.
1027 * This corresponds to a tail application of abort-to-prompt.
1029 VM_DEFINE_OP (16, abort
, "abort", OP1 (U8_X24
))
1031 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1033 ASSERT (nlocals
>= 2);
1034 /* FIXME: Really we should capture the caller's registers. Until
1035 then, manually advance the IP so that when the prompt resumes,
1036 it continues with the next instruction. */
1039 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1040 SCM_EOL
, LOCAL_ADDRESS (0), registers
);
1042 /* vm_abort should not return */
1046 /* builtin-ref dst:12 idx:12
1048 * Load a builtin stub by index into DST.
1050 VM_DEFINE_OP (17, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1052 scm_t_uint16 dst
, idx
;
1054 UNPACK_12_12 (op
, dst
, idx
);
1055 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1064 * Function prologues
1067 /* br-if-nargs-ne expected:24 _:8 offset:24
1068 * br-if-nargs-lt expected:24 _:8 offset:24
1069 * br-if-nargs-gt expected:24 _:8 offset:24
1071 * If the number of actual arguments is not equal, less than, or greater
1072 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1073 * the current instruction pointer.
1075 VM_DEFINE_OP (18, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1079 VM_DEFINE_OP (19, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1083 VM_DEFINE_OP (20, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1088 /* assert-nargs-ee expected:24
1089 * assert-nargs-ge expected:24
1090 * assert-nargs-le expected:24
1092 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1093 * respectively, signal an error.
1095 VM_DEFINE_OP (21, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1097 scm_t_uint32 expected
;
1098 UNPACK_24 (op
, expected
);
1099 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1100 vm_error_wrong_num_args (LOCAL_REF (0)));
1103 VM_DEFINE_OP (22, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1105 scm_t_uint32 expected
;
1106 UNPACK_24 (op
, expected
);
1107 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1108 vm_error_wrong_num_args (LOCAL_REF (0)));
1111 VM_DEFINE_OP (23, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1113 scm_t_uint32 expected
;
1114 UNPACK_24 (op
, expected
);
1115 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1116 vm_error_wrong_num_args (LOCAL_REF (0)));
1120 /* alloc-frame nlocals:24
1122 * Ensure that there is space on the stack for NLOCALS local variables,
1123 * setting them all to SCM_UNDEFINED, except those nargs values that
1124 * were passed as arguments and procedure.
1126 VM_DEFINE_OP (24, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1128 scm_t_uint32 nlocals
, nargs
;
1129 UNPACK_24 (op
, nlocals
);
1131 nargs
= FRAME_LOCALS_COUNT ();
1132 ALLOC_FRAME (nlocals
);
1133 while (nlocals
-- > nargs
)
1134 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1139 /* reset-frame nlocals:24
1141 * Like alloc-frame, but doesn't check that the stack is big enough.
1142 * Used to reset the frame size to something less than the size that
1143 * was previously set via alloc-frame.
1145 VM_DEFINE_OP (25, reset_frame
, "reset-frame", OP1 (U8_U24
))
1147 scm_t_uint32 nlocals
;
1148 UNPACK_24 (op
, nlocals
);
1149 RESET_FRAME (nlocals
);
1153 /* assert-nargs-ee/locals expected:12 nlocals:12
1155 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1156 * number of locals reserved is EXPECTED + NLOCALS.
1158 VM_DEFINE_OP (26, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1160 scm_t_uint16 expected
, nlocals
;
1161 UNPACK_12_12 (op
, expected
, nlocals
);
1162 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1163 vm_error_wrong_num_args (LOCAL_REF (0)));
1164 ALLOC_FRAME (expected
+ nlocals
);
1166 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1171 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1173 * Find the first positional argument after NREQ. If it is greater
1174 * than NPOS, jump to OFFSET.
1176 * This instruction is only emitted for functions with multiple
1177 * clauses, and an earlier clause has keywords and no rest arguments.
1178 * See "Case-lambda" in the manual, for more on how case-lambda
1179 * chooses the clause to apply.
1181 VM_DEFINE_OP (27, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1183 scm_t_uint32 nreq
, npos
;
1185 UNPACK_24 (op
, nreq
);
1186 UNPACK_24 (ip
[1], npos
);
1188 /* We can only have too many positionals if there are more
1189 arguments than NPOS. */
1190 if (FRAME_LOCALS_COUNT() > npos
)
1193 for (n
= nreq
; n
< npos
; n
++)
1194 if (scm_is_keyword (LOCAL_REF (n
)))
1196 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1198 scm_t_int32 offset
= ip
[2];
1199 offset
>>= 8; /* Sign-extending shift. */
1206 /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
1208 * flags := allow-other-keys:1 has-rest:1 _:6
1210 * Find the last positional argument, and shuffle all the rest above
1211 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1212 * load the constant at KW-OFFSET words from the current IP, and use it
1213 * to bind keyword arguments. If HAS-REST, collect all shuffled
1214 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1215 * the arguments that we shuffled up.
1217 * A macro-mega-instruction.
1219 VM_DEFINE_OP (28, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1221 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1222 scm_t_int32 kw_offset
;
1225 char allow_other_keys
, has_rest
;
1227 UNPACK_24 (op
, nreq
);
1228 allow_other_keys
= ip
[1] & 0x1;
1229 has_rest
= ip
[1] & 0x2;
1230 UNPACK_24 (ip
[1], nreq_and_opt
);
1231 UNPACK_24 (ip
[2], ntotal
);
1233 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1234 VM_ASSERT (!(kw_bits
& 0x7), abort());
1235 kw
= SCM_PACK (kw_bits
);
1237 nargs
= FRAME_LOCALS_COUNT ();
1239 /* look in optionals for first keyword or last positional */
1240 /* starting after the last required positional arg */
1242 while (/* while we have args */
1244 /* and we still have positionals to fill */
1245 && npositional
< nreq_and_opt
1246 /* and we haven't reached a keyword yet */
1247 && !scm_is_keyword (LOCAL_REF (npositional
)))
1248 /* bind this optional arg (by leaving it in place) */
1250 nkw
= nargs
- npositional
;
1251 /* shuffle non-positional arguments above ntotal */
1252 ALLOC_FRAME (ntotal
+ nkw
);
1255 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1256 /* and fill optionals & keyword args with SCM_UNDEFINED */
1259 LOCAL_SET (n
++, SCM_UNDEFINED
);
1261 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1262 vm_error_kwargs_length_not_even (LOCAL_REF (0)));
1264 /* Now bind keywords, in the order given. */
1265 for (n
= 0; n
< nkw
; n
++)
1266 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1269 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1270 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1272 SCM si
= SCM_CDAR (walk
);
1273 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1274 LOCAL_REF (ntotal
+ n
+ 1));
1277 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1278 vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0),
1279 LOCAL_REF (ntotal
+ n
)));
1283 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (LOCAL_REF (0),
1284 LOCAL_REF (ntotal
+ n
)));
1291 rest
= scm_inline_cons (thread
, LOCAL_REF (ntotal
+ n
), rest
);
1292 LOCAL_SET (nreq_and_opt
, rest
);
1295 RESET_FRAME (ntotal
);
1302 * Collect any arguments at or above DST into a list, and store that
1305 VM_DEFINE_OP (29, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1307 scm_t_uint32 dst
, nargs
;
1310 UNPACK_24 (op
, dst
);
1311 nargs
= FRAME_LOCALS_COUNT ();
1315 ALLOC_FRAME (dst
+ 1);
1317 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1321 while (nargs
-- > dst
)
1323 rest
= scm_inline_cons (thread
, LOCAL_REF (nargs
), rest
);
1324 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1327 RESET_FRAME (dst
+ 1);
1330 LOCAL_SET (dst
, rest
);
1339 * Branching instructions
1344 * Add OFFSET, a signed 24-bit number, to the current instruction
1347 VM_DEFINE_OP (30, br
, "br", OP1 (U8_L24
))
1349 scm_t_int32 offset
= op
;
1350 offset
>>= 8; /* Sign-extending shift. */
1352 VM_HANDLE_INTERRUPTS
;
1356 /* br-if-true test:24 invert:1 _:7 offset:24
1358 * If the value in TEST is true for the purposes of Scheme, add
1359 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1361 VM_DEFINE_OP (31, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1363 BR_UNARY (x
, scm_is_true (x
));
1366 /* br-if-null test:24 invert:1 _:7 offset:24
1368 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1369 * signed 24-bit number, to the current instruction pointer.
1371 VM_DEFINE_OP (32, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1373 BR_UNARY (x
, scm_is_null (x
));
1376 /* br-if-nil test:24 invert:1 _:7 offset:24
1378 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1379 * number, to the current instruction pointer.
1381 VM_DEFINE_OP (33, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1383 BR_UNARY (x
, scm_is_lisp_false (x
));
1386 /* br-if-pair test:24 invert:1 _:7 offset:24
1388 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1389 * to the current instruction pointer.
1391 VM_DEFINE_OP (34, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1393 BR_UNARY (x
, scm_is_pair (x
));
1396 /* br-if-struct test:24 invert:1 _:7 offset:24
1398 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1399 * number, to the current instruction pointer.
1401 VM_DEFINE_OP (35, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1403 BR_UNARY (x
, SCM_STRUCTP (x
));
1406 /* br-if-char test:24 invert:1 _:7 offset:24
1408 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1409 * to the current instruction pointer.
1411 VM_DEFINE_OP (36, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1413 BR_UNARY (x
, SCM_CHARP (x
));
1416 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1418 * If the value in TEST has the TC7 given in the second word, add
1419 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1421 VM_DEFINE_OP (37, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1423 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1426 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1428 * If the value in A is eq? to the value in B, add OFFSET, a signed
1429 * 24-bit number, to the current instruction pointer.
1431 VM_DEFINE_OP (38, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1433 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1436 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1438 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1439 * 24-bit number, to the current instruction pointer.
1441 VM_DEFINE_OP (39, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1445 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1446 && scm_is_true (scm_eqv_p (x
, y
))));
1449 // FIXME: remove, have compiler inline eqv test instead
1450 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1452 * If the value in A is equal? to the value in B, add OFFSET, a signed
1453 * 24-bit number, to the current instruction pointer.
1455 // FIXME: Should sync_ip before calling out and cache_fp before coming
1456 // back! Another reason to remove this opcode!
1457 VM_DEFINE_OP (40, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1461 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1462 && scm_is_true (scm_equal_p (x
, y
))));
1465 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1467 * If the value in A is = to the value in B, add OFFSET, a signed
1468 * 24-bit number, to the current instruction pointer.
1470 VM_DEFINE_OP (41, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1472 BR_ARITHMETIC (==, scm_num_eq_p
);
1475 /* br-if-< a:12 b:12 invert:1 _:7 offset:24
1477 * If the value in A is < to the value in B, add OFFSET, a signed
1478 * 24-bit number, to the current instruction pointer.
1480 VM_DEFINE_OP (42, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1482 BR_ARITHMETIC (<, scm_less_p
);
1485 /* br-if-<= a:12 b:12 invert:1 _:7 offset:24
1487 * If the value in A is <= to the value in B, add OFFSET, a signed
1488 * 24-bit number, to the current instruction pointer.
1490 VM_DEFINE_OP (43, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1492 BR_ARITHMETIC (<=, scm_leq_p
);
1499 * Lexical binding instructions
1502 /* mov dst:12 src:12
1504 * Copy a value from one local slot to another.
1506 VM_DEFINE_OP (44, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1511 UNPACK_12_12 (op
, dst
, src
);
1512 LOCAL_SET (dst
, LOCAL_REF (src
));
1517 /* long-mov dst:24 _:8 src:24
1519 * Copy a value from one local slot to another.
1521 VM_DEFINE_OP (45, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1526 UNPACK_24 (op
, dst
);
1527 UNPACK_24 (ip
[1], src
);
1528 LOCAL_SET (dst
, LOCAL_REF (src
));
1533 /* box dst:12 src:12
1535 * Create a new variable holding SRC, and place it in DST.
1537 VM_DEFINE_OP (46, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1539 scm_t_uint16 dst
, src
;
1540 UNPACK_12_12 (op
, dst
, src
);
1541 LOCAL_SET (dst
, scm_inline_cell (thread
, scm_tc7_variable
,
1542 SCM_UNPACK (LOCAL_REF (src
))));
1546 /* box-ref dst:12 src:12
1548 * Unpack the variable at SRC into DST, asserting that the variable is
1551 VM_DEFINE_OP (47, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1553 scm_t_uint16 dst
, src
;
1555 UNPACK_12_12 (op
, dst
, src
);
1556 var
= LOCAL_REF (src
);
1557 VM_ASSERT (SCM_VARIABLEP (var
),
1558 vm_error_not_a_variable ("variable-ref", var
));
1559 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (var
));
1560 LOCAL_SET (dst
, VARIABLE_REF (var
));
1564 /* box-set! dst:12 src:12
1566 * Set the contents of the variable at DST to SET.
1568 VM_DEFINE_OP (48, box_set
, "box-set!", OP1 (U8_U12_U12
))
1570 scm_t_uint16 dst
, src
;
1572 UNPACK_12_12 (op
, dst
, src
);
1573 var
= LOCAL_REF (dst
);
1574 VM_ASSERT (SCM_VARIABLEP (var
),
1575 vm_error_not_a_variable ("variable-set!", var
));
1576 VARIABLE_SET (var
, LOCAL_REF (src
));
1580 /* make-closure dst:24 offset:32 _:8 nfree:24
1582 * Make a new closure, and write it to DST. The code for the closure
1583 * will be found at OFFSET words from the current IP. OFFSET is a
1584 * signed 32-bit integer. Space for NFREE free variables will be
1587 VM_DEFINE_OP (49, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1589 scm_t_uint32 dst
, nfree
, n
;
1593 UNPACK_24 (op
, dst
);
1595 UNPACK_24 (ip
[2], nfree
);
1597 // FIXME: Assert range of nfree?
1598 closure
= scm_inline_words (thread
, scm_tc7_program
| (nfree
<< 16),
1600 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1601 // FIXME: Elide these initializations?
1602 for (n
= 0; n
< nfree
; n
++)
1603 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1604 LOCAL_SET (dst
, closure
);
1608 /* free-ref dst:12 src:12 _:8 idx:24
1610 * Load free variable IDX from the closure SRC into local slot DST.
1612 VM_DEFINE_OP (50, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1614 scm_t_uint16 dst
, src
;
1616 UNPACK_12_12 (op
, dst
, src
);
1617 UNPACK_24 (ip
[1], idx
);
1618 /* CHECK_FREE_VARIABLE (src); */
1619 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1623 /* free-set! dst:12 src:12 _:8 idx:24
1625 * Set free variable IDX from the closure DST to SRC.
1627 VM_DEFINE_OP (51, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1629 scm_t_uint16 dst
, src
;
1631 UNPACK_12_12 (op
, dst
, src
);
1632 UNPACK_24 (ip
[1], idx
);
1633 /* CHECK_FREE_VARIABLE (src); */
1634 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1642 * Immediates and statically allocated non-immediates
1645 /* make-short-immediate dst:8 low-bits:16
1647 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1650 VM_DEFINE_OP (52, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1655 UNPACK_8_16 (op
, dst
, val
);
1656 LOCAL_SET (dst
, SCM_PACK (val
));
1660 /* make-long-immediate dst:24 low-bits:32
1662 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1665 VM_DEFINE_OP (53, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
) | OP_DST
)
1670 UNPACK_24 (op
, dst
);
1672 LOCAL_SET (dst
, SCM_PACK (val
));
1676 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1678 * Make an immediate with HIGH-BITS and LOW-BITS.
1680 VM_DEFINE_OP (54, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1685 UNPACK_24 (op
, dst
);
1686 #if SIZEOF_SCM_T_BITS > 4
1691 ASSERT (ip
[1] == 0);
1694 LOCAL_SET (dst
, SCM_PACK (val
));
1698 /* make-non-immediate dst:24 offset:32
1700 * Load a pointer to statically allocated memory into DST. The
1701 * object's memory is will be found OFFSET 32-bit words away from the
1702 * current instruction pointer. OFFSET is a signed value. The
1703 * intention here is that the compiler would produce an object file
1704 * containing the words of a non-immediate object, and this
1705 * instruction creates a pointer to that memory, effectively
1706 * resurrecting that object.
1708 * Whether the object is mutable or immutable depends on where it was
1709 * allocated by the compiler, and loaded by the loader.
1711 VM_DEFINE_OP (55, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1716 scm_t_bits unpacked
;
1718 UNPACK_24 (op
, dst
);
1721 unpacked
= (scm_t_bits
) loc
;
1723 VM_ASSERT (!(unpacked
& 0x7), abort());
1725 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1730 /* static-ref dst:24 offset:32
1732 * Load a SCM value into DST. The SCM value will be fetched from
1733 * memory, OFFSET 32-bit words away from the current instruction
1734 * pointer. OFFSET is a signed value.
1736 * The intention is for this instruction to be used to load constants
1737 * that the compiler is unable to statically allocate, like symbols.
1738 * These values would be initialized when the object file loads.
1740 VM_DEFINE_OP (56, static_ref
, "static-ref", OP2 (U8_U24
, S32
) | OP_DST
)
1745 scm_t_uintptr loc_bits
;
1747 UNPACK_24 (op
, dst
);
1750 loc_bits
= (scm_t_uintptr
) loc
;
1751 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1753 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1758 /* static-set! src:24 offset:32
1760 * Store a SCM value into memory, OFFSET 32-bit words away from the
1761 * current instruction pointer. OFFSET is a signed value.
1763 VM_DEFINE_OP (57, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1769 UNPACK_24 (op
, src
);
1772 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1774 *((SCM
*) loc
) = LOCAL_REF (src
);
1779 /* static-patch! _:24 dst-offset:32 src-offset:32
1781 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1782 * are signed 32-bit values, indicating a memory address as a number
1783 * of 32-bit words away from the current instruction pointer.
1785 VM_DEFINE_OP (58, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1787 scm_t_int32 dst_offset
, src_offset
;
1794 dst_loc
= (void **) (ip
+ dst_offset
);
1795 src
= ip
+ src_offset
;
1796 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1806 * Mutable top-level bindings
1809 /* There are three slightly different ways to resolve toplevel
1812 1. A toplevel reference outside of a function. These need to be
1813 looked up when the expression is evaluated -- no later, and no
1814 before. They are looked up relative to the module that is
1815 current when the expression is evaluated. For example:
1819 The "resolve" instruction resolves the variable (box), and then
1820 access is via box-ref or box-set!.
1822 2. A toplevel reference inside a function. These are looked up
1823 relative to the module that was current when the function was
1824 defined. Unlike code at the toplevel, which is usually run only
1825 once, these bindings benefit from memoized lookup, in which the
1826 variable resulting from the lookup is cached in the function.
1828 (lambda () (if (foo) a b))
1830 The toplevel-box instruction is equivalent to "resolve", but
1831 caches the resulting variable in statically allocated memory.
1833 3. A reference to an identifier with respect to a particular
1834 module. This can happen for primitive references, and
1835 references residualized by macro expansions. These can always
1836 be cached. Use module-box for these.
1839 /* current-module dst:24
1841 * Store the current module in DST.
1843 VM_DEFINE_OP (59, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1847 UNPACK_24 (op
, dst
);
1850 LOCAL_SET (dst
, scm_current_module ());
1855 /* resolve dst:24 bound?:1 _:7 sym:24
1857 * Resolve SYM in the current module, and place the resulting variable
1860 VM_DEFINE_OP (60, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1866 UNPACK_24 (op
, dst
);
1867 UNPACK_24 (ip
[1], sym
);
1870 var
= scm_lookup (LOCAL_REF (sym
));
1873 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (LOCAL_REF (sym
)));
1874 LOCAL_SET (dst
, var
);
1879 /* define! sym:12 val:12
1881 * Look up a binding for SYM in the current module, creating it if
1882 * necessary. Set its value to VAL.
1884 VM_DEFINE_OP (61, define
, "define!", OP1 (U8_U12_U12
))
1886 scm_t_uint16 sym
, val
;
1887 UNPACK_12_12 (op
, sym
, val
);
1889 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1894 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1896 * Load a SCM value. The SCM value will be fetched from memory,
1897 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1898 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1901 * Then, if the loaded value is a variable, it is placed in DST, and control
1904 * Otherwise, we have to resolve the variable. In that case we load
1905 * the module from MOD-OFFSET, just as we loaded the variable.
1906 * Usually the module gets set when the closure is created. The name
1907 * is an offset to a symbol.
1909 * We use the module and the symbol to resolve the variable, placing it in
1910 * DST, and caching the resolved variable so that we will hit the cache next
1913 VM_DEFINE_OP (62, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1916 scm_t_int32 var_offset
;
1917 scm_t_uint32
* var_loc_u32
;
1921 UNPACK_24 (op
, dst
);
1923 var_loc_u32
= ip
+ var_offset
;
1924 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1925 var_loc
= (SCM
*) var_loc_u32
;
1928 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1931 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1932 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1933 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1934 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1938 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1939 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1941 mod
= *((SCM
*) mod_loc
);
1942 sym
= *((SCM
*) sym_loc
);
1944 /* If the toplevel scope was captured before modules were
1945 booted, use the root module. */
1946 if (scm_is_false (mod
))
1947 mod
= scm_the_root_module ();
1949 var
= scm_module_lookup (mod
, sym
);
1952 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
1957 LOCAL_SET (dst
, var
);
1961 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1963 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1964 * instead of the module itself.
1966 VM_DEFINE_OP (63, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1969 scm_t_int32 var_offset
;
1970 scm_t_uint32
* var_loc_u32
;
1974 UNPACK_24 (op
, dst
);
1976 var_loc_u32
= ip
+ var_offset
;
1977 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1978 var_loc
= (SCM
*) var_loc_u32
;
1981 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1984 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1985 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1986 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
1987 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1991 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
1992 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1994 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
1995 sym
= *((SCM
*) sym_loc
);
1997 if (!scm_module_system_booted_p
)
2000 scm_equal_p (modname
,
2003 scm_from_utf8_symbol ("guile"))));
2004 var
= scm_lookup (sym
);
2006 else if (scm_is_true (SCM_CAR (modname
)))
2007 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2009 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2014 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
2019 LOCAL_SET (dst
, var
);
2026 * The dynamic environment
2029 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2031 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2032 * handler at HANDLER-OFFSET words from the current IP. The handler
2033 * will expect a multiple-value return as if from a call with the
2034 * procedure at PROC-SLOT.
2036 VM_DEFINE_OP (64, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2038 scm_t_uint32 tag
, proc_slot
;
2040 scm_t_uint8 escape_only_p
;
2041 scm_t_dynstack_prompt_flags flags
;
2043 UNPACK_24 (op
, tag
);
2044 escape_only_p
= ip
[1] & 0x1;
2045 UNPACK_24 (ip
[1], proc_slot
);
2047 offset
>>= 8; /* Sign extension */
2049 /* Push the prompt onto the dynamic stack. */
2050 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2051 scm_dynstack_push_prompt (&thread
->dynstack
, flags
,
2053 fp
- vp
->stack_base
,
2054 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2060 /* wind winder:12 unwinder:12
2062 * Push wind and unwind procedures onto the dynamic stack. Note that
2063 * neither are actually called; the compiler should emit calls to wind
2064 * and unwind for the normal dynamic-wind control flow. Also note that
2065 * the compiler should have inserted checks that they wind and unwind
2066 * procs are thunks, if it could not prove that to be the case.
2068 VM_DEFINE_OP (65, wind
, "wind", OP1 (U8_U12_U12
))
2070 scm_t_uint16 winder
, unwinder
;
2071 UNPACK_12_12 (op
, winder
, unwinder
);
2072 scm_dynstack_push_dynwind (&thread
->dynstack
,
2073 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2079 * A normal exit from the dynamic extent of an expression. Pop the top
2080 * entry off of the dynamic stack.
2082 VM_DEFINE_OP (66, unwind
, "unwind", OP1 (U8_X24
))
2084 scm_dynstack_pop (&thread
->dynstack
);
2088 /* push-fluid fluid:12 value:12
2090 * Dynamically bind VALUE to FLUID.
2092 VM_DEFINE_OP (67, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2094 scm_t_uint32 fluid
, value
;
2096 UNPACK_12_12 (op
, fluid
, value
);
2098 scm_dynstack_push_fluid (&thread
->dynstack
,
2099 LOCAL_REF (fluid
), LOCAL_REF (value
),
2100 thread
->dynamic_state
);
2106 * Leave the dynamic extent of a with-fluid* expression, restoring the
2107 * fluid to its previous value.
2109 VM_DEFINE_OP (68, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2111 /* This function must not allocate. */
2112 scm_dynstack_unwind_fluid (&thread
->dynstack
,
2113 thread
->dynamic_state
);
2117 /* fluid-ref dst:12 src:12
2119 * Reference the fluid in SRC, and place the value in DST.
2121 VM_DEFINE_OP (69, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2123 scm_t_uint16 dst
, src
;
2127 UNPACK_12_12 (op
, dst
, src
);
2128 fluid
= LOCAL_REF (src
);
2129 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2130 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2131 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2133 /* Punt dynstate expansion and error handling to the C proc. */
2135 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2139 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2140 if (scm_is_eq (val
, SCM_UNDEFINED
))
2141 val
= SCM_I_FLUID_DEFAULT (fluid
);
2142 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2143 vm_error_unbound_fluid (fluid
));
2144 LOCAL_SET (dst
, val
);
2150 /* fluid-set fluid:12 val:12
2152 * Set the value of the fluid in DST to the value in SRC.
2154 VM_DEFINE_OP (70, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2160 UNPACK_12_12 (op
, a
, b
);
2161 fluid
= LOCAL_REF (a
);
2162 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2163 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2164 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2166 /* Punt dynstate expansion and error handling to the C proc. */
2168 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2171 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2180 * Strings, symbols, and keywords
2183 /* string-length dst:12 src:12
2185 * Store the length of the string in SRC in DST.
2187 VM_DEFINE_OP (71, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2190 if (SCM_LIKELY (scm_is_string (str
)))
2191 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2195 RETURN (scm_string_length (str
));
2199 /* string-ref dst:8 src:8 idx:8
2201 * Fetch the character at position IDX in the string in SRC, and store
2204 VM_DEFINE_OP (72, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2206 scm_t_signed_bits i
= 0;
2208 if (SCM_LIKELY (scm_is_string (str
)
2209 && SCM_I_INUMP (idx
)
2210 && ((i
= SCM_I_INUM (idx
)) >= 0)
2211 && i
< scm_i_string_length (str
)))
2212 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2216 RETURN (scm_string_ref (str
, idx
));
2220 /* No string-set! instruction, as there is no good fast path there. */
2222 /* string->number dst:12 src:12
2224 * Parse a string in SRC to a number, and store in DST.
2226 VM_DEFINE_OP (73, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2228 scm_t_uint16 dst
, src
;
2230 UNPACK_12_12 (op
, dst
, src
);
2233 scm_string_to_number (LOCAL_REF (src
),
2234 SCM_UNDEFINED
/* radix = 10 */));
2238 /* string->symbol dst:12 src:12
2240 * Parse a string in SRC to a symbol, and store in DST.
2242 VM_DEFINE_OP (74, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2244 scm_t_uint16 dst
, src
;
2246 UNPACK_12_12 (op
, dst
, src
);
2248 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2252 /* symbol->keyword dst:12 src:12
2254 * Make a keyword from the symbol in SRC, and store it in DST.
2256 VM_DEFINE_OP (75, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2258 scm_t_uint16 dst
, src
;
2259 UNPACK_12_12 (op
, dst
, src
);
2261 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2271 /* cons dst:8 car:8 cdr:8
2273 * Cons CAR and CDR, and store the result in DST.
2275 VM_DEFINE_OP (76, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2278 RETURN (scm_inline_cons (thread
, x
, y
));
2281 /* car dst:12 src:12
2283 * Place the car of SRC in DST.
2285 VM_DEFINE_OP (77, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2288 VM_VALIDATE_PAIR (x
, "car");
2289 RETURN (SCM_CAR (x
));
2292 /* cdr dst:12 src:12
2294 * Place the cdr of SRC in DST.
2296 VM_DEFINE_OP (78, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2299 VM_VALIDATE_PAIR (x
, "cdr");
2300 RETURN (SCM_CDR (x
));
2303 /* set-car! pair:12 car:12
2305 * Set the car of DST to SRC.
2307 VM_DEFINE_OP (79, set_car
, "set-car!", OP1 (U8_U12_U12
))
2311 UNPACK_12_12 (op
, a
, b
);
2314 VM_VALIDATE_PAIR (x
, "set-car!");
2319 /* set-cdr! pair:12 cdr:12
2321 * Set the cdr of DST to SRC.
2323 VM_DEFINE_OP (80, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2327 UNPACK_12_12 (op
, a
, b
);
2330 VM_VALIDATE_PAIR (x
, "set-car!");
2339 * Numeric operations
2342 /* add dst:8 a:8 b:8
2344 * Add A to B, and place the result in DST.
2346 VM_DEFINE_OP (81, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2348 BINARY_INTEGER_OP (+, scm_sum
);
2351 /* add1 dst:12 src:12
2353 * Add 1 to the value in SRC, and place the result in DST.
2355 VM_DEFINE_OP (82, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2359 /* Check for overflow. We must avoid overflow in the signed
2360 addition below, even if X is not an inum. */
2361 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2365 /* Add 1 to the integer without untagging. */
2366 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2368 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2372 RETURN_EXP (scm_sum (x
, SCM_I_MAKINUM (1)));
2375 /* sub dst:8 a:8 b:8
2377 * Subtract B from A, and place the result in DST.
2379 VM_DEFINE_OP (83, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2381 BINARY_INTEGER_OP (-, scm_difference
);
2384 /* sub1 dst:12 src:12
2386 * Subtract 1 from SRC, and place the result in DST.
2388 VM_DEFINE_OP (84, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2392 /* Check for overflow. We must avoid overflow in the signed
2393 subtraction below, even if X is not an inum. */
2394 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2398 /* Substract 1 from the integer without untagging. */
2399 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2401 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2405 RETURN_EXP (scm_difference (x
, SCM_I_MAKINUM (1)));
2408 /* mul dst:8 a:8 b:8
2410 * Multiply A and B, and place the result in DST.
2412 VM_DEFINE_OP (85, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2415 RETURN_EXP (scm_product (x
, y
));
2418 /* div dst:8 a:8 b:8
2420 * Divide A by B, and place the result in DST.
2422 VM_DEFINE_OP (86, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2425 RETURN_EXP (scm_divide (x
, y
));
2428 /* quo dst:8 a:8 b:8
2430 * Divide A by B, and place the quotient in DST.
2432 VM_DEFINE_OP (87, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2435 RETURN_EXP (scm_quotient (x
, y
));
2438 /* rem dst:8 a:8 b:8
2440 * Divide A by B, and place the remainder in DST.
2442 VM_DEFINE_OP (88, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2445 RETURN_EXP (scm_remainder (x
, y
));
2448 /* mod dst:8 a:8 b:8
2450 * Place the modulo of A by B in DST.
2452 VM_DEFINE_OP (89, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2455 RETURN_EXP (scm_modulo (x
, y
));
2458 /* ash dst:8 a:8 b:8
2460 * Shift A arithmetically by B bits, and place the result in DST.
2462 VM_DEFINE_OP (90, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2465 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2467 if (SCM_I_INUM (y
) < 0)
2468 /* Right shift, will be a fixnum. */
2469 RETURN (SCM_I_MAKINUM
2470 (SCM_SRS (SCM_I_INUM (x
),
2471 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2472 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2474 /* Left shift. See comments in scm_ash. */
2476 scm_t_signed_bits nn
, bits_to_shift
;
2478 nn
= SCM_I_INUM (x
);
2479 bits_to_shift
= SCM_I_INUM (y
);
2481 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2483 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2485 RETURN (SCM_I_MAKINUM (nn
< 0
2486 ? -(-nn
<< bits_to_shift
)
2487 : (nn
<< bits_to_shift
)));
2492 RETURN_EXP (scm_ash (x
, y
));
2495 /* logand dst:8 a:8 b:8
2497 * Place the bitwise AND of A and B into DST.
2499 VM_DEFINE_OP (91, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2502 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2503 /* Compute bitwise AND without untagging */
2504 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2505 RETURN_EXP (scm_logand (x
, y
));
2508 /* logior dst:8 a:8 b:8
2510 * Place the bitwise inclusive OR of A with B in DST.
2512 VM_DEFINE_OP (92, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2515 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2516 /* Compute bitwise OR without untagging */
2517 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2518 RETURN_EXP (scm_logior (x
, y
));
2521 /* logxor dst:8 a:8 b:8
2523 * Place the bitwise exclusive OR of A with B in DST.
2525 VM_DEFINE_OP (93, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2528 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2529 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2530 RETURN_EXP (scm_logxor (x
, y
));
2533 /* make-vector dst:8 length:8 init:8
2535 * Make a vector and write it to DST. The vector will have space for
2536 * LENGTH slots. They will be filled with the value in slot INIT.
2538 VM_DEFINE_OP (94, make_vector
, "make-vector", OP1 (U8_U8_U8_U8
) | OP_DST
)
2540 scm_t_uint8 dst
, init
, length
;
2542 UNPACK_8_8_8 (op
, dst
, length
, init
);
2544 LOCAL_SET (dst
, scm_make_vector (LOCAL_REF (length
), LOCAL_REF (init
)));
2549 /* make-vector/immediate dst:8 length:8 init:8
2551 * Make a short vector of known size and write it to DST. The vector
2552 * will have space for LENGTH slots, an immediate value. They will be
2553 * filled with the value in slot INIT.
2555 VM_DEFINE_OP (95, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2557 scm_t_uint8 dst
, init
;
2558 scm_t_int32 length
, n
;
2561 UNPACK_8_8_8 (op
, dst
, length
, init
);
2563 val
= LOCAL_REF (init
);
2564 vector
= scm_inline_words (thread
, scm_tc7_vector
| (length
<< 8),
2566 for (n
= 0; n
< length
; n
++)
2567 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2568 LOCAL_SET (dst
, vector
);
2572 /* vector-length dst:12 src:12
2574 * Store the length of the vector in SRC in DST.
2576 VM_DEFINE_OP (96, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2579 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2580 vm_error_not_a_vector ("vector-ref", vect
));
2581 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2584 /* vector-ref dst:8 src:8 idx:8
2586 * Fetch the item at position IDX in the vector in SRC, and store it
2589 VM_DEFINE_OP (97, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2591 scm_t_signed_bits i
= 0;
2593 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2594 vm_error_not_a_vector ("vector-ref", vect
));
2595 VM_ASSERT ((SCM_I_INUMP (idx
)
2596 && ((i
= SCM_I_INUM (idx
)) >= 0)
2597 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2598 vm_error_out_of_range ("vector-ref", idx
));
2599 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2602 /* vector-ref/immediate dst:8 src:8 idx:8
2604 * Fill DST with the item IDX elements into the vector at SRC. Useful
2605 * for building data types using vectors.
2607 VM_DEFINE_OP (98, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2609 scm_t_uint8 dst
, src
, idx
;
2612 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2613 v
= LOCAL_REF (src
);
2614 VM_ASSERT (SCM_I_IS_VECTOR (v
),
2615 vm_error_not_a_vector ("vector-ref", v
));
2616 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (v
),
2617 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2618 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2622 /* vector-set! dst:8 idx:8 src:8
2624 * Store SRC into the vector DST at index IDX.
2626 VM_DEFINE_OP (99, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2628 scm_t_uint8 dst
, idx_var
, src
;
2630 scm_t_signed_bits i
= 0;
2632 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2633 vect
= LOCAL_REF (dst
);
2634 idx
= LOCAL_REF (idx_var
);
2635 val
= LOCAL_REF (src
);
2637 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2638 vm_error_not_a_vector ("vector-ref", vect
));
2639 VM_ASSERT ((SCM_I_INUMP (idx
)
2640 && ((i
= SCM_I_INUM (idx
)) >= 0)
2641 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2642 vm_error_out_of_range ("vector-ref", idx
));
2643 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2647 /* vector-set!/immediate dst:8 idx:8 src:8
2649 * Store SRC into the vector DST at index IDX. Here IDX is an
2652 VM_DEFINE_OP (100, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2654 scm_t_uint8 dst
, idx
, src
;
2657 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2658 vect
= LOCAL_REF (dst
);
2659 val
= LOCAL_REF (src
);
2661 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2662 vm_error_not_a_vector ("vector-ref", vect
));
2663 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (vect
),
2664 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2665 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2676 /* struct-vtable dst:12 src:12
2678 * Store the vtable of SRC into DST.
2680 VM_DEFINE_OP (101, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2683 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2684 RETURN (SCM_STRUCT_VTABLE (obj
));
2687 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2689 * Allocate a new struct with VTABLE, and place it in DST. The struct
2690 * will be constructed with space for NFIELDS fields, which should
2691 * correspond to the field count of the VTABLE.
2693 VM_DEFINE_OP (102, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2695 scm_t_uint8 dst
, vtable
, nfields
;
2698 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2701 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2702 LOCAL_SET (dst
, ret
);
2707 /* struct-ref/immediate dst:8 src:8 idx:8
2709 * Fetch the item at slot IDX in the struct in SRC, and store it
2710 * in DST. IDX is an immediate unsigned 8-bit value.
2712 VM_DEFINE_OP (103, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2714 scm_t_uint8 dst
, src
, idx
;
2717 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2719 obj
= LOCAL_REF (src
);
2721 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2722 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2723 SCM_VTABLE_FLAG_SIMPLE
)
2724 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2725 scm_vtable_index_size
)))
2726 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2729 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2732 /* struct-set!/immediate dst:8 idx:8 src:8
2734 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2735 * unsigned 8-bit value.
2737 VM_DEFINE_OP (104, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2739 scm_t_uint8 dst
, idx
, src
;
2742 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2744 obj
= LOCAL_REF (dst
);
2745 val
= LOCAL_REF (src
);
2747 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2748 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2749 SCM_VTABLE_FLAG_SIMPLE
)
2750 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2751 SCM_VTABLE_FLAG_SIMPLE_RW
)
2752 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2753 scm_vtable_index_size
)))
2755 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2760 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2764 /* class-of dst:12 type:12
2766 * Store the vtable of SRC into DST.
2768 VM_DEFINE_OP (105, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2771 if (SCM_INSTANCEP (obj
))
2772 RETURN (SCM_CLASS_OF (obj
));
2774 RETURN (scm_class_of (obj
));
2780 * Arrays, packed uniform arrays, and bytevectors.
2783 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2785 * Load the contiguous typed array located at OFFSET 32-bit words away
2786 * from the instruction pointer, and store into DST. LEN is a byte
2787 * length. OFFSET is signed.
2789 VM_DEFINE_OP (106, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2791 scm_t_uint8 dst
, type
, shape
;
2795 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2799 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2805 /* make-array dst:8 type:8 fill:8 _:8 bounds:24
2807 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2809 VM_DEFINE_OP (107, make_array
, "make-array", OP2 (U8_U8_U8_U8
, X8_U24
) | OP_DST
)
2811 scm_t_uint8 dst
, type
, fill
, bounds
;
2812 UNPACK_8_8_8 (op
, dst
, type
, fill
);
2813 UNPACK_24 (ip
[1], bounds
);
2815 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2816 LOCAL_REF (bounds
)));
2820 /* bv-u8-ref dst:8 src:8 idx:8
2821 * bv-s8-ref dst:8 src:8 idx:8
2822 * bv-u16-ref dst:8 src:8 idx:8
2823 * bv-s16-ref dst:8 src:8 idx:8
2824 * bv-u32-ref dst:8 src:8 idx:8
2825 * bv-s32-ref dst:8 src:8 idx:8
2826 * bv-u64-ref dst:8 src:8 idx:8
2827 * bv-s64-ref dst:8 src:8 idx:8
2828 * bv-f32-ref dst:8 src:8 idx:8
2829 * bv-f64-ref dst:8 src:8 idx:8
2831 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2832 * it in DST. All accesses use native endianness.
2834 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2836 scm_t_signed_bits i; \
2837 const scm_t_ ## type *int_ptr; \
2840 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2841 i = SCM_I_INUM (idx); \
2842 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2844 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2846 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2847 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2848 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2852 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2856 #define BV_INT_REF(stem, type, size) \
2858 scm_t_signed_bits i; \
2859 const scm_t_ ## type *int_ptr; \
2862 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2863 i = SCM_I_INUM (idx); \
2864 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2866 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2868 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2869 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2871 scm_t_ ## type x = *int_ptr; \
2872 if (SCM_FIXABLE (x)) \
2873 RETURN (SCM_I_MAKINUM (x)); \
2877 RETURN (scm_from_ ## type (x)); \
2883 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2887 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2889 scm_t_signed_bits i; \
2890 const type *float_ptr; \
2893 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2894 i = SCM_I_INUM (idx); \
2895 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2898 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2900 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2901 && (ALIGNED_P (float_ptr, type)))) \
2902 RETURN (scm_from_double (*float_ptr)); \
2904 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2907 VM_DEFINE_OP (108, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2908 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2910 VM_DEFINE_OP (109, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2911 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2913 VM_DEFINE_OP (110, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2914 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2916 VM_DEFINE_OP (111, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2917 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2919 VM_DEFINE_OP (112, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2920 #if SIZEOF_VOID_P > 4
2921 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2923 BV_INT_REF (u32
, uint32
, 4);
2926 VM_DEFINE_OP (113, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2927 #if SIZEOF_VOID_P > 4
2928 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2930 BV_INT_REF (s32
, int32
, 4);
2933 VM_DEFINE_OP (114, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2934 BV_INT_REF (u64
, uint64
, 8);
2936 VM_DEFINE_OP (115, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2937 BV_INT_REF (s64
, int64
, 8);
2939 VM_DEFINE_OP (116, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2940 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2942 VM_DEFINE_OP (117, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2943 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2945 /* bv-u8-set! dst:8 idx:8 src:8
2946 * bv-s8-set! dst:8 idx:8 src:8
2947 * bv-u16-set! dst:8 idx:8 src:8
2948 * bv-s16-set! dst:8 idx:8 src:8
2949 * bv-u32-set! dst:8 idx:8 src:8
2950 * bv-s32-set! dst:8 idx:8 src:8
2951 * bv-u64-set! dst:8 idx:8 src:8
2952 * bv-s64-set! dst:8 idx:8 src:8
2953 * bv-f32-set! dst:8 idx:8 src:8
2954 * bv-f64-set! dst:8 idx:8 src:8
2956 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2957 * values are written using native endianness.
2959 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2961 scm_t_uint8 dst, idx, src; \
2962 scm_t_signed_bits i, j = 0; \
2963 SCM bv, scm_idx, val; \
2964 scm_t_ ## type *int_ptr; \
2966 UNPACK_8_8_8 (op, dst, idx, src); \
2967 bv = LOCAL_REF (dst); \
2968 scm_idx = LOCAL_REF (idx); \
2969 val = LOCAL_REF (src); \
2970 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2971 i = SCM_I_INUM (scm_idx); \
2972 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2974 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2976 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2977 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2978 && (SCM_I_INUMP (val)) \
2979 && ((j = SCM_I_INUM (val)) >= min) \
2981 *int_ptr = (scm_t_ ## type) j; \
2985 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
2990 #define BV_INT_SET(stem, type, size) \
2992 scm_t_uint8 dst, idx, src; \
2993 scm_t_signed_bits i; \
2994 SCM bv, scm_idx, val; \
2995 scm_t_ ## type *int_ptr; \
2997 UNPACK_8_8_8 (op, dst, idx, src); \
2998 bv = LOCAL_REF (dst); \
2999 scm_idx = LOCAL_REF (idx); \
3000 val = LOCAL_REF (src); \
3001 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3002 i = SCM_I_INUM (scm_idx); \
3003 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3005 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3007 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3008 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3009 *int_ptr = scm_to_ ## type (val); \
3013 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3018 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3020 scm_t_uint8 dst, idx, src; \
3021 scm_t_signed_bits i; \
3022 SCM bv, scm_idx, val; \
3025 UNPACK_8_8_8 (op, dst, idx, src); \
3026 bv = LOCAL_REF (dst); \
3027 scm_idx = LOCAL_REF (idx); \
3028 val = LOCAL_REF (src); \
3029 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3030 i = SCM_I_INUM (scm_idx); \
3031 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3033 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3035 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3036 && (ALIGNED_P (float_ptr, type)))) \
3037 *float_ptr = scm_to_double (val); \
3041 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3046 VM_DEFINE_OP (118, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3047 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3049 VM_DEFINE_OP (119, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3050 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3052 VM_DEFINE_OP (120, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3053 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3055 VM_DEFINE_OP (121, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3056 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3058 VM_DEFINE_OP (122, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3059 #if SIZEOF_VOID_P > 4
3060 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3062 BV_INT_SET (u32
, uint32
, 4);
3065 VM_DEFINE_OP (123, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3066 #if SIZEOF_VOID_P > 4
3067 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3069 BV_INT_SET (s32
, int32
, 4);
3072 VM_DEFINE_OP (124, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3073 BV_INT_SET (u64
, uint64
, 8);
3075 VM_DEFINE_OP (125, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3076 BV_INT_SET (s64
, int64
, 8);
3078 VM_DEFINE_OP (126, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3079 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3081 VM_DEFINE_OP (127, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3082 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3084 VM_DEFINE_OP (128, unused_128
, NULL
, NOP
)
3085 VM_DEFINE_OP (129, unused_129
, NULL
, NOP
)
3086 VM_DEFINE_OP (130, unused_130
, NULL
, NOP
)
3087 VM_DEFINE_OP (131, unused_131
, NULL
, NOP
)
3088 VM_DEFINE_OP (132, unused_132
, NULL
, NOP
)
3089 VM_DEFINE_OP (133, unused_133
, NULL
, NOP
)
3090 VM_DEFINE_OP (134, unused_134
, NULL
, NOP
)
3091 VM_DEFINE_OP (135, unused_135
, NULL
, NOP
)
3092 VM_DEFINE_OP (136, unused_136
, NULL
, NOP
)
3093 VM_DEFINE_OP (137, unused_137
, NULL
, NOP
)
3094 VM_DEFINE_OP (138, unused_138
, NULL
, NOP
)
3095 VM_DEFINE_OP (139, unused_139
, NULL
, NOP
)
3096 VM_DEFINE_OP (140, unused_140
, NULL
, NOP
)
3097 VM_DEFINE_OP (141, unused_141
, NULL
, NOP
)
3098 VM_DEFINE_OP (142, unused_142
, NULL
, NOP
)
3099 VM_DEFINE_OP (143, unused_143
, NULL
, NOP
)
3100 VM_DEFINE_OP (144, unused_144
, NULL
, NOP
)
3101 VM_DEFINE_OP (145, unused_145
, NULL
, NOP
)
3102 VM_DEFINE_OP (146, unused_146
, NULL
, NOP
)
3103 VM_DEFINE_OP (147, unused_147
, NULL
, NOP
)
3104 VM_DEFINE_OP (148, unused_148
, NULL
, NOP
)
3105 VM_DEFINE_OP (149, unused_149
, NULL
, NOP
)
3106 VM_DEFINE_OP (150, unused_150
, NULL
, NOP
)
3107 VM_DEFINE_OP (151, unused_151
, NULL
, NOP
)
3108 VM_DEFINE_OP (152, unused_152
, NULL
, NOP
)
3109 VM_DEFINE_OP (153, unused_153
, NULL
, NOP
)
3110 VM_DEFINE_OP (154, unused_154
, NULL
, NOP
)
3111 VM_DEFINE_OP (155, unused_155
, NULL
, NOP
)
3112 VM_DEFINE_OP (156, unused_156
, NULL
, NOP
)
3113 VM_DEFINE_OP (157, unused_157
, NULL
, NOP
)
3114 VM_DEFINE_OP (158, unused_158
, NULL
, NOP
)
3115 VM_DEFINE_OP (159, unused_159
, NULL
, NOP
)
3116 VM_DEFINE_OP (160, unused_160
, NULL
, NOP
)
3117 VM_DEFINE_OP (161, unused_161
, NULL
, NOP
)
3118 VM_DEFINE_OP (162, unused_162
, NULL
, NOP
)
3119 VM_DEFINE_OP (163, unused_163
, NULL
, NOP
)
3120 VM_DEFINE_OP (164, unused_164
, NULL
, NOP
)
3121 VM_DEFINE_OP (165, unused_165
, NULL
, NOP
)
3122 VM_DEFINE_OP (166, unused_166
, NULL
, NOP
)
3123 VM_DEFINE_OP (167, unused_167
, NULL
, NOP
)
3124 VM_DEFINE_OP (168, unused_168
, NULL
, NOP
)
3125 VM_DEFINE_OP (169, unused_169
, NULL
, NOP
)
3126 VM_DEFINE_OP (170, unused_170
, NULL
, NOP
)
3127 VM_DEFINE_OP (171, unused_171
, NULL
, NOP
)
3128 VM_DEFINE_OP (172, unused_172
, NULL
, NOP
)
3129 VM_DEFINE_OP (173, unused_173
, NULL
, NOP
)
3130 VM_DEFINE_OP (174, unused_174
, NULL
, NOP
)
3131 VM_DEFINE_OP (175, unused_175
, NULL
, NOP
)
3132 VM_DEFINE_OP (176, unused_176
, NULL
, NOP
)
3133 VM_DEFINE_OP (177, unused_177
, NULL
, NOP
)
3134 VM_DEFINE_OP (178, unused_178
, NULL
, NOP
)
3135 VM_DEFINE_OP (179, unused_179
, NULL
, NOP
)
3136 VM_DEFINE_OP (180, unused_180
, NULL
, NOP
)
3137 VM_DEFINE_OP (181, unused_181
, NULL
, NOP
)
3138 VM_DEFINE_OP (182, unused_182
, NULL
, NOP
)
3139 VM_DEFINE_OP (183, unused_183
, NULL
, NOP
)
3140 VM_DEFINE_OP (184, unused_184
, NULL
, NOP
)
3141 VM_DEFINE_OP (185, unused_185
, NULL
, NOP
)
3142 VM_DEFINE_OP (186, unused_186
, NULL
, NOP
)
3143 VM_DEFINE_OP (187, unused_187
, NULL
, NOP
)
3144 VM_DEFINE_OP (188, unused_188
, NULL
, NOP
)
3145 VM_DEFINE_OP (189, unused_189
, NULL
, NOP
)
3146 VM_DEFINE_OP (190, unused_190
, NULL
, NOP
)
3147 VM_DEFINE_OP (191, unused_191
, NULL
, NOP
)
3148 VM_DEFINE_OP (192, unused_192
, NULL
, NOP
)
3149 VM_DEFINE_OP (193, unused_193
, NULL
, NOP
)
3150 VM_DEFINE_OP (194, unused_194
, NULL
, NOP
)
3151 VM_DEFINE_OP (195, unused_195
, NULL
, NOP
)
3152 VM_DEFINE_OP (196, unused_196
, NULL
, NOP
)
3153 VM_DEFINE_OP (197, unused_197
, NULL
, NOP
)
3154 VM_DEFINE_OP (198, unused_198
, NULL
, NOP
)
3155 VM_DEFINE_OP (199, unused_199
, NULL
, NOP
)
3156 VM_DEFINE_OP (200, unused_200
, NULL
, NOP
)
3157 VM_DEFINE_OP (201, unused_201
, NULL
, NOP
)
3158 VM_DEFINE_OP (202, unused_202
, NULL
, NOP
)
3159 VM_DEFINE_OP (203, unused_203
, NULL
, NOP
)
3160 VM_DEFINE_OP (204, unused_204
, NULL
, NOP
)
3161 VM_DEFINE_OP (205, unused_205
, NULL
, NOP
)
3162 VM_DEFINE_OP (206, unused_206
, NULL
, NOP
)
3163 VM_DEFINE_OP (207, unused_207
, NULL
, NOP
)
3164 VM_DEFINE_OP (208, unused_208
, NULL
, NOP
)
3165 VM_DEFINE_OP (209, unused_209
, NULL
, NOP
)
3166 VM_DEFINE_OP (210, unused_210
, NULL
, NOP
)
3167 VM_DEFINE_OP (211, unused_211
, NULL
, NOP
)
3168 VM_DEFINE_OP (212, unused_212
, NULL
, NOP
)
3169 VM_DEFINE_OP (213, unused_213
, NULL
, NOP
)
3170 VM_DEFINE_OP (214, unused_214
, NULL
, NOP
)
3171 VM_DEFINE_OP (215, unused_215
, NULL
, NOP
)
3172 VM_DEFINE_OP (216, unused_216
, NULL
, NOP
)
3173 VM_DEFINE_OP (217, unused_217
, NULL
, NOP
)
3174 VM_DEFINE_OP (218, unused_218
, NULL
, NOP
)
3175 VM_DEFINE_OP (219, unused_219
, NULL
, NOP
)
3176 VM_DEFINE_OP (220, unused_220
, NULL
, NOP
)
3177 VM_DEFINE_OP (221, unused_221
, NULL
, NOP
)
3178 VM_DEFINE_OP (222, unused_222
, NULL
, NOP
)
3179 VM_DEFINE_OP (223, unused_223
, NULL
, NOP
)
3180 VM_DEFINE_OP (224, unused_224
, NULL
, NOP
)
3181 VM_DEFINE_OP (225, unused_225
, NULL
, NOP
)
3182 VM_DEFINE_OP (226, unused_226
, NULL
, NOP
)
3183 VM_DEFINE_OP (227, unused_227
, NULL
, NOP
)
3184 VM_DEFINE_OP (228, unused_228
, NULL
, NOP
)
3185 VM_DEFINE_OP (229, unused_229
, NULL
, NOP
)
3186 VM_DEFINE_OP (230, unused_230
, NULL
, NOP
)
3187 VM_DEFINE_OP (231, unused_231
, NULL
, NOP
)
3188 VM_DEFINE_OP (232, unused_232
, NULL
, NOP
)
3189 VM_DEFINE_OP (233, unused_233
, NULL
, NOP
)
3190 VM_DEFINE_OP (234, unused_234
, NULL
, NOP
)
3191 VM_DEFINE_OP (235, unused_235
, NULL
, NOP
)
3192 VM_DEFINE_OP (236, unused_236
, NULL
, NOP
)
3193 VM_DEFINE_OP (237, unused_237
, NULL
, NOP
)
3194 VM_DEFINE_OP (238, unused_238
, NULL
, NOP
)
3195 VM_DEFINE_OP (239, unused_239
, NULL
, NOP
)
3196 VM_DEFINE_OP (240, unused_240
, NULL
, NOP
)
3197 VM_DEFINE_OP (241, unused_241
, NULL
, NOP
)
3198 VM_DEFINE_OP (242, unused_242
, NULL
, NOP
)
3199 VM_DEFINE_OP (243, unused_243
, NULL
, NOP
)
3200 VM_DEFINE_OP (244, unused_244
, NULL
, NOP
)
3201 VM_DEFINE_OP (245, unused_245
, NULL
, NOP
)
3202 VM_DEFINE_OP (246, unused_246
, NULL
, NOP
)
3203 VM_DEFINE_OP (247, unused_247
, NULL
, NOP
)
3204 VM_DEFINE_OP (248, unused_248
, NULL
, NOP
)
3205 VM_DEFINE_OP (249, unused_249
, NULL
, NOP
)
3206 VM_DEFINE_OP (250, unused_250
, NULL
, NOP
)
3207 VM_DEFINE_OP (251, unused_251
, NULL
, NOP
)
3208 VM_DEFINE_OP (252, unused_252
, NULL
, NOP
)
3209 VM_DEFINE_OP (253, unused_253
, NULL
, NOP
)
3210 VM_DEFINE_OP (254, unused_254
, NULL
, NOP
)
3211 VM_DEFINE_OP (255, unused_255
, NULL
, NOP
)
3213 vm_error_bad_instruction (op
);
3214 abort (); /* never reached */
3217 END_DISPATCH_SWITCH
;
3221 #undef ABORT_CONTINUATION_HOOK
3226 #undef BEGIN_DISPATCH_SWITCH
3227 #undef BINARY_INTEGER_OP
3228 #undef BR_ARITHMETIC
3232 #undef BV_FIXABLE_INT_REF
3233 #undef BV_FIXABLE_INT_SET
3238 #undef CACHE_REGISTER
3239 #undef END_DISPATCH_SWITCH
3240 #undef FREE_VARIABLE_REF
3249 #undef POP_CONTINUATION_HOOK
3250 #undef PUSH_CONTINUATION_HOOK
3252 #undef RETURN_ONE_VALUE
3253 #undef RETURN_VALUE_LIST
3263 #undef VARIABLE_BOUNDP
3266 #undef VM_CHECK_FREE_VARIABLE
3267 #undef VM_CHECK_OBJECT
3268 #undef VM_CHECK_UNDERFLOW
3270 #undef VM_INSTRUCTION_TO_LABEL
3272 #undef VM_VALIDATE_BYTEVECTOR
3273 #undef VM_VALIDATE_PAIR
3274 #undef VM_VALIDATE_STRUCT
3277 (defun renumber-ops ()
3278 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3281 (let ((counter -1)) (goto-char (point-min))
3282 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3284 (number-to-string (setq counter (1+ counter)))