1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* This file is included in vm.c multiple times. */
22 #define UNPACK_8_8_8(op,a,b,c) \
25 a = (op >> 8) & 0xff; \
26 b = (op >> 16) & 0xff; \
31 #define UNPACK_8_16(op,a,b) \
34 a = (op >> 8) & 0xff; \
39 #define UNPACK_16_8(op,a,b) \
42 a = (op >> 8) & 0xffff; \
47 #define UNPACK_12_12(op,a,b) \
50 a = (op >> 8) & 0xfff; \
55 #define UNPACK_24(op,a) \
63 /* Assign some registers by hand. There used to be a bigger list here,
64 but it was never tested, and in the case of x86-32, was a source of
65 compilation failures. It can be revived if it's useful, but my naive
66 hope is that simply annotating the locals with "register" will be a
67 sufficient hint to the compiler. */
69 # if defined __x86_64__
70 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
71 well. Tell it to keep the jump table in a r12, which is
73 # define JT_REG asm ("r12")
87 #define VM_ASSERT(condition, handler) \
89 if (SCM_UNLIKELY (!(condition))) \
96 #ifdef VM_ENABLE_ASSERTIONS
97 # define ASSERT(condition) VM_ASSERT (condition, abort())
99 # define ASSERT(condition)
103 #define RUN_HOOK(exp) \
105 if (SCM_UNLIKELY (vp->trace_level > 0)) \
113 #define RUN_HOOK(exp)
115 #define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
116 #define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
118 #define APPLY_HOOK() \
120 #define PUSH_CONTINUATION_HOOK() \
121 RUN_HOOK0 (push_continuation)
122 #define POP_CONTINUATION_HOOK(old_fp) \
123 RUN_HOOK1 (pop_continuation, old_fp)
124 #define NEXT_HOOK() \
126 #define ABORT_CONTINUATION_HOOK() \
129 #define VM_HANDLE_INTERRUPTS \
130 SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ())
135 The VM has three state bits: the instruction pointer (IP), the frame
136 pointer (FP), and the top-of-stack pointer (SP). We cache the first
137 two of these in machine registers, local to the VM, because they are
138 used extensively by the VM. As the SP is used more by code outside
139 the VM than by the VM itself, we don't bother caching it locally.
141 Since the FP changes infrequently, relative to the IP, we keep vp->fp
142 in sync with the local FP. This would be a big lose for the IP,
143 though, so instead of updating vp->ip all the time, we call SYNC_IP
144 whenever we would need to know the IP of the top frame. In practice,
145 we need to SYNC_IP whenever we call out of the VM to a function that
146 would like to walk the stack, perhaps as the result of an
149 One more thing. We allow the stack to move, when it expands.
150 Therefore if you call out to a C procedure that could call Scheme
151 code, or otherwise push anything on the stack, you will need to
152 CACHE_FP afterwards to restore the possibly-changed FP. */
154 #define SYNC_IP() vp->ip = (ip)
156 #define CACHE_FP() fp = (vp->fp)
157 #define CACHE_REGISTER() \
164 /* Reserve stack space for a frame. Will check that there is sufficient
165 stack space for N locals, including the procedure. Invoke after
166 preparing the new frame and setting the fp and ip.
168 If there is not enough space for this frame, we try to expand the
169 stack, possibly relocating it somewhere else in the address space.
170 Because of the possible relocation, no pointer into the stack besides
171 FP is valid across an ALLOC_FRAME call. Be careful! */
172 #define ALLOC_FRAME(n) \
174 SCM *new_sp = LOCAL_ADDRESS (n - 1); \
175 if (new_sp > vp->sp_max_since_gc) \
177 if (SCM_UNLIKELY (new_sp >= vp->stack_limit)) \
180 vm_expand_stack (vp, new_sp); \
184 vp->sp_max_since_gc = vp->sp = new_sp; \
190 /* Reset the current frame to hold N locals. Used when we know that no
191 stack expansion is needed. */
192 #define RESET_FRAME(n) \
194 vp->sp = LOCAL_ADDRESS (n - 1); \
195 if (vp->sp > vp->sp_max_since_gc) \
196 vp->sp_max_since_gc = vp->sp; \
199 /* Compute the number of locals in the frame. At a call, this is equal
200 to the number of actual arguments when a function is first called,
201 plus one for the function. */
202 #define FRAME_LOCALS_COUNT_FROM(slot) \
203 (vp->sp + 1 - LOCAL_ADDRESS (slot))
204 #define FRAME_LOCALS_COUNT() \
205 FRAME_LOCALS_COUNT_FROM (0)
207 /* Restore registers after returning from a frame. */
208 #define RESTORE_FRAME() \
213 #ifdef HAVE_LABELS_AS_VALUES
214 # define BEGIN_DISPATCH_SWITCH /* */
215 # define END_DISPATCH_SWITCH /* */
222 goto *jump_table[op & 0xff]; \
225 # define VM_DEFINE_OP(opcode, tag, name, meta) \
228 # define BEGIN_DISPATCH_SWITCH \
234 # define END_DISPATCH_SWITCH \
243 # define VM_DEFINE_OP(opcode, tag, name, meta) \
248 #define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
249 #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
250 #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
252 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
253 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
254 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
256 #define RETURN_ONE_VALUE(ret) \
260 VM_HANDLE_INTERRUPTS; \
262 ip = SCM_FRAME_RETURN_ADDRESS (fp); \
263 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
265 old_fp[-1] = SCM_BOOL_F; \
266 old_fp[-2] = SCM_BOOL_F; \
268 SCM_FRAME_LOCAL (old_fp, 1) = val; \
269 vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
270 POP_CONTINUATION_HOOK (old_fp); \
274 /* While we could generate the list-unrolling code here, it's fine for
275 now to just tail-call (apply values vals). */
276 #define RETURN_VALUE_LIST(vals_) \
279 VM_HANDLE_INTERRUPTS; \
280 fp[0] = vm_builtin_apply; \
281 fp[1] = vm_builtin_values; \
284 ip = (scm_t_uint32 *) vm_builtin_apply_code; \
285 goto op_tail_apply; \
288 #define BR_NARGS(rel) \
289 scm_t_uint32 expected; \
290 UNPACK_24 (op, expected); \
291 if (FRAME_LOCALS_COUNT() rel expected) \
293 scm_t_int32 offset = ip[1]; \
294 offset >>= 8; /* Sign-extending shift. */ \
299 #define BR_UNARY(x, exp) \
302 UNPACK_24 (op, test); \
303 x = LOCAL_REF (test); \
304 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
306 scm_t_int32 offset = ip[1]; \
307 offset >>= 8; /* Sign-extending shift. */ \
309 VM_HANDLE_INTERRUPTS; \
314 #define BR_BINARY(x, y, exp) \
317 UNPACK_12_12 (op, a, b); \
320 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
322 scm_t_int32 offset = ip[1]; \
323 offset >>= 8; /* Sign-extending shift. */ \
325 VM_HANDLE_INTERRUPTS; \
330 #define BR_ARITHMETIC(crel,srel) \
334 UNPACK_12_12 (op, a, b); \
337 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
339 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
340 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
341 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
343 scm_t_int32 offset = ip[1]; \
344 offset >>= 8; /* Sign-extending shift. */ \
346 VM_HANDLE_INTERRUPTS; \
357 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
359 scm_t_int32 offset = ip[1]; \
360 offset >>= 8; /* Sign-extending shift. */ \
362 VM_HANDLE_INTERRUPTS; \
370 scm_t_uint16 dst, src; \
372 UNPACK_12_12 (op, dst, src); \
374 #define ARGS2(a1, a2) \
375 scm_t_uint8 dst, src1, src2; \
377 UNPACK_8_8_8 (op, dst, src1, src2); \
378 a1 = LOCAL_REF (src1); \
379 a2 = LOCAL_REF (src2)
381 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
382 #define RETURN_EXP(exp) \
383 do { SCM __x; SYNC_IP (); __x = exp; CACHE_FP (); RETURN (__x); } while (0)
385 /* The maximum/minimum tagged integers. */
387 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
389 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
391 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
392 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
394 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
397 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
399 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
400 if (SCM_FIXABLE (n)) \
401 RETURN (SCM_I_MAKINUM (n)); \
403 RETURN_EXP (SFUNC (x, y)); \
406 #define VM_VALIDATE_PAIR(x, proc) \
407 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
409 #define VM_VALIDATE_STRUCT(obj, proc) \
410 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
412 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
413 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
415 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
416 #define ALIGNED_P(ptr, type) \
417 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
420 VM_NAME (scm_i_thread
*thread
, struct scm_vm
*vp
,
421 scm_i_jmp_buf
*registers
, int resume
)
423 /* Instruction pointer: A pointer to the opcode that is currently
425 register scm_t_uint32
*ip IP_REG
;
427 /* Frame pointer: A pointer into the stack, off of which we index
428 arguments and local variables. Pushed at function calls, popped on
430 register SCM
*fp FP_REG
;
432 /* Current opcode: A cache of *ip. */
433 register scm_t_uint32 op
;
435 #ifdef HAVE_LABELS_AS_VALUES
436 static const void *jump_table_
[256] = {
437 #define LABEL_ADDR(opcode, tag, name, meta) &&op_##tag,
438 FOR_EACH_VM_OPERATION(LABEL_ADDR
)
441 register const void **jump_table JT_REG
;
442 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
443 load instruction at each instruction dispatch. */
444 jump_table
= jump_table_
;
447 /* Load VM registers. */
450 VM_HANDLE_INTERRUPTS
;
452 /* Usually a call to the VM happens on application, with the boot
453 continuation on the next frame. Sometimes it happens after a
454 non-local exit however; in that case the VM state is all set up,
455 and we have but to jump to the next opcode. */
456 if (SCM_UNLIKELY (resume
))
460 while (!SCM_PROGRAM_P (LOCAL_REF (0)))
462 SCM proc
= LOCAL_REF (0);
464 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
466 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
469 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
471 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
473 /* Shuffle args up. */
476 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
478 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
483 vm_error_wrong_type_apply (proc
);
487 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
490 BEGIN_DISPATCH_SWITCH
;
501 * Bring the VM to a halt, returning all the values from the stack.
503 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
505 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
507 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
516 for (n
= nvals
; n
> 0; n
--)
517 ret
= scm_inline_cons (thread
, LOCAL_REF (4 + n
- 1), ret
);
518 ret
= scm_values (ret
);
521 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
522 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
523 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
528 /* call proc:24 _:8 nlocals:24
530 * Call a procedure. PROC is the local corresponding to a procedure.
531 * The two values below PROC will be overwritten by the saved call
532 * frame data. The new frame will have space for NLOCALS locals: one
533 * for the procedure, and the rest for the arguments which should
534 * already have been pushed on.
536 * When the call returns, execution proceeds with the next
537 * instruction. There may be any number of values on the return
538 * stack; the precise number can be had by subtracting the address of
539 * PROC from the post-call SP.
541 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
543 scm_t_uint32 proc
, nlocals
;
546 UNPACK_24 (op
, proc
);
547 UNPACK_24 (ip
[1], nlocals
);
549 VM_HANDLE_INTERRUPTS
;
552 fp
= vp
->fp
= old_fp
+ proc
;
553 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
554 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
556 RESET_FRAME (nlocals
);
558 PUSH_CONTINUATION_HOOK ();
561 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
564 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
568 /* call-label proc:24 _:8 nlocals:24 label:32
570 * Call a procedure in the same compilation unit.
572 * This instruction is just like "call", except that instead of
573 * dereferencing PROC to find the call target, the call target is
574 * known to be at LABEL, a signed 32-bit offset in 32-bit units from
575 * the current IP. Since PROC is not dereferenced, it may be some
576 * other representation of the closure.
578 VM_DEFINE_OP (2, call_label
, "call-label", OP3 (U8_U24
, X8_U24
, L32
))
580 scm_t_uint32 proc
, nlocals
;
584 UNPACK_24 (op
, proc
);
585 UNPACK_24 (ip
[1], nlocals
);
588 VM_HANDLE_INTERRUPTS
;
591 fp
= vp
->fp
= old_fp
+ proc
;
592 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
593 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 3);
595 RESET_FRAME (nlocals
);
597 PUSH_CONTINUATION_HOOK ();
603 /* tail-call nlocals:24
605 * Tail-call a procedure. Requires that the procedure and all of the
606 * arguments have already been shuffled into position. Will reset the
609 VM_DEFINE_OP (3, tail_call
, "tail-call", OP1 (U8_U24
))
611 scm_t_uint32 nlocals
;
613 UNPACK_24 (op
, nlocals
);
615 VM_HANDLE_INTERRUPTS
;
617 RESET_FRAME (nlocals
);
621 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
624 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
628 /* tail-call-label nlocals:24 label:32
630 * Tail-call a known procedure. As call is to call-label, tail-call
631 * is to tail-call-label.
633 VM_DEFINE_OP (4, tail_call_label
, "tail-call-label", OP2 (U8_U24
, L32
))
635 scm_t_uint32 nlocals
;
638 UNPACK_24 (op
, nlocals
);
641 VM_HANDLE_INTERRUPTS
;
643 RESET_FRAME (nlocals
);
650 /* tail-call/shuffle from:24
652 * Tail-call a procedure. The procedure should already be set to slot
653 * 0. The rest of the args are taken from the frame, starting at
654 * FROM, shuffled down to start at slot 0. This is part of the
655 * implementation of the call-with-values builtin.
657 VM_DEFINE_OP (5, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
659 scm_t_uint32 n
, from
, nlocals
;
661 UNPACK_24 (op
, from
);
663 VM_HANDLE_INTERRUPTS
;
665 VM_ASSERT (from
> 0, abort ());
666 nlocals
= FRAME_LOCALS_COUNT ();
668 for (n
= 0; from
+ n
< nlocals
; n
++)
669 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
675 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
678 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
682 /* receive dst:12 proc:12 _:8 nlocals:24
684 * Receive a single return value from a call whose procedure was in
685 * PROC, asserting that the call actually returned at least one
686 * value. Afterwards, resets the frame to NLOCALS locals.
688 VM_DEFINE_OP (6, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
690 scm_t_uint16 dst
, proc
;
691 scm_t_uint32 nlocals
;
692 UNPACK_12_12 (op
, dst
, proc
);
693 UNPACK_24 (ip
[1], nlocals
);
694 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
695 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
696 RESET_FRAME (nlocals
);
700 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
702 * Receive a return of multiple values from a call whose procedure was
703 * in PROC. If fewer than NVALUES values were returned, signal an
704 * error. Unless ALLOW-EXTRA? is true, require that the number of
705 * return values equals NVALUES exactly. After receive-values has
706 * run, the values can be copied down via `mov'.
708 VM_DEFINE_OP (7, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
710 scm_t_uint32 proc
, nvalues
;
711 UNPACK_24 (op
, proc
);
712 UNPACK_24 (ip
[1], nvalues
);
714 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
715 vm_error_not_enough_values ());
717 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
718 vm_error_wrong_number_of_values (nvalues
));
726 VM_DEFINE_OP (8, return, "return", OP1 (U8_U24
))
730 RETURN_ONE_VALUE (LOCAL_REF (src
));
733 /* return-values _:24
735 * Return a number of values from a call frame. This opcode
736 * corresponds to an application of `values' in tail position. As
737 * with tail calls, we expect that the values have already been
738 * shuffled down to a contiguous array starting at slot 1.
739 * We also expect the frame has already been reset.
741 VM_DEFINE_OP (9, return_values
, "return-values", OP1 (U8_X24
))
745 VM_HANDLE_INTERRUPTS
;
748 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
749 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
751 /* Clear stack frame. */
752 old_fp
[-1] = SCM_BOOL_F
;
753 old_fp
[-2] = SCM_BOOL_F
;
755 POP_CONTINUATION_HOOK (old_fp
);
764 * Specialized call stubs
767 /* subr-call ptr-idx:24
769 * Call a subr, passing all locals in this frame as arguments. Fetch
770 * the foreign pointer from PTR-IDX, a free variable. Return from the
771 * calling frame. This instruction is part of the trampolines
772 * created in gsubr.c, and is not generated by the compiler.
774 VM_DEFINE_OP (10, subr_call
, "subr-call", OP1 (U8_U24
))
776 scm_t_uint32 ptr_idx
;
780 UNPACK_24 (op
, ptr_idx
);
782 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
783 subr
= SCM_POINTER_VALUE (pointer
);
787 switch (FRAME_LOCALS_COUNT_FROM (1))
796 ret
= subr (fp
[1], fp
[2]);
799 ret
= subr (fp
[1], fp
[2], fp
[3]);
802 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
805 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
808 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
811 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
814 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
817 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
820 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
828 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
829 /* multiple values returned to continuation */
830 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
832 RETURN_ONE_VALUE (ret
);
835 /* foreign-call cif-idx:12 ptr-idx:12
837 * Call a foreign function. Fetch the CIF and foreign pointer from
838 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
839 * frame. Arguments are taken from the stack. This instruction is
840 * part of the trampolines created by the FFI, and is not generated by
843 VM_DEFINE_OP (11, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
845 scm_t_uint16 cif_idx
, ptr_idx
;
846 SCM closure
, cif
, pointer
, ret
;
848 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
850 closure
= LOCAL_REF (0);
851 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
852 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
856 // FIXME: separate args
857 ret
= scm_i_foreign_call (scm_inline_cons (thread
, cif
, pointer
),
862 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
863 /* multiple values returned to continuation */
864 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
866 RETURN_ONE_VALUE (ret
);
869 /* continuation-call contregs:24
871 * Return to a continuation, nonlocally. The arguments to the
872 * continuation are taken from the stack. CONTREGS is a free variable
873 * containing the reified continuation. This instruction is part of
874 * the implementation of undelimited continuations, and is not
875 * generated by the compiler.
877 VM_DEFINE_OP (12, continuation_call
, "continuation-call", OP1 (U8_U24
))
880 scm_t_uint32 contregs_idx
;
882 UNPACK_24 (op
, contregs_idx
);
885 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
888 scm_i_check_continuation (contregs
);
889 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
890 scm_i_contregs_vm_cont (contregs
),
891 FRAME_LOCALS_COUNT_FROM (1),
893 scm_i_reinstate_continuation (contregs
);
899 /* compose-continuation cont:24
901 * Compose a partial continution with the current continuation. The
902 * arguments to the continuation are taken from the stack. CONT is a
903 * free variable containing the reified continuation. This
904 * instruction is part of the implementation of partial continuations,
905 * and is not generated by the compiler.
907 VM_DEFINE_OP (13, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
910 scm_t_uint32 cont_idx
;
912 UNPACK_24 (op
, cont_idx
);
913 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
916 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
917 vm_error_continuation_not_rewindable (vmcont
));
918 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
928 * Tail-apply the procedure in local slot 0 to the rest of the
929 * arguments. This instruction is part of the implementation of
930 * `apply', and is not generated by the compiler.
932 VM_DEFINE_OP (14, tail_apply
, "tail-apply", OP1 (U8_X24
))
934 int i
, list_idx
, list_len
, nlocals
;
937 VM_HANDLE_INTERRUPTS
;
939 nlocals
= FRAME_LOCALS_COUNT ();
940 // At a minimum, there should be apply, f, and the list.
941 VM_ASSERT (nlocals
>= 3, abort ());
942 list_idx
= nlocals
- 1;
943 list
= LOCAL_REF (list_idx
);
944 list_len
= scm_ilength (list
);
946 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
948 nlocals
= nlocals
- 2 + list_len
;
949 ALLOC_FRAME (nlocals
);
951 for (i
= 1; i
< list_idx
; i
++)
952 LOCAL_SET (i
- 1, LOCAL_REF (i
));
954 /* Null out these slots, just in case there are less than 2 elements
956 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
957 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
959 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
960 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
964 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
967 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
973 * Capture the current continuation, and tail-apply the procedure in
974 * local slot 1 to it. This instruction is part of the implementation
975 * of `call/cc', and is not generated by the compiler.
977 VM_DEFINE_OP (15, call_cc
, "call/cc", OP1 (U8_X24
))
980 scm_t_dynstack
*dynstack
;
983 VM_HANDLE_INTERRUPTS
;
986 dynstack
= scm_dynstack_capture_all (&thread
->dynstack
);
987 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
988 SCM_FRAME_DYNAMIC_LINK (fp
),
989 SCM_FRAME_PREVIOUS_SP (fp
),
990 SCM_FRAME_RETURN_ADDRESS (fp
),
993 /* FIXME: Seems silly to capture the registers here, when they are
994 already captured in the registers local, which here we are
995 copying out to the heap; and likewise, the setjmp(®isters)
996 code already has the non-local return handler. But oh
998 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
1002 LOCAL_SET (0, LOCAL_REF (1));
1003 LOCAL_SET (1, cont
);
1008 if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
1011 ip
= SCM_PROGRAM_CODE (LOCAL_REF (0));
1017 ABORT_CONTINUATION_HOOK ();
1024 * Abort to a prompt handler. The tag is expected in r1, and the rest
1025 * of the values in the frame are returned to the prompt handler.
1026 * This corresponds to a tail application of abort-to-prompt.
1028 VM_DEFINE_OP (16, abort
, "abort", OP1 (U8_X24
))
1030 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1032 ASSERT (nlocals
>= 2);
1033 /* FIXME: Really we should capture the caller's registers. Until
1034 then, manually advance the IP so that when the prompt resumes,
1035 it continues with the next instruction. */
1038 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1039 SCM_EOL
, LOCAL_ADDRESS (0), registers
);
1041 /* vm_abort should not return */
1045 /* builtin-ref dst:12 idx:12
1047 * Load a builtin stub by index into DST.
1049 VM_DEFINE_OP (17, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1051 scm_t_uint16 dst
, idx
;
1053 UNPACK_12_12 (op
, dst
, idx
);
1054 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1063 * Function prologues
1066 /* br-if-nargs-ne expected:24 _:8 offset:24
1067 * br-if-nargs-lt expected:24 _:8 offset:24
1068 * br-if-nargs-gt expected:24 _:8 offset:24
1070 * If the number of actual arguments is not equal, less than, or greater
1071 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1072 * the current instruction pointer.
1074 VM_DEFINE_OP (18, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1078 VM_DEFINE_OP (19, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1082 VM_DEFINE_OP (20, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1087 /* assert-nargs-ee expected:24
1088 * assert-nargs-ge expected:24
1089 * assert-nargs-le expected:24
1091 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1092 * respectively, signal an error.
1094 VM_DEFINE_OP (21, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1096 scm_t_uint32 expected
;
1097 UNPACK_24 (op
, expected
);
1098 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1099 vm_error_wrong_num_args (LOCAL_REF (0)));
1102 VM_DEFINE_OP (22, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1104 scm_t_uint32 expected
;
1105 UNPACK_24 (op
, expected
);
1106 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1107 vm_error_wrong_num_args (LOCAL_REF (0)));
1110 VM_DEFINE_OP (23, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1112 scm_t_uint32 expected
;
1113 UNPACK_24 (op
, expected
);
1114 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1115 vm_error_wrong_num_args (LOCAL_REF (0)));
1119 /* alloc-frame nlocals:24
1121 * Ensure that there is space on the stack for NLOCALS local variables,
1122 * setting them all to SCM_UNDEFINED, except those nargs values that
1123 * were passed as arguments and procedure.
1125 VM_DEFINE_OP (24, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1127 scm_t_uint32 nlocals
, nargs
;
1128 UNPACK_24 (op
, nlocals
);
1130 nargs
= FRAME_LOCALS_COUNT ();
1131 ALLOC_FRAME (nlocals
);
1132 while (nlocals
-- > nargs
)
1133 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1138 /* reset-frame nlocals:24
1140 * Like alloc-frame, but doesn't check that the stack is big enough.
1141 * Used to reset the frame size to something less than the size that
1142 * was previously set via alloc-frame.
1144 VM_DEFINE_OP (25, reset_frame
, "reset-frame", OP1 (U8_U24
))
1146 scm_t_uint32 nlocals
;
1147 UNPACK_24 (op
, nlocals
);
1148 RESET_FRAME (nlocals
);
1152 /* assert-nargs-ee/locals expected:12 nlocals:12
1154 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1155 * number of locals reserved is EXPECTED + NLOCALS.
1157 VM_DEFINE_OP (26, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1159 scm_t_uint16 expected
, nlocals
;
1160 UNPACK_12_12 (op
, expected
, nlocals
);
1161 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1162 vm_error_wrong_num_args (LOCAL_REF (0)));
1163 ALLOC_FRAME (expected
+ nlocals
);
1165 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1170 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1172 * Find the first positional argument after NREQ. If it is greater
1173 * than NPOS, jump to OFFSET.
1175 * This instruction is only emitted for functions with multiple
1176 * clauses, and an earlier clause has keywords and no rest arguments.
1177 * See "Case-lambda" in the manual, for more on how case-lambda
1178 * chooses the clause to apply.
1180 VM_DEFINE_OP (27, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1182 scm_t_uint32 nreq
, npos
;
1184 UNPACK_24 (op
, nreq
);
1185 UNPACK_24 (ip
[1], npos
);
1187 /* We can only have too many positionals if there are more
1188 arguments than NPOS. */
1189 if (FRAME_LOCALS_COUNT() > npos
)
1192 for (n
= nreq
; n
< npos
; n
++)
1193 if (scm_is_keyword (LOCAL_REF (n
)))
1195 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1197 scm_t_int32 offset
= ip
[2];
1198 offset
>>= 8; /* Sign-extending shift. */
1205 /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
1207 * flags := allow-other-keys:1 has-rest:1 _:6
1209 * Find the last positional argument, and shuffle all the rest above
1210 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1211 * load the constant at KW-OFFSET words from the current IP, and use it
1212 * to bind keyword arguments. If HAS-REST, collect all shuffled
1213 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1214 * the arguments that we shuffled up.
1216 * A macro-mega-instruction.
1218 VM_DEFINE_OP (28, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1220 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1221 scm_t_int32 kw_offset
;
1224 char allow_other_keys
, has_rest
;
1226 UNPACK_24 (op
, nreq
);
1227 allow_other_keys
= ip
[1] & 0x1;
1228 has_rest
= ip
[1] & 0x2;
1229 UNPACK_24 (ip
[1], nreq_and_opt
);
1230 UNPACK_24 (ip
[2], ntotal
);
1232 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1233 VM_ASSERT (!(kw_bits
& 0x7), abort());
1234 kw
= SCM_PACK (kw_bits
);
1236 nargs
= FRAME_LOCALS_COUNT ();
1238 /* look in optionals for first keyword or last positional */
1239 /* starting after the last required positional arg */
1241 while (/* while we have args */
1243 /* and we still have positionals to fill */
1244 && npositional
< nreq_and_opt
1245 /* and we haven't reached a keyword yet */
1246 && !scm_is_keyword (LOCAL_REF (npositional
)))
1247 /* bind this optional arg (by leaving it in place) */
1249 nkw
= nargs
- npositional
;
1250 /* shuffle non-positional arguments above ntotal */
1251 ALLOC_FRAME (ntotal
+ nkw
);
1254 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1255 /* and fill optionals & keyword args with SCM_UNDEFINED */
1258 LOCAL_SET (n
++, SCM_UNDEFINED
);
1260 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1261 vm_error_kwargs_length_not_even (LOCAL_REF (0)));
1263 /* Now bind keywords, in the order given. */
1264 for (n
= 0; n
< nkw
; n
++)
1265 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1268 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1269 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1271 SCM si
= SCM_CDAR (walk
);
1272 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1273 LOCAL_REF (ntotal
+ n
+ 1));
1276 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1277 vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0),
1278 LOCAL_REF (ntotal
+ n
)));
1282 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (LOCAL_REF (0),
1283 LOCAL_REF (ntotal
+ n
)));
1290 rest
= scm_inline_cons (thread
, LOCAL_REF (ntotal
+ n
), rest
);
1291 LOCAL_SET (nreq_and_opt
, rest
);
1294 RESET_FRAME (ntotal
);
1301 * Collect any arguments at or above DST into a list, and store that
1304 VM_DEFINE_OP (29, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1306 scm_t_uint32 dst
, nargs
;
1309 UNPACK_24 (op
, dst
);
1310 nargs
= FRAME_LOCALS_COUNT ();
1314 ALLOC_FRAME (dst
+ 1);
1316 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1320 while (nargs
-- > dst
)
1322 rest
= scm_inline_cons (thread
, LOCAL_REF (nargs
), rest
);
1323 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1326 RESET_FRAME (dst
+ 1);
1329 LOCAL_SET (dst
, rest
);
1338 * Branching instructions
1343 * Add OFFSET, a signed 24-bit number, to the current instruction
1346 VM_DEFINE_OP (30, br
, "br", OP1 (U8_L24
))
1348 scm_t_int32 offset
= op
;
1349 offset
>>= 8; /* Sign-extending shift. */
1351 VM_HANDLE_INTERRUPTS
;
1355 /* br-if-true test:24 invert:1 _:7 offset:24
1357 * If the value in TEST is true for the purposes of Scheme, add
1358 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1360 VM_DEFINE_OP (31, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1362 BR_UNARY (x
, scm_is_true (x
));
1365 /* br-if-null test:24 invert:1 _:7 offset:24
1367 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1368 * signed 24-bit number, to the current instruction pointer.
1370 VM_DEFINE_OP (32, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1372 BR_UNARY (x
, scm_is_null (x
));
1375 /* br-if-nil test:24 invert:1 _:7 offset:24
1377 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1378 * number, to the current instruction pointer.
1380 VM_DEFINE_OP (33, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1382 BR_UNARY (x
, scm_is_lisp_false (x
));
1385 /* br-if-pair test:24 invert:1 _:7 offset:24
1387 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1388 * to the current instruction pointer.
1390 VM_DEFINE_OP (34, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1392 BR_UNARY (x
, scm_is_pair (x
));
1395 /* br-if-struct test:24 invert:1 _:7 offset:24
1397 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1398 * number, to the current instruction pointer.
1400 VM_DEFINE_OP (35, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1402 BR_UNARY (x
, SCM_STRUCTP (x
));
1405 /* br-if-char test:24 invert:1 _:7 offset:24
1407 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1408 * to the current instruction pointer.
1410 VM_DEFINE_OP (36, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1412 BR_UNARY (x
, SCM_CHARP (x
));
1415 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1417 * If the value in TEST has the TC7 given in the second word, add
1418 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1420 VM_DEFINE_OP (37, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1422 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1425 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1427 * If the value in A is eq? to the value in B, add OFFSET, a signed
1428 * 24-bit number, to the current instruction pointer.
1430 VM_DEFINE_OP (38, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1432 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1435 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1437 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1438 * 24-bit number, to the current instruction pointer.
1440 VM_DEFINE_OP (39, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1444 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1445 && scm_is_true (scm_eqv_p (x
, y
))));
1448 // FIXME: remove, have compiler inline eqv test instead
1449 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1451 * If the value in A is equal? to the value in B, add OFFSET, a signed
1452 * 24-bit number, to the current instruction pointer.
1454 // FIXME: Should sync_ip before calling out and cache_fp before coming
1455 // back! Another reason to remove this opcode!
1456 VM_DEFINE_OP (40, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1460 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1461 && scm_is_true (scm_equal_p (x
, y
))));
1464 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1466 * If the value in A is = to the value in B, add OFFSET, a signed
1467 * 24-bit number, to the current instruction pointer.
1469 VM_DEFINE_OP (41, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1471 BR_ARITHMETIC (==, scm_num_eq_p
);
1474 /* br-if-< a:12 b:12 invert:1 _:7 offset:24
1476 * If the value in A is < to the value in B, add OFFSET, a signed
1477 * 24-bit number, to the current instruction pointer.
1479 VM_DEFINE_OP (42, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1481 BR_ARITHMETIC (<, scm_less_p
);
1484 /* br-if-<= a:12 b:12 invert:1 _:7 offset:24
1486 * If the value in A is <= to the value in B, add OFFSET, a signed
1487 * 24-bit number, to the current instruction pointer.
1489 VM_DEFINE_OP (43, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1491 BR_ARITHMETIC (<=, scm_leq_p
);
1498 * Lexical binding instructions
1501 /* mov dst:12 src:12
1503 * Copy a value from one local slot to another.
1505 VM_DEFINE_OP (44, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1510 UNPACK_12_12 (op
, dst
, src
);
1511 LOCAL_SET (dst
, LOCAL_REF (src
));
1516 /* long-mov dst:24 _:8 src:24
1518 * Copy a value from one local slot to another.
1520 VM_DEFINE_OP (45, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1525 UNPACK_24 (op
, dst
);
1526 UNPACK_24 (ip
[1], src
);
1527 LOCAL_SET (dst
, LOCAL_REF (src
));
1532 /* box dst:12 src:12
1534 * Create a new variable holding SRC, and place it in DST.
1536 VM_DEFINE_OP (46, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1538 scm_t_uint16 dst
, src
;
1539 UNPACK_12_12 (op
, dst
, src
);
1540 LOCAL_SET (dst
, scm_inline_cell (thread
, scm_tc7_variable
,
1541 SCM_UNPACK (LOCAL_REF (src
))));
1545 /* box-ref dst:12 src:12
1547 * Unpack the variable at SRC into DST, asserting that the variable is
1550 VM_DEFINE_OP (47, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1552 scm_t_uint16 dst
, src
;
1554 UNPACK_12_12 (op
, dst
, src
);
1555 var
= LOCAL_REF (src
);
1556 VM_ASSERT (SCM_VARIABLEP (var
),
1557 vm_error_not_a_variable ("variable-ref", var
));
1558 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (var
));
1559 LOCAL_SET (dst
, VARIABLE_REF (var
));
1563 /* box-set! dst:12 src:12
1565 * Set the contents of the variable at DST to SET.
1567 VM_DEFINE_OP (48, box_set
, "box-set!", OP1 (U8_U12_U12
))
1569 scm_t_uint16 dst
, src
;
1571 UNPACK_12_12 (op
, dst
, src
);
1572 var
= LOCAL_REF (dst
);
1573 VM_ASSERT (SCM_VARIABLEP (var
),
1574 vm_error_not_a_variable ("variable-set!", var
));
1575 VARIABLE_SET (var
, LOCAL_REF (src
));
1579 /* make-closure dst:24 offset:32 _:8 nfree:24
1581 * Make a new closure, and write it to DST. The code for the closure
1582 * will be found at OFFSET words from the current IP. OFFSET is a
1583 * signed 32-bit integer. Space for NFREE free variables will be
1586 VM_DEFINE_OP (49, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1588 scm_t_uint32 dst
, nfree
, n
;
1592 UNPACK_24 (op
, dst
);
1594 UNPACK_24 (ip
[2], nfree
);
1596 // FIXME: Assert range of nfree?
1597 closure
= scm_inline_words (thread
, scm_tc7_program
| (nfree
<< 16),
1599 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1600 // FIXME: Elide these initializations?
1601 for (n
= 0; n
< nfree
; n
++)
1602 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1603 LOCAL_SET (dst
, closure
);
1607 /* free-ref dst:12 src:12 _:8 idx:24
1609 * Load free variable IDX from the closure SRC into local slot DST.
1611 VM_DEFINE_OP (50, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1613 scm_t_uint16 dst
, src
;
1615 UNPACK_12_12 (op
, dst
, src
);
1616 UNPACK_24 (ip
[1], idx
);
1617 /* CHECK_FREE_VARIABLE (src); */
1618 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1622 /* free-set! dst:12 src:12 _:8 idx:24
1624 * Set free variable IDX from the closure DST to SRC.
1626 VM_DEFINE_OP (51, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
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 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1641 * Immediates and statically allocated non-immediates
1644 /* make-short-immediate dst:8 low-bits:16
1646 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1649 VM_DEFINE_OP (52, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1654 UNPACK_8_16 (op
, dst
, val
);
1655 LOCAL_SET (dst
, SCM_PACK (val
));
1659 /* make-long-immediate dst:24 low-bits:32
1661 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1664 VM_DEFINE_OP (53, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
) | OP_DST
)
1669 UNPACK_24 (op
, dst
);
1671 LOCAL_SET (dst
, SCM_PACK (val
));
1675 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1677 * Make an immediate with HIGH-BITS and LOW-BITS.
1679 VM_DEFINE_OP (54, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1684 UNPACK_24 (op
, dst
);
1685 #if SIZEOF_SCM_T_BITS > 4
1690 ASSERT (ip
[1] == 0);
1693 LOCAL_SET (dst
, SCM_PACK (val
));
1697 /* make-non-immediate dst:24 offset:32
1699 * Load a pointer to statically allocated memory into DST. The
1700 * object's memory is will be found OFFSET 32-bit words away from the
1701 * current instruction pointer. OFFSET is a signed value. The
1702 * intention here is that the compiler would produce an object file
1703 * containing the words of a non-immediate object, and this
1704 * instruction creates a pointer to that memory, effectively
1705 * resurrecting that object.
1707 * Whether the object is mutable or immutable depends on where it was
1708 * allocated by the compiler, and loaded by the loader.
1710 VM_DEFINE_OP (55, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1715 scm_t_bits unpacked
;
1717 UNPACK_24 (op
, dst
);
1720 unpacked
= (scm_t_bits
) loc
;
1722 VM_ASSERT (!(unpacked
& 0x7), abort());
1724 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1729 /* static-ref dst:24 offset:32
1731 * Load a SCM value into DST. The SCM value will be fetched from
1732 * memory, OFFSET 32-bit words away from the current instruction
1733 * pointer. OFFSET is a signed value.
1735 * The intention is for this instruction to be used to load constants
1736 * that the compiler is unable to statically allocate, like symbols.
1737 * These values would be initialized when the object file loads.
1739 VM_DEFINE_OP (56, static_ref
, "static-ref", OP2 (U8_U24
, S32
) | OP_DST
)
1744 scm_t_uintptr loc_bits
;
1746 UNPACK_24 (op
, dst
);
1749 loc_bits
= (scm_t_uintptr
) loc
;
1750 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1752 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1757 /* static-set! src:24 offset:32
1759 * Store a SCM value into memory, OFFSET 32-bit words away from the
1760 * current instruction pointer. OFFSET is a signed value.
1762 VM_DEFINE_OP (57, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1768 UNPACK_24 (op
, src
);
1771 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1773 *((SCM
*) loc
) = LOCAL_REF (src
);
1778 /* static-patch! _:24 dst-offset:32 src-offset:32
1780 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1781 * are signed 32-bit values, indicating a memory address as a number
1782 * of 32-bit words away from the current instruction pointer.
1784 VM_DEFINE_OP (58, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1786 scm_t_int32 dst_offset
, src_offset
;
1793 dst_loc
= (void **) (ip
+ dst_offset
);
1794 src
= ip
+ src_offset
;
1795 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1805 * Mutable top-level bindings
1808 /* There are three slightly different ways to resolve toplevel
1811 1. A toplevel reference outside of a function. These need to be
1812 looked up when the expression is evaluated -- no later, and no
1813 before. They are looked up relative to the module that is
1814 current when the expression is evaluated. For example:
1818 The "resolve" instruction resolves the variable (box), and then
1819 access is via box-ref or box-set!.
1821 2. A toplevel reference inside a function. These are looked up
1822 relative to the module that was current when the function was
1823 defined. Unlike code at the toplevel, which is usually run only
1824 once, these bindings benefit from memoized lookup, in which the
1825 variable resulting from the lookup is cached in the function.
1827 (lambda () (if (foo) a b))
1829 The toplevel-box instruction is equivalent to "resolve", but
1830 caches the resulting variable in statically allocated memory.
1832 3. A reference to an identifier with respect to a particular
1833 module. This can happen for primitive references, and
1834 references residualized by macro expansions. These can always
1835 be cached. Use module-box for these.
1838 /* current-module dst:24
1840 * Store the current module in DST.
1842 VM_DEFINE_OP (59, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1846 UNPACK_24 (op
, dst
);
1849 LOCAL_SET (dst
, scm_current_module ());
1854 /* resolve dst:24 bound?:1 _:7 sym:24
1856 * Resolve SYM in the current module, and place the resulting variable
1859 VM_DEFINE_OP (60, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1865 UNPACK_24 (op
, dst
);
1866 UNPACK_24 (ip
[1], sym
);
1869 var
= scm_lookup (LOCAL_REF (sym
));
1872 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (LOCAL_REF (sym
)));
1873 LOCAL_SET (dst
, var
);
1878 /* define! sym:12 val:12
1880 * Look up a binding for SYM in the current module, creating it if
1881 * necessary. Set its value to VAL.
1883 VM_DEFINE_OP (61, define
, "define!", OP1 (U8_U12_U12
))
1885 scm_t_uint16 sym
, val
;
1886 UNPACK_12_12 (op
, sym
, val
);
1888 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1893 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1895 * Load a SCM value. The SCM value will be fetched from memory,
1896 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1897 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1900 * Then, if the loaded value is a variable, it is placed in DST, and control
1903 * Otherwise, we have to resolve the variable. In that case we load
1904 * the module from MOD-OFFSET, just as we loaded the variable.
1905 * Usually the module gets set when the closure is created. The name
1906 * is an offset to a symbol.
1908 * We use the module and the symbol to resolve the variable, placing it in
1909 * DST, and caching the resolved variable so that we will hit the cache next
1912 VM_DEFINE_OP (62, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1915 scm_t_int32 var_offset
;
1916 scm_t_uint32
* var_loc_u32
;
1920 UNPACK_24 (op
, dst
);
1922 var_loc_u32
= ip
+ var_offset
;
1923 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1924 var_loc
= (SCM
*) var_loc_u32
;
1927 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1930 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1931 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1932 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1933 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1937 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1938 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1940 mod
= *((SCM
*) mod_loc
);
1941 sym
= *((SCM
*) sym_loc
);
1943 /* If the toplevel scope was captured before modules were
1944 booted, use the root module. */
1945 if (scm_is_false (mod
))
1946 mod
= scm_the_root_module ();
1948 var
= scm_module_lookup (mod
, sym
);
1951 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
1956 LOCAL_SET (dst
, var
);
1960 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1962 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1963 * instead of the module itself.
1965 VM_DEFINE_OP (63, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1968 scm_t_int32 var_offset
;
1969 scm_t_uint32
* var_loc_u32
;
1973 UNPACK_24 (op
, dst
);
1975 var_loc_u32
= ip
+ var_offset
;
1976 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1977 var_loc
= (SCM
*) var_loc_u32
;
1980 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1983 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1984 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1985 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
1986 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1990 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
1991 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1993 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
1994 sym
= *((SCM
*) sym_loc
);
1996 if (!scm_module_system_booted_p
)
1999 scm_equal_p (modname
,
2002 scm_from_utf8_symbol ("guile"))));
2003 var
= scm_lookup (sym
);
2005 else if (scm_is_true (SCM_CAR (modname
)))
2006 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2008 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2013 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (sym
));
2018 LOCAL_SET (dst
, var
);
2025 * The dynamic environment
2028 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2030 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2031 * handler at HANDLER-OFFSET words from the current IP. The handler
2032 * will expect a multiple-value return as if from a call with the
2033 * procedure at PROC-SLOT.
2035 VM_DEFINE_OP (64, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2037 scm_t_uint32 tag
, proc_slot
;
2039 scm_t_uint8 escape_only_p
;
2040 scm_t_dynstack_prompt_flags flags
;
2042 UNPACK_24 (op
, tag
);
2043 escape_only_p
= ip
[1] & 0x1;
2044 UNPACK_24 (ip
[1], proc_slot
);
2046 offset
>>= 8; /* Sign extension */
2048 /* Push the prompt onto the dynamic stack. */
2049 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2050 scm_dynstack_push_prompt (&thread
->dynstack
, flags
,
2052 fp
- vp
->stack_base
,
2053 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2059 /* wind winder:12 unwinder:12
2061 * Push wind and unwind procedures onto the dynamic stack. Note that
2062 * neither are actually called; the compiler should emit calls to wind
2063 * and unwind for the normal dynamic-wind control flow. Also note that
2064 * the compiler should have inserted checks that they wind and unwind
2065 * procs are thunks, if it could not prove that to be the case.
2067 VM_DEFINE_OP (65, wind
, "wind", OP1 (U8_U12_U12
))
2069 scm_t_uint16 winder
, unwinder
;
2070 UNPACK_12_12 (op
, winder
, unwinder
);
2071 scm_dynstack_push_dynwind (&thread
->dynstack
,
2072 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2078 * A normal exit from the dynamic extent of an expression. Pop the top
2079 * entry off of the dynamic stack.
2081 VM_DEFINE_OP (66, unwind
, "unwind", OP1 (U8_X24
))
2083 scm_dynstack_pop (&thread
->dynstack
);
2087 /* push-fluid fluid:12 value:12
2089 * Dynamically bind VALUE to FLUID.
2091 VM_DEFINE_OP (67, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2093 scm_t_uint32 fluid
, value
;
2095 UNPACK_12_12 (op
, fluid
, value
);
2097 scm_dynstack_push_fluid (&thread
->dynstack
,
2098 LOCAL_REF (fluid
), LOCAL_REF (value
),
2099 thread
->dynamic_state
);
2105 * Leave the dynamic extent of a with-fluid* expression, restoring the
2106 * fluid to its previous value.
2108 VM_DEFINE_OP (68, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2110 /* This function must not allocate. */
2111 scm_dynstack_unwind_fluid (&thread
->dynstack
,
2112 thread
->dynamic_state
);
2116 /* fluid-ref dst:12 src:12
2118 * Reference the fluid in SRC, and place the value in DST.
2120 VM_DEFINE_OP (69, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2122 scm_t_uint16 dst
, src
;
2126 UNPACK_12_12 (op
, dst
, src
);
2127 fluid
= LOCAL_REF (src
);
2128 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2129 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2130 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2132 /* Punt dynstate expansion and error handling to the C proc. */
2134 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2138 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2139 if (scm_is_eq (val
, SCM_UNDEFINED
))
2140 val
= SCM_I_FLUID_DEFAULT (fluid
);
2141 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2142 vm_error_unbound_fluid (fluid
));
2143 LOCAL_SET (dst
, val
);
2149 /* fluid-set fluid:12 val:12
2151 * Set the value of the fluid in DST to the value in SRC.
2153 VM_DEFINE_OP (70, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2159 UNPACK_12_12 (op
, a
, b
);
2160 fluid
= LOCAL_REF (a
);
2161 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2162 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2163 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2165 /* Punt dynstate expansion and error handling to the C proc. */
2167 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2170 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2179 * Strings, symbols, and keywords
2182 /* string-length dst:12 src:12
2184 * Store the length of the string in SRC in DST.
2186 VM_DEFINE_OP (71, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2189 if (SCM_LIKELY (scm_is_string (str
)))
2190 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2194 RETURN (scm_string_length (str
));
2198 /* string-ref dst:8 src:8 idx:8
2200 * Fetch the character at position IDX in the string in SRC, and store
2203 VM_DEFINE_OP (72, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2205 scm_t_signed_bits i
= 0;
2207 if (SCM_LIKELY (scm_is_string (str
)
2208 && SCM_I_INUMP (idx
)
2209 && ((i
= SCM_I_INUM (idx
)) >= 0)
2210 && i
< scm_i_string_length (str
)))
2211 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2215 RETURN (scm_string_ref (str
, idx
));
2219 /* No string-set! instruction, as there is no good fast path there. */
2221 /* string->number dst:12 src:12
2223 * Parse a string in SRC to a number, and store in DST.
2225 VM_DEFINE_OP (73, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2227 scm_t_uint16 dst
, src
;
2229 UNPACK_12_12 (op
, dst
, src
);
2232 scm_string_to_number (LOCAL_REF (src
),
2233 SCM_UNDEFINED
/* radix = 10 */));
2237 /* string->symbol dst:12 src:12
2239 * Parse a string in SRC to a symbol, and store in DST.
2241 VM_DEFINE_OP (74, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2243 scm_t_uint16 dst
, src
;
2245 UNPACK_12_12 (op
, dst
, src
);
2247 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2251 /* symbol->keyword dst:12 src:12
2253 * Make a keyword from the symbol in SRC, and store it in DST.
2255 VM_DEFINE_OP (75, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2257 scm_t_uint16 dst
, src
;
2258 UNPACK_12_12 (op
, dst
, src
);
2260 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2270 /* cons dst:8 car:8 cdr:8
2272 * Cons CAR and CDR, and store the result in DST.
2274 VM_DEFINE_OP (76, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2277 RETURN (scm_inline_cons (thread
, x
, y
));
2280 /* car dst:12 src:12
2282 * Place the car of SRC in DST.
2284 VM_DEFINE_OP (77, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2287 VM_VALIDATE_PAIR (x
, "car");
2288 RETURN (SCM_CAR (x
));
2291 /* cdr dst:12 src:12
2293 * Place the cdr of SRC in DST.
2295 VM_DEFINE_OP (78, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2298 VM_VALIDATE_PAIR (x
, "cdr");
2299 RETURN (SCM_CDR (x
));
2302 /* set-car! pair:12 car:12
2304 * Set the car of DST to SRC.
2306 VM_DEFINE_OP (79, set_car
, "set-car!", OP1 (U8_U12_U12
))
2310 UNPACK_12_12 (op
, a
, b
);
2313 VM_VALIDATE_PAIR (x
, "set-car!");
2318 /* set-cdr! pair:12 cdr:12
2320 * Set the cdr of DST to SRC.
2322 VM_DEFINE_OP (80, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2326 UNPACK_12_12 (op
, a
, b
);
2329 VM_VALIDATE_PAIR (x
, "set-car!");
2338 * Numeric operations
2341 /* add dst:8 a:8 b:8
2343 * Add A to B, and place the result in DST.
2345 VM_DEFINE_OP (81, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2347 BINARY_INTEGER_OP (+, scm_sum
);
2350 /* add1 dst:12 src:12
2352 * Add 1 to the value in SRC, and place the result in DST.
2354 VM_DEFINE_OP (82, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2358 /* Check for overflow. We must avoid overflow in the signed
2359 addition below, even if X is not an inum. */
2360 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2364 /* Add 1 to the integer without untagging. */
2365 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2367 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2371 RETURN_EXP (scm_sum (x
, SCM_I_MAKINUM (1)));
2374 /* sub dst:8 a:8 b:8
2376 * Subtract B from A, and place the result in DST.
2378 VM_DEFINE_OP (83, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2380 BINARY_INTEGER_OP (-, scm_difference
);
2383 /* sub1 dst:12 src:12
2385 * Subtract 1 from SRC, and place the result in DST.
2387 VM_DEFINE_OP (84, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2391 /* Check for overflow. We must avoid overflow in the signed
2392 subtraction below, even if X is not an inum. */
2393 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2397 /* Substract 1 from the integer without untagging. */
2398 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2400 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2404 RETURN_EXP (scm_difference (x
, SCM_I_MAKINUM (1)));
2407 /* mul dst:8 a:8 b:8
2409 * Multiply A and B, and place the result in DST.
2411 VM_DEFINE_OP (85, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2414 RETURN_EXP (scm_product (x
, y
));
2417 /* div dst:8 a:8 b:8
2419 * Divide A by B, and place the result in DST.
2421 VM_DEFINE_OP (86, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2424 RETURN_EXP (scm_divide (x
, y
));
2427 /* quo dst:8 a:8 b:8
2429 * Divide A by B, and place the quotient in DST.
2431 VM_DEFINE_OP (87, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2434 RETURN_EXP (scm_quotient (x
, y
));
2437 /* rem dst:8 a:8 b:8
2439 * Divide A by B, and place the remainder in DST.
2441 VM_DEFINE_OP (88, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2444 RETURN_EXP (scm_remainder (x
, y
));
2447 /* mod dst:8 a:8 b:8
2449 * Place the modulo of A by B in DST.
2451 VM_DEFINE_OP (89, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2454 RETURN_EXP (scm_modulo (x
, y
));
2457 /* ash dst:8 a:8 b:8
2459 * Shift A arithmetically by B bits, and place the result in DST.
2461 VM_DEFINE_OP (90, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2464 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2466 if (SCM_I_INUM (y
) < 0)
2467 /* Right shift, will be a fixnum. */
2468 RETURN (SCM_I_MAKINUM
2469 (SCM_SRS (SCM_I_INUM (x
),
2470 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2471 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2473 /* Left shift. See comments in scm_ash. */
2475 scm_t_signed_bits nn
, bits_to_shift
;
2477 nn
= SCM_I_INUM (x
);
2478 bits_to_shift
= SCM_I_INUM (y
);
2480 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2482 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2484 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2489 RETURN_EXP (scm_ash (x
, y
));
2492 /* logand dst:8 a:8 b:8
2494 * Place the bitwise AND of A and B into DST.
2496 VM_DEFINE_OP (91, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2499 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2500 /* Compute bitwise AND without untagging */
2501 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2502 RETURN_EXP (scm_logand (x
, y
));
2505 /* logior dst:8 a:8 b:8
2507 * Place the bitwise inclusive OR of A with B in DST.
2509 VM_DEFINE_OP (92, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2512 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2513 /* Compute bitwise OR without untagging */
2514 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2515 RETURN_EXP (scm_logior (x
, y
));
2518 /* logxor dst:8 a:8 b:8
2520 * Place the bitwise exclusive OR of A with B in DST.
2522 VM_DEFINE_OP (93, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2525 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2526 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2527 RETURN_EXP (scm_logxor (x
, y
));
2530 /* make-vector dst:8 length:8 init:8
2532 * Make a vector and write it to DST. The vector will have space for
2533 * LENGTH slots. They will be filled with the value in slot INIT.
2535 VM_DEFINE_OP (94, make_vector
, "make-vector", OP1 (U8_U8_U8_U8
) | OP_DST
)
2537 scm_t_uint8 dst
, init
, length
;
2539 UNPACK_8_8_8 (op
, dst
, length
, init
);
2541 LOCAL_SET (dst
, scm_make_vector (LOCAL_REF (length
), LOCAL_REF (init
)));
2546 /* make-vector/immediate dst:8 length:8 init:8
2548 * Make a short vector of known size and write it to DST. The vector
2549 * will have space for LENGTH slots, an immediate value. They will be
2550 * filled with the value in slot INIT.
2552 VM_DEFINE_OP (95, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2554 scm_t_uint8 dst
, init
;
2555 scm_t_int32 length
, n
;
2558 UNPACK_8_8_8 (op
, dst
, length
, init
);
2560 val
= LOCAL_REF (init
);
2561 vector
= scm_inline_words (thread
, scm_tc7_vector
| (length
<< 8),
2563 for (n
= 0; n
< length
; n
++)
2564 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2565 LOCAL_SET (dst
, vector
);
2569 /* vector-length dst:12 src:12
2571 * Store the length of the vector in SRC in DST.
2573 VM_DEFINE_OP (96, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2576 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2577 vm_error_not_a_vector ("vector-ref", vect
));
2578 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2581 /* vector-ref dst:8 src:8 idx:8
2583 * Fetch the item at position IDX in the vector in SRC, and store it
2586 VM_DEFINE_OP (97, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2588 scm_t_signed_bits i
= 0;
2590 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2591 vm_error_not_a_vector ("vector-ref", vect
));
2592 VM_ASSERT ((SCM_I_INUMP (idx
)
2593 && ((i
= SCM_I_INUM (idx
)) >= 0)
2594 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2595 vm_error_out_of_range ("vector-ref", idx
));
2596 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2599 /* vector-ref/immediate dst:8 src:8 idx:8
2601 * Fill DST with the item IDX elements into the vector at SRC. Useful
2602 * for building data types using vectors.
2604 VM_DEFINE_OP (98, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2606 scm_t_uint8 dst
, src
, idx
;
2609 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2610 v
= LOCAL_REF (src
);
2611 VM_ASSERT (SCM_I_IS_VECTOR (v
),
2612 vm_error_not_a_vector ("vector-ref", v
));
2613 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (v
),
2614 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2615 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2619 /* vector-set! dst:8 idx:8 src:8
2621 * Store SRC into the vector DST at index IDX.
2623 VM_DEFINE_OP (99, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2625 scm_t_uint8 dst
, idx_var
, src
;
2627 scm_t_signed_bits i
= 0;
2629 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2630 vect
= LOCAL_REF (dst
);
2631 idx
= LOCAL_REF (idx_var
);
2632 val
= LOCAL_REF (src
);
2634 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2635 vm_error_not_a_vector ("vector-ref", vect
));
2636 VM_ASSERT ((SCM_I_INUMP (idx
)
2637 && ((i
= SCM_I_INUM (idx
)) >= 0)
2638 && i
< SCM_I_VECTOR_LENGTH (vect
)),
2639 vm_error_out_of_range ("vector-ref", idx
));
2640 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2644 /* vector-set!/immediate dst:8 idx:8 src:8
2646 * Store SRC into the vector DST at index IDX. Here IDX is an
2649 VM_DEFINE_OP (100, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2651 scm_t_uint8 dst
, idx
, src
;
2654 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2655 vect
= LOCAL_REF (dst
);
2656 val
= LOCAL_REF (src
);
2658 VM_ASSERT (SCM_I_IS_VECTOR (vect
),
2659 vm_error_not_a_vector ("vector-ref", vect
));
2660 VM_ASSERT (idx
< SCM_I_VECTOR_LENGTH (vect
),
2661 vm_error_out_of_range ("vector-ref", scm_from_size_t (idx
)));
2662 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2673 /* struct-vtable dst:12 src:12
2675 * Store the vtable of SRC into DST.
2677 VM_DEFINE_OP (101, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2680 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2681 RETURN (SCM_STRUCT_VTABLE (obj
));
2684 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2686 * Allocate a new struct with VTABLE, and place it in DST. The struct
2687 * will be constructed with space for NFIELDS fields, which should
2688 * correspond to the field count of the VTABLE.
2690 VM_DEFINE_OP (102, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2692 scm_t_uint8 dst
, vtable
, nfields
;
2695 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2698 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2699 LOCAL_SET (dst
, ret
);
2704 /* struct-ref/immediate dst:8 src:8 idx:8
2706 * Fetch the item at slot IDX in the struct in SRC, and store it
2707 * in DST. IDX is an immediate unsigned 8-bit value.
2709 VM_DEFINE_OP (103, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2711 scm_t_uint8 dst
, src
, idx
;
2714 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2716 obj
= LOCAL_REF (src
);
2718 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2719 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2720 SCM_VTABLE_FLAG_SIMPLE
)
2721 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2722 scm_vtable_index_size
)))
2723 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2726 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2729 /* struct-set!/immediate dst:8 idx:8 src:8
2731 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2732 * unsigned 8-bit value.
2734 VM_DEFINE_OP (104, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2736 scm_t_uint8 dst
, idx
, src
;
2739 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2741 obj
= LOCAL_REF (dst
);
2742 val
= LOCAL_REF (src
);
2744 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2745 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2746 SCM_VTABLE_FLAG_SIMPLE
)
2747 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2748 SCM_VTABLE_FLAG_SIMPLE_RW
)
2749 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2750 scm_vtable_index_size
)))
2752 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2757 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2761 /* class-of dst:12 type:12
2763 * Store the vtable of SRC into DST.
2765 VM_DEFINE_OP (105, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2768 if (SCM_INSTANCEP (obj
))
2769 RETURN (SCM_CLASS_OF (obj
));
2771 RETURN (scm_class_of (obj
));
2777 * Arrays, packed uniform arrays, and bytevectors.
2780 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2782 * Load the contiguous typed array located at OFFSET 32-bit words away
2783 * from the instruction pointer, and store into DST. LEN is a byte
2784 * length. OFFSET is signed.
2786 VM_DEFINE_OP (106, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2788 scm_t_uint8 dst
, type
, shape
;
2792 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2796 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2802 /* make-array dst:8 type:8 fill:8 _:8 bounds:24
2804 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2806 VM_DEFINE_OP (107, make_array
, "make-array", OP2 (U8_U8_U8_U8
, X8_U24
) | OP_DST
)
2808 scm_t_uint8 dst
, type
, fill
, bounds
;
2809 UNPACK_8_8_8 (op
, dst
, type
, fill
);
2810 UNPACK_24 (ip
[1], bounds
);
2812 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2813 LOCAL_REF (bounds
)));
2817 /* bv-u8-ref dst:8 src:8 idx:8
2818 * bv-s8-ref dst:8 src:8 idx:8
2819 * bv-u16-ref dst:8 src:8 idx:8
2820 * bv-s16-ref dst:8 src:8 idx:8
2821 * bv-u32-ref dst:8 src:8 idx:8
2822 * bv-s32-ref dst:8 src:8 idx:8
2823 * bv-u64-ref dst:8 src:8 idx:8
2824 * bv-s64-ref dst:8 src:8 idx:8
2825 * bv-f32-ref dst:8 src:8 idx:8
2826 * bv-f64-ref dst:8 src:8 idx:8
2828 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2829 * it in DST. All accesses use native endianness.
2831 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2833 scm_t_signed_bits i; \
2834 const scm_t_ ## type *int_ptr; \
2837 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2838 i = SCM_I_INUM (idx); \
2839 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2841 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2843 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2844 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2845 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2849 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2853 #define BV_INT_REF(stem, type, size) \
2855 scm_t_signed_bits i; \
2856 const scm_t_ ## type *int_ptr; \
2859 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2860 i = SCM_I_INUM (idx); \
2861 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2863 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2865 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2866 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2868 scm_t_ ## type x = *int_ptr; \
2869 if (SCM_FIXABLE (x)) \
2870 RETURN (SCM_I_MAKINUM (x)); \
2874 RETURN (scm_from_ ## type (x)); \
2880 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2884 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2886 scm_t_signed_bits i; \
2887 const type *float_ptr; \
2890 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2891 i = SCM_I_INUM (idx); \
2892 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2895 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2897 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2898 && (ALIGNED_P (float_ptr, type)))) \
2899 RETURN (scm_from_double (*float_ptr)); \
2901 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2904 VM_DEFINE_OP (108, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2905 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2907 VM_DEFINE_OP (109, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2908 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2910 VM_DEFINE_OP (110, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2911 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2913 VM_DEFINE_OP (111, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2914 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2916 VM_DEFINE_OP (112, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2917 #if SIZEOF_VOID_P > 4
2918 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2920 BV_INT_REF (u32
, uint32
, 4);
2923 VM_DEFINE_OP (113, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2924 #if SIZEOF_VOID_P > 4
2925 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2927 BV_INT_REF (s32
, int32
, 4);
2930 VM_DEFINE_OP (114, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2931 BV_INT_REF (u64
, uint64
, 8);
2933 VM_DEFINE_OP (115, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2934 BV_INT_REF (s64
, int64
, 8);
2936 VM_DEFINE_OP (116, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2937 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2939 VM_DEFINE_OP (117, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2940 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2942 /* bv-u8-set! dst:8 idx:8 src:8
2943 * bv-s8-set! dst:8 idx:8 src:8
2944 * bv-u16-set! dst:8 idx:8 src:8
2945 * bv-s16-set! dst:8 idx:8 src:8
2946 * bv-u32-set! dst:8 idx:8 src:8
2947 * bv-s32-set! dst:8 idx:8 src:8
2948 * bv-u64-set! dst:8 idx:8 src:8
2949 * bv-s64-set! dst:8 idx:8 src:8
2950 * bv-f32-set! dst:8 idx:8 src:8
2951 * bv-f64-set! dst:8 idx:8 src:8
2953 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2954 * values are written using native endianness.
2956 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2958 scm_t_uint8 dst, idx, src; \
2959 scm_t_signed_bits i, j = 0; \
2960 SCM bv, scm_idx, val; \
2961 scm_t_ ## type *int_ptr; \
2963 UNPACK_8_8_8 (op, dst, idx, src); \
2964 bv = LOCAL_REF (dst); \
2965 scm_idx = LOCAL_REF (idx); \
2966 val = LOCAL_REF (src); \
2967 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2968 i = SCM_I_INUM (scm_idx); \
2969 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2971 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2973 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2974 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2975 && (SCM_I_INUMP (val)) \
2976 && ((j = SCM_I_INUM (val)) >= min) \
2978 *int_ptr = (scm_t_ ## type) j; \
2982 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
2987 #define BV_INT_SET(stem, type, size) \
2989 scm_t_uint8 dst, idx, src; \
2990 scm_t_signed_bits i; \
2991 SCM bv, scm_idx, val; \
2992 scm_t_ ## type *int_ptr; \
2994 UNPACK_8_8_8 (op, dst, idx, src); \
2995 bv = LOCAL_REF (dst); \
2996 scm_idx = LOCAL_REF (idx); \
2997 val = LOCAL_REF (src); \
2998 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2999 i = SCM_I_INUM (scm_idx); \
3000 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3002 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3004 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3005 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3006 *int_ptr = scm_to_ ## type (val); \
3010 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3015 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3017 scm_t_uint8 dst, idx, src; \
3018 scm_t_signed_bits i; \
3019 SCM bv, scm_idx, val; \
3022 UNPACK_8_8_8 (op, dst, idx, src); \
3023 bv = LOCAL_REF (dst); \
3024 scm_idx = LOCAL_REF (idx); \
3025 val = LOCAL_REF (src); \
3026 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3027 i = SCM_I_INUM (scm_idx); \
3028 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3030 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3032 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3033 && (ALIGNED_P (float_ptr, type)))) \
3034 *float_ptr = scm_to_double (val); \
3038 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3043 VM_DEFINE_OP (118, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3044 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3046 VM_DEFINE_OP (119, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3047 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3049 VM_DEFINE_OP (120, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3050 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3052 VM_DEFINE_OP (121, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3053 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3055 VM_DEFINE_OP (122, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3056 #if SIZEOF_VOID_P > 4
3057 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3059 BV_INT_SET (u32
, uint32
, 4);
3062 VM_DEFINE_OP (123, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3063 #if SIZEOF_VOID_P > 4
3064 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3066 BV_INT_SET (s32
, int32
, 4);
3069 VM_DEFINE_OP (124, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3070 BV_INT_SET (u64
, uint64
, 8);
3072 VM_DEFINE_OP (125, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3073 BV_INT_SET (s64
, int64
, 8);
3075 VM_DEFINE_OP (126, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3076 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3078 VM_DEFINE_OP (127, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3079 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3081 VM_DEFINE_OP (128, unused_128
, NULL
, NOP
)
3082 VM_DEFINE_OP (129, unused_129
, NULL
, NOP
)
3083 VM_DEFINE_OP (130, unused_130
, NULL
, NOP
)
3084 VM_DEFINE_OP (131, unused_131
, NULL
, NOP
)
3085 VM_DEFINE_OP (132, unused_132
, NULL
, NOP
)
3086 VM_DEFINE_OP (133, unused_133
, NULL
, NOP
)
3087 VM_DEFINE_OP (134, unused_134
, NULL
, NOP
)
3088 VM_DEFINE_OP (135, unused_135
, NULL
, NOP
)
3089 VM_DEFINE_OP (136, unused_136
, NULL
, NOP
)
3090 VM_DEFINE_OP (137, unused_137
, NULL
, NOP
)
3091 VM_DEFINE_OP (138, unused_138
, NULL
, NOP
)
3092 VM_DEFINE_OP (139, unused_139
, NULL
, NOP
)
3093 VM_DEFINE_OP (140, unused_140
, NULL
, NOP
)
3094 VM_DEFINE_OP (141, unused_141
, NULL
, NOP
)
3095 VM_DEFINE_OP (142, unused_142
, NULL
, NOP
)
3096 VM_DEFINE_OP (143, unused_143
, NULL
, NOP
)
3097 VM_DEFINE_OP (144, unused_144
, NULL
, NOP
)
3098 VM_DEFINE_OP (145, unused_145
, NULL
, NOP
)
3099 VM_DEFINE_OP (146, unused_146
, NULL
, NOP
)
3100 VM_DEFINE_OP (147, unused_147
, NULL
, NOP
)
3101 VM_DEFINE_OP (148, unused_148
, NULL
, NOP
)
3102 VM_DEFINE_OP (149, unused_149
, NULL
, NOP
)
3103 VM_DEFINE_OP (150, unused_150
, NULL
, NOP
)
3104 VM_DEFINE_OP (151, unused_151
, NULL
, NOP
)
3105 VM_DEFINE_OP (152, unused_152
, NULL
, NOP
)
3106 VM_DEFINE_OP (153, unused_153
, NULL
, NOP
)
3107 VM_DEFINE_OP (154, unused_154
, NULL
, NOP
)
3108 VM_DEFINE_OP (155, unused_155
, NULL
, NOP
)
3109 VM_DEFINE_OP (156, unused_156
, NULL
, NOP
)
3110 VM_DEFINE_OP (157, unused_157
, NULL
, NOP
)
3111 VM_DEFINE_OP (158, unused_158
, NULL
, NOP
)
3112 VM_DEFINE_OP (159, unused_159
, NULL
, NOP
)
3113 VM_DEFINE_OP (160, unused_160
, NULL
, NOP
)
3114 VM_DEFINE_OP (161, unused_161
, NULL
, NOP
)
3115 VM_DEFINE_OP (162, unused_162
, NULL
, NOP
)
3116 VM_DEFINE_OP (163, unused_163
, NULL
, NOP
)
3117 VM_DEFINE_OP (164, unused_164
, NULL
, NOP
)
3118 VM_DEFINE_OP (165, unused_165
, NULL
, NOP
)
3119 VM_DEFINE_OP (166, unused_166
, NULL
, NOP
)
3120 VM_DEFINE_OP (167, unused_167
, NULL
, NOP
)
3121 VM_DEFINE_OP (168, unused_168
, NULL
, NOP
)
3122 VM_DEFINE_OP (169, unused_169
, NULL
, NOP
)
3123 VM_DEFINE_OP (170, unused_170
, NULL
, NOP
)
3124 VM_DEFINE_OP (171, unused_171
, NULL
, NOP
)
3125 VM_DEFINE_OP (172, unused_172
, NULL
, NOP
)
3126 VM_DEFINE_OP (173, unused_173
, NULL
, NOP
)
3127 VM_DEFINE_OP (174, unused_174
, NULL
, NOP
)
3128 VM_DEFINE_OP (175, unused_175
, NULL
, NOP
)
3129 VM_DEFINE_OP (176, unused_176
, NULL
, NOP
)
3130 VM_DEFINE_OP (177, unused_177
, NULL
, NOP
)
3131 VM_DEFINE_OP (178, unused_178
, NULL
, NOP
)
3132 VM_DEFINE_OP (179, unused_179
, NULL
, NOP
)
3133 VM_DEFINE_OP (180, unused_180
, NULL
, NOP
)
3134 VM_DEFINE_OP (181, unused_181
, NULL
, NOP
)
3135 VM_DEFINE_OP (182, unused_182
, NULL
, NOP
)
3136 VM_DEFINE_OP (183, unused_183
, NULL
, NOP
)
3137 VM_DEFINE_OP (184, unused_184
, NULL
, NOP
)
3138 VM_DEFINE_OP (185, unused_185
, NULL
, NOP
)
3139 VM_DEFINE_OP (186, unused_186
, NULL
, NOP
)
3140 VM_DEFINE_OP (187, unused_187
, NULL
, NOP
)
3141 VM_DEFINE_OP (188, unused_188
, NULL
, NOP
)
3142 VM_DEFINE_OP (189, unused_189
, NULL
, NOP
)
3143 VM_DEFINE_OP (190, unused_190
, NULL
, NOP
)
3144 VM_DEFINE_OP (191, unused_191
, NULL
, NOP
)
3145 VM_DEFINE_OP (192, unused_192
, NULL
, NOP
)
3146 VM_DEFINE_OP (193, unused_193
, NULL
, NOP
)
3147 VM_DEFINE_OP (194, unused_194
, NULL
, NOP
)
3148 VM_DEFINE_OP (195, unused_195
, NULL
, NOP
)
3149 VM_DEFINE_OP (196, unused_196
, NULL
, NOP
)
3150 VM_DEFINE_OP (197, unused_197
, NULL
, NOP
)
3151 VM_DEFINE_OP (198, unused_198
, NULL
, NOP
)
3152 VM_DEFINE_OP (199, unused_199
, NULL
, NOP
)
3153 VM_DEFINE_OP (200, unused_200
, NULL
, NOP
)
3154 VM_DEFINE_OP (201, unused_201
, NULL
, NOP
)
3155 VM_DEFINE_OP (202, unused_202
, NULL
, NOP
)
3156 VM_DEFINE_OP (203, unused_203
, NULL
, NOP
)
3157 VM_DEFINE_OP (204, unused_204
, NULL
, NOP
)
3158 VM_DEFINE_OP (205, unused_205
, NULL
, NOP
)
3159 VM_DEFINE_OP (206, unused_206
, NULL
, NOP
)
3160 VM_DEFINE_OP (207, unused_207
, NULL
, NOP
)
3161 VM_DEFINE_OP (208, unused_208
, NULL
, NOP
)
3162 VM_DEFINE_OP (209, unused_209
, NULL
, NOP
)
3163 VM_DEFINE_OP (210, unused_210
, NULL
, NOP
)
3164 VM_DEFINE_OP (211, unused_211
, NULL
, NOP
)
3165 VM_DEFINE_OP (212, unused_212
, NULL
, NOP
)
3166 VM_DEFINE_OP (213, unused_213
, NULL
, NOP
)
3167 VM_DEFINE_OP (214, unused_214
, NULL
, NOP
)
3168 VM_DEFINE_OP (215, unused_215
, NULL
, NOP
)
3169 VM_DEFINE_OP (216, unused_216
, NULL
, NOP
)
3170 VM_DEFINE_OP (217, unused_217
, NULL
, NOP
)
3171 VM_DEFINE_OP (218, unused_218
, NULL
, NOP
)
3172 VM_DEFINE_OP (219, unused_219
, NULL
, NOP
)
3173 VM_DEFINE_OP (220, unused_220
, NULL
, NOP
)
3174 VM_DEFINE_OP (221, unused_221
, NULL
, NOP
)
3175 VM_DEFINE_OP (222, unused_222
, NULL
, NOP
)
3176 VM_DEFINE_OP (223, unused_223
, NULL
, NOP
)
3177 VM_DEFINE_OP (224, unused_224
, NULL
, NOP
)
3178 VM_DEFINE_OP (225, unused_225
, NULL
, NOP
)
3179 VM_DEFINE_OP (226, unused_226
, NULL
, NOP
)
3180 VM_DEFINE_OP (227, unused_227
, NULL
, NOP
)
3181 VM_DEFINE_OP (228, unused_228
, NULL
, NOP
)
3182 VM_DEFINE_OP (229, unused_229
, NULL
, NOP
)
3183 VM_DEFINE_OP (230, unused_230
, NULL
, NOP
)
3184 VM_DEFINE_OP (231, unused_231
, NULL
, NOP
)
3185 VM_DEFINE_OP (232, unused_232
, NULL
, NOP
)
3186 VM_DEFINE_OP (233, unused_233
, NULL
, NOP
)
3187 VM_DEFINE_OP (234, unused_234
, NULL
, NOP
)
3188 VM_DEFINE_OP (235, unused_235
, NULL
, NOP
)
3189 VM_DEFINE_OP (236, unused_236
, NULL
, NOP
)
3190 VM_DEFINE_OP (237, unused_237
, NULL
, NOP
)
3191 VM_DEFINE_OP (238, unused_238
, NULL
, NOP
)
3192 VM_DEFINE_OP (239, unused_239
, NULL
, NOP
)
3193 VM_DEFINE_OP (240, unused_240
, NULL
, NOP
)
3194 VM_DEFINE_OP (241, unused_241
, NULL
, NOP
)
3195 VM_DEFINE_OP (242, unused_242
, NULL
, NOP
)
3196 VM_DEFINE_OP (243, unused_243
, NULL
, NOP
)
3197 VM_DEFINE_OP (244, unused_244
, NULL
, NOP
)
3198 VM_DEFINE_OP (245, unused_245
, NULL
, NOP
)
3199 VM_DEFINE_OP (246, unused_246
, NULL
, NOP
)
3200 VM_DEFINE_OP (247, unused_247
, NULL
, NOP
)
3201 VM_DEFINE_OP (248, unused_248
, NULL
, NOP
)
3202 VM_DEFINE_OP (249, unused_249
, NULL
, NOP
)
3203 VM_DEFINE_OP (250, unused_250
, NULL
, NOP
)
3204 VM_DEFINE_OP (251, unused_251
, NULL
, NOP
)
3205 VM_DEFINE_OP (252, unused_252
, NULL
, NOP
)
3206 VM_DEFINE_OP (253, unused_253
, NULL
, NOP
)
3207 VM_DEFINE_OP (254, unused_254
, NULL
, NOP
)
3208 VM_DEFINE_OP (255, unused_255
, NULL
, NOP
)
3210 vm_error_bad_instruction (op
);
3211 abort (); /* never reached */
3214 END_DISPATCH_SWITCH
;
3218 #undef ABORT_CONTINUATION_HOOK
3223 #undef BEGIN_DISPATCH_SWITCH
3224 #undef BINARY_INTEGER_OP
3225 #undef BR_ARITHMETIC
3229 #undef BV_FIXABLE_INT_REF
3230 #undef BV_FIXABLE_INT_SET
3235 #undef CACHE_REGISTER
3236 #undef END_DISPATCH_SWITCH
3237 #undef FREE_VARIABLE_REF
3246 #undef POP_CONTINUATION_HOOK
3247 #undef PUSH_CONTINUATION_HOOK
3249 #undef RETURN_ONE_VALUE
3250 #undef RETURN_VALUE_LIST
3260 #undef VARIABLE_BOUNDP
3263 #undef VM_CHECK_FREE_VARIABLE
3264 #undef VM_CHECK_OBJECT
3265 #undef VM_CHECK_UNDERFLOW
3267 #undef VM_INSTRUCTION_TO_LABEL
3269 #undef VM_VALIDATE_BYTEVECTOR
3270 #undef VM_VALIDATE_PAIR
3271 #undef VM_VALIDATE_STRUCT
3274 (defun renumber-ops ()
3275 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3278 (let ((counter -1)) (goto-char (point-min))
3279 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3281 (number-to-string (setq counter (1+ counter)))