1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* This file is included in vm.c multiple times. */
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)) \
112 #define RUN_HOOK(exp)
114 #define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
115 #define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
117 #define APPLY_HOOK() \
119 #define PUSH_CONTINUATION_HOOK() \
120 RUN_HOOK0 (push_continuation)
121 #define POP_CONTINUATION_HOOK(old_fp) \
122 RUN_HOOK1 (pop_continuation, old_fp)
123 #define NEXT_HOOK() \
125 #define ABORT_CONTINUATION_HOOK() \
127 #define RESTORE_CONTINUATION_HOOK() \
128 RUN_HOOK0 (restore_continuation)
130 #define VM_HANDLE_INTERRUPTS \
131 SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
136 This is Guile's new virtual machine. When I say "new", I mean
137 relative to the current virtual machine. At some point it will
138 become "the" virtual machine, and we'll delete this paragraph. As
139 such, the rest of the comments speak as if there's only one VM.
140 In difference from the old VM, local 0 is the procedure, and the
141 first argument is local 1. At some point in the future we should
142 change the fp to point to the procedure and not to local 1.
148 /* The VM has three state bits: the instruction pointer (IP), the frame
149 pointer (FP), and the top-of-stack pointer (SP). We cache the first
150 two of these in machine registers, local to the VM, because they are
151 used extensively by the VM. As the SP is used more by code outside
152 the VM than by the VM itself, we don't bother caching it locally.
154 Since the FP changes infrequently, relative to the IP, we keep vp->fp
155 in sync with the local FP. This would be a big lose for the IP,
156 though, so instead of updating vp->ip all the time, we call SYNC_IP
157 whenever we would need to know the IP of the top frame. In practice,
158 we need to SYNC_IP whenever we call out of the VM to a function that
159 would like to walk the stack, perhaps as the result of an
165 #define SYNC_REGISTER() \
167 #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
168 #define SYNC_ALL() /* FP already saved */ \
171 /* After advancing vp->sp, but before writing any stack slots, check
172 that it is actually in bounds. If it is not in bounds, currently we
173 signal an error. In the future we may expand the stack instead,
174 possibly by moving it elsewhere, therefore no pointer into the stack
175 besides FP is valid across a CHECK_OVERFLOW call. Be careful! */
176 #define CHECK_OVERFLOW() \
178 if (SCM_UNLIKELY (vp->sp >= vp->stack_limit)) \
180 vm_error_stack_overflow (vp); \
185 /* Reserve stack space for a frame. Will check that there is sufficient
186 stack space for N locals, including the procedure. Invoke after
187 preparing the new frame and setting the fp and ip. */
188 #define ALLOC_FRAME(n) \
190 vp->sp = LOCAL_ADDRESS (n - 1); \
194 /* Reset the current frame to hold N locals. Used when we know that no
195 stack expansion is needed. */
196 #define RESET_FRAME(n) \
198 vp->sp = LOCAL_ADDRESS (n - 1); \
201 /* Compute the number of locals in the frame. At a call, this is equal
202 to the number of actual arguments when a function is first called,
203 plus one for the function. */
204 #define FRAME_LOCALS_COUNT_FROM(slot) \
205 (vp->sp + 1 - LOCAL_ADDRESS (slot))
206 #define FRAME_LOCALS_COUNT() \
207 FRAME_LOCALS_COUNT_FROM (0)
209 /* Restore registers after returning from a frame. */
210 #define RESTORE_FRAME() \
215 #define CACHE_REGISTER() \
217 ip = (scm_t_uint32 *) vp->ip; \
221 #ifdef HAVE_LABELS_AS_VALUES
222 # define BEGIN_DISPATCH_SWITCH /* */
223 # define END_DISPATCH_SWITCH /* */
230 goto *jump_table[op & 0xff]; \
233 # define VM_DEFINE_OP(opcode, tag, name, meta) \
236 # define BEGIN_DISPATCH_SWITCH \
242 # define END_DISPATCH_SWITCH \
244 goto vm_error_bad_instruction; \
253 # define VM_DEFINE_OP(opcode, tag, name, meta) \
258 #define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
259 #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
260 #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
262 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
263 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
264 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
266 #define RETURN_ONE_VALUE(ret) \
270 VM_HANDLE_INTERRUPTS; \
271 ip = SCM_FRAME_RETURN_ADDRESS (fp); \
272 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
274 old_fp[-1] = SCM_BOOL_F; \
275 old_fp[-2] = SCM_BOOL_F; \
277 SCM_FRAME_LOCAL (old_fp, 1) = val; \
278 vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
279 POP_CONTINUATION_HOOK (old_fp); \
283 /* While we could generate the list-unrolling code here, it's fine for
284 now to just tail-call (apply values vals). */
285 #define RETURN_VALUE_LIST(vals_) \
288 VM_HANDLE_INTERRUPTS; \
289 fp[0] = vm_builtin_apply; \
290 fp[1] = vm_builtin_values; \
293 ip = (scm_t_uint32 *) vm_builtin_apply_code; \
294 goto op_tail_apply; \
297 #define BR_NARGS(rel) \
298 scm_t_uint32 expected; \
299 UNPACK_24 (op, expected); \
300 if (FRAME_LOCALS_COUNT() rel expected) \
302 scm_t_int32 offset = ip[1]; \
303 offset >>= 8; /* Sign-extending shift. */ \
308 #define BR_UNARY(x, exp) \
311 UNPACK_24 (op, test); \
312 x = LOCAL_REF (test); \
313 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
315 scm_t_int32 offset = ip[1]; \
316 offset >>= 8; /* Sign-extending shift. */ \
318 VM_HANDLE_INTERRUPTS; \
323 #define BR_BINARY(x, y, exp) \
326 UNPACK_12_12 (op, a, b); \
329 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
331 scm_t_int32 offset = ip[1]; \
332 offset >>= 8; /* Sign-extending shift. */ \
334 VM_HANDLE_INTERRUPTS; \
339 #define BR_ARITHMETIC(crel,srel) \
343 UNPACK_12_12 (op, a, b); \
346 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
348 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
349 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
350 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
352 scm_t_int32 offset = ip[1]; \
353 offset >>= 8; /* Sign-extending shift. */ \
355 VM_HANDLE_INTERRUPTS; \
365 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
367 scm_t_int32 offset = ip[1]; \
368 offset >>= 8; /* Sign-extending shift. */ \
370 VM_HANDLE_INTERRUPTS; \
378 scm_t_uint16 dst, src; \
380 UNPACK_12_12 (op, dst, src); \
382 #define ARGS2(a1, a2) \
383 scm_t_uint8 dst, src1, src2; \
385 UNPACK_8_8_8 (op, dst, src1, src2); \
386 a1 = LOCAL_REF (src1); \
387 a2 = LOCAL_REF (src2)
389 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
391 /* The maximum/minimum tagged integers. */
393 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
395 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
397 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
398 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
400 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
403 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
405 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
406 if (SCM_FIXABLE (n)) \
407 RETURN (SCM_I_MAKINUM (n)); \
410 RETURN (SFUNC (x, y)); \
413 #define VM_VALIDATE_PAIR(x, proc) \
414 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
416 #define VM_VALIDATE_STRUCT(obj, proc) \
417 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
419 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
420 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
422 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
423 #define ALIGNED_P(ptr, type) \
424 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
427 VM_NAME (scm_i_thread
*current_thread
, struct scm_vm
*vp
)
429 /* Instruction pointer: A pointer to the opcode that is currently
431 register scm_t_uint32
*ip IP_REG
;
433 /* Frame pointer: A pointer into the stack, off of which we index
434 arguments and local variables. Pushed at function calls, popped on
436 register SCM
*fp FP_REG
;
438 /* Current opcode: A cache of *ip. */
439 register scm_t_uint32 op
;
441 /* Cached variables. */
442 scm_i_jmp_buf registers
; /* used for prompts */
444 #ifdef HAVE_LABELS_AS_VALUES
445 static const void **jump_table_pointer
= NULL
;
446 register const void **jump_table JT_REG
;
448 if (SCM_UNLIKELY (!jump_table_pointer
))
451 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
452 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
453 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
454 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
455 FOR_EACH_VM_OPERATION(INIT
);
459 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
460 load instruction at each instruction dispatch. */
461 jump_table
= jump_table_pointer
;
464 if (SCM_I_SETJMP (registers
))
466 /* Non-local return. The values are on the stack, on a new frame
467 set up to call `values' to return the values to the handler.
468 Cache the VM registers back from the vp, and dispatch to the
471 Note, at this point, we must assume that any variable local to
472 vm_engine that can be assigned *has* been assigned. So we need
473 to pull all our state back from the ip/fp/sp.
476 ABORT_CONTINUATION_HOOK ();
480 /* Load VM registers. */
483 VM_HANDLE_INTERRUPTS
;
486 while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
488 SCM proc
= SCM_FRAME_PROGRAM (fp
);
490 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
492 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
495 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
497 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
499 /* Shuffle args up. */
502 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
504 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
509 vm_error_wrong_type_apply (proc
);
513 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
516 BEGIN_DISPATCH_SWITCH
;
527 * Bring the VM to a halt, returning all the values from the stack.
529 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
531 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
533 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
543 for (n
= nvals
; n
> 0; n
--)
544 ret
= scm_cons (LOCAL_REF (4 + n
- 1), ret
);
545 ret
= scm_values (ret
);
548 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
549 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
550 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
555 /* call proc:24 _:8 nlocals:24
557 * Call a procedure. PROC is the local corresponding to a procedure.
558 * The three values below PROC will be overwritten by the saved call
559 * frame data. The new frame will have space for NLOCALS locals: one
560 * for the procedure, and the rest for the arguments which should
561 * already have been pushed on.
563 * When the call returns, execution proceeds with the next
564 * instruction. There may be any number of values on the return
565 * stack; the precise number can be had by subtracting the address of
566 * PROC from the post-call SP.
568 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
570 scm_t_uint32 proc
, nlocals
;
573 UNPACK_24 (op
, proc
);
574 UNPACK_24 (ip
[1], nlocals
);
576 VM_HANDLE_INTERRUPTS
;
578 fp
= vp
->fp
= old_fp
+ proc
;
579 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
580 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
582 RESET_FRAME (nlocals
);
584 PUSH_CONTINUATION_HOOK ();
587 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
590 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
594 /* tail-call nlocals:24
596 * Tail-call a procedure. Requires that the procedure and all of the
597 * arguments have already been shuffled into position. Will reset the
600 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
602 scm_t_uint32 nlocals
;
604 UNPACK_24 (op
, nlocals
);
606 VM_HANDLE_INTERRUPTS
;
608 RESET_FRAME (nlocals
);
612 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
615 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
619 /* tail-call/shuffle from:24
621 * Tail-call a procedure. The procedure should already be set to slot
622 * 0. The rest of the args are taken from the frame, starting at
623 * FROM, shuffled down to start at slot 0. This is part of the
624 * implementation of the call-with-values builtin.
626 VM_DEFINE_OP (3, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
628 scm_t_uint32 n
, from
, nlocals
;
630 UNPACK_24 (op
, from
);
632 VM_HANDLE_INTERRUPTS
;
634 VM_ASSERT (from
> 0, abort ());
635 nlocals
= FRAME_LOCALS_COUNT ();
637 for (n
= 0; from
+ n
< nlocals
; n
++)
638 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
644 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
647 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
651 /* receive dst:12 proc:12 _:8 nlocals:24
653 * Receive a single return value from a call whose procedure was in
654 * PROC, asserting that the call actually returned at least one
655 * value. Afterwards, resets the frame to NLOCALS locals.
657 VM_DEFINE_OP (4, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
659 scm_t_uint16 dst
, proc
;
660 scm_t_uint32 nlocals
;
661 UNPACK_12_12 (op
, dst
, proc
);
662 UNPACK_24 (ip
[1], nlocals
);
663 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
664 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
665 RESET_FRAME (nlocals
);
669 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
671 * Receive a return of multiple values from a call whose procedure was
672 * in PROC. If fewer than NVALUES values were returned, signal an
673 * error. Unless ALLOW-EXTRA? is true, require that the number of
674 * return values equals NVALUES exactly. After receive-values has
675 * run, the values can be copied down via `mov'.
677 VM_DEFINE_OP (5, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
679 scm_t_uint32 proc
, nvalues
;
680 UNPACK_24 (op
, proc
);
681 UNPACK_24 (ip
[1], nvalues
);
683 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
684 vm_error_not_enough_values ());
686 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
687 vm_error_wrong_number_of_values (nvalues
));
695 VM_DEFINE_OP (6, return, "return", OP1 (U8_U24
))
699 RETURN_ONE_VALUE (LOCAL_REF (src
));
702 /* return-values _:24
704 * Return a number of values from a call frame. This opcode
705 * corresponds to an application of `values' in tail position. As
706 * with tail calls, we expect that the values have already been
707 * shuffled down to a contiguous array starting at slot 1.
708 * We also expect the frame has already been reset.
710 VM_DEFINE_OP (7, return_values
, "return-values", OP1 (U8_X24
))
714 VM_HANDLE_INTERRUPTS
;
715 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
716 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
718 /* Clear stack frame. */
719 old_fp
[-1] = SCM_BOOL_F
;
720 old_fp
[-2] = SCM_BOOL_F
;
722 POP_CONTINUATION_HOOK (old_fp
);
731 * Specialized call stubs
734 /* subr-call ptr-idx:24
736 * Call a subr, passing all locals in this frame as arguments. Fetch
737 * the foreign pointer from PTR-IDX, a free variable. Return from the
738 * calling frame. This instruction is part of the trampolines
739 * created in gsubr.c, and is not generated by the compiler.
741 VM_DEFINE_OP (8, subr_call
, "subr-call", OP1 (U8_U24
))
743 scm_t_uint32 ptr_idx
;
747 UNPACK_24 (op
, ptr_idx
);
749 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
750 subr
= SCM_POINTER_VALUE (pointer
);
752 VM_HANDLE_INTERRUPTS
;
755 switch (FRAME_LOCALS_COUNT_FROM (1))
764 ret
= subr (fp
[1], fp
[2]);
767 ret
= subr (fp
[1], fp
[2], fp
[3]);
770 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
773 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
776 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
779 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
782 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
785 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
788 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
794 // NULLSTACK_FOR_NONLOCAL_EXIT ();
796 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
797 /* multiple values returned to continuation */
798 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
800 RETURN_ONE_VALUE (ret
);
803 /* foreign-call cif-idx:12 ptr-idx:12
805 * Call a foreign function. Fetch the CIF and foreign pointer from
806 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
807 * frame. Arguments are taken from the stack. This instruction is
808 * part of the trampolines created by the FFI, and is not generated by
811 VM_DEFINE_OP (9, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
813 scm_t_uint16 cif_idx
, ptr_idx
;
814 SCM closure
, cif
, pointer
, ret
;
816 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
818 closure
= LOCAL_REF (0);
819 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
820 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
823 VM_HANDLE_INTERRUPTS
;
825 // FIXME: separate args
826 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), LOCAL_ADDRESS (1));
828 // NULLSTACK_FOR_NONLOCAL_EXIT ();
830 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
831 /* multiple values returned to continuation */
832 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
834 RETURN_ONE_VALUE (ret
);
837 /* continuation-call contregs:24
839 * Return to a continuation, nonlocally. The arguments to the
840 * continuation are taken from the stack. CONTREGS is a free variable
841 * containing the reified continuation. This instruction is part of
842 * the implementation of undelimited continuations, and is not
843 * generated by the compiler.
845 VM_DEFINE_OP (10, continuation_call
, "continuation-call", OP1 (U8_U24
))
848 scm_t_uint32 contregs_idx
;
850 UNPACK_24 (op
, contregs_idx
);
853 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
856 scm_i_check_continuation (contregs
);
857 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
858 scm_i_contregs_vm_cont (contregs
),
859 FRAME_LOCALS_COUNT_FROM (1),
861 scm_i_reinstate_continuation (contregs
);
867 /* compose-continuation cont:24
869 * Compose a partial continution with the current continuation. The
870 * arguments to the continuation are taken from the stack. CONT is a
871 * free variable containing the reified continuation. This
872 * instruction is part of the implementation of partial continuations,
873 * and is not generated by the compiler.
875 VM_DEFINE_OP (11, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
878 scm_t_uint32 cont_idx
;
880 UNPACK_24 (op
, cont_idx
);
881 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
884 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
885 vm_error_continuation_not_rewindable (vmcont
));
886 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
888 ¤t_thread
->dynstack
,
896 * Tail-apply the procedure in local slot 0 to the rest of the
897 * arguments. This instruction is part of the implementation of
898 * `apply', and is not generated by the compiler.
900 VM_DEFINE_OP (12, tail_apply
, "tail-apply", OP1 (U8_X24
))
902 int i
, list_idx
, list_len
, nlocals
;
905 VM_HANDLE_INTERRUPTS
;
907 nlocals
= FRAME_LOCALS_COUNT ();
908 // At a minimum, there should be apply, f, and the list.
909 VM_ASSERT (nlocals
>= 3, abort ());
910 list_idx
= nlocals
- 1;
911 list
= LOCAL_REF (list_idx
);
912 list_len
= scm_ilength (list
);
914 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
916 nlocals
= nlocals
- 2 + list_len
;
917 ALLOC_FRAME (nlocals
);
919 for (i
= 1; i
< list_idx
; i
++)
920 LOCAL_SET (i
- 1, LOCAL_REF (i
));
922 /* Null out these slots, just in case there are less than 2 elements
924 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
925 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
927 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
928 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
932 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
935 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
941 * Capture the current continuation, and tail-apply the procedure in
942 * local slot 1 to it. This instruction is part of the implementation
943 * of `call/cc', and is not generated by the compiler.
945 VM_DEFINE_OP (13, call_cc
, "call/cc", OP1 (U8_X24
))
948 scm_t_dynstack
*dynstack
;
951 VM_HANDLE_INTERRUPTS
;
954 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
955 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
956 SCM_FRAME_DYNAMIC_LINK (fp
),
957 SCM_FRAME_PREVIOUS_SP (fp
),
958 SCM_FRAME_RETURN_ADDRESS (fp
),
961 /* FIXME: Seems silly to capture the registers here, when they are
962 already captured in the registers local, which here we are
963 copying out to the heap; and likewise, the setjmp(®isters)
964 code already has the non-local return handler. But oh
966 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
970 LOCAL_SET (0, LOCAL_REF (1));
976 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
979 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
985 ABORT_CONTINUATION_HOOK ();
992 * Abort to a prompt handler. The tag is expected in r1, and the rest
993 * of the values in the frame are returned to the prompt handler.
994 * This corresponds to a tail application of abort-to-prompt.
996 VM_DEFINE_OP (14, abort
, "abort", OP1 (U8_X24
))
998 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1000 ASSERT (nlocals
>= 2);
1001 /* FIXME: Really we should capture the caller's registers. Until
1002 then, manually advance the IP so that when the prompt resumes,
1003 it continues with the next instruction. */
1006 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1007 SCM_EOL
, LOCAL_ADDRESS (0), ®isters
);
1009 /* vm_abort should not return */
1013 /* builtin-ref dst:12 idx:12
1015 * Load a builtin stub by index into DST.
1017 VM_DEFINE_OP (15, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1019 scm_t_uint16 dst
, idx
;
1021 UNPACK_12_12 (op
, dst
, idx
);
1022 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1031 * Function prologues
1034 /* br-if-nargs-ne expected:24 _:8 offset:24
1035 * br-if-nargs-lt expected:24 _:8 offset:24
1036 * br-if-nargs-gt expected:24 _:8 offset:24
1038 * If the number of actual arguments is not equal, less than, or greater
1039 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1040 * the current instruction pointer.
1042 VM_DEFINE_OP (16, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1046 VM_DEFINE_OP (17, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1050 VM_DEFINE_OP (18, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1055 /* assert-nargs-ee expected:24
1056 * assert-nargs-ge expected:24
1057 * assert-nargs-le expected:24
1059 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1060 * respectively, signal an error.
1062 VM_DEFINE_OP (19, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1064 scm_t_uint32 expected
;
1065 UNPACK_24 (op
, expected
);
1066 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1067 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1070 VM_DEFINE_OP (20, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1072 scm_t_uint32 expected
;
1073 UNPACK_24 (op
, expected
);
1074 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1075 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1078 VM_DEFINE_OP (21, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1080 scm_t_uint32 expected
;
1081 UNPACK_24 (op
, expected
);
1082 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1083 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1087 /* alloc-frame nlocals:24
1089 * Ensure that there is space on the stack for NLOCALS local variables,
1090 * setting them all to SCM_UNDEFINED, except those nargs values that
1091 * were passed as arguments and procedure.
1093 VM_DEFINE_OP (22, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1095 scm_t_uint32 nlocals
, nargs
;
1096 UNPACK_24 (op
, nlocals
);
1098 nargs
= FRAME_LOCALS_COUNT ();
1099 ALLOC_FRAME (nlocals
);
1100 while (nlocals
-- > nargs
)
1101 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1106 /* reset-frame nlocals:24
1108 * Like alloc-frame, but doesn't check that the stack is big enough.
1109 * Used to reset the frame size to something less than the size that
1110 * was previously set via alloc-frame.
1112 VM_DEFINE_OP (23, reset_frame
, "reset-frame", OP1 (U8_U24
))
1114 scm_t_uint32 nlocals
;
1115 UNPACK_24 (op
, nlocals
);
1116 RESET_FRAME (nlocals
);
1120 /* assert-nargs-ee/locals expected:12 nlocals:12
1122 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1123 * number of locals reserved is EXPECTED + NLOCALS.
1125 VM_DEFINE_OP (24, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1127 scm_t_uint16 expected
, nlocals
;
1128 UNPACK_12_12 (op
, expected
, nlocals
);
1129 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1130 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1131 ALLOC_FRAME (expected
+ nlocals
);
1133 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1138 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1140 * Find the first positional argument after NREQ. If it is greater
1141 * than NPOS, jump to OFFSET.
1143 * This instruction is only emitted for functions with multiple
1144 * clauses, and an earlier clause has keywords and no rest arguments.
1145 * See "Case-lambda" in the manual, for more on how case-lambda
1146 * chooses the clause to apply.
1148 VM_DEFINE_OP (25, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1150 scm_t_uint32 nreq
, npos
;
1152 UNPACK_24 (op
, nreq
);
1153 UNPACK_24 (ip
[1], npos
);
1155 /* We can only have too many positionals if there are more
1156 arguments than NPOS. */
1157 if (FRAME_LOCALS_COUNT() > npos
)
1160 for (n
= nreq
; n
< npos
; n
++)
1161 if (scm_is_keyword (LOCAL_REF (n
)))
1163 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1165 scm_t_int32 offset
= ip
[2];
1166 offset
>>= 8; /* Sign-extending shift. */
1173 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1174 * _:8 ntotal:24 kw-offset:32
1176 * Find the last positional argument, and shuffle all the rest above
1177 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1178 * load the constant at KW-OFFSET words from the current IP, and use it
1179 * to bind keyword arguments. If HAS-REST, collect all shuffled
1180 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1181 * the arguments that we shuffled up.
1183 * A macro-mega-instruction.
1185 VM_DEFINE_OP (26, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1187 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1188 scm_t_int32 kw_offset
;
1191 char allow_other_keys
, has_rest
;
1193 UNPACK_24 (op
, nreq
);
1194 allow_other_keys
= ip
[1] & 0x1;
1195 has_rest
= ip
[1] & 0x2;
1196 UNPACK_24 (ip
[1], nreq_and_opt
);
1197 UNPACK_24 (ip
[2], ntotal
);
1199 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1200 VM_ASSERT (!(kw_bits
& 0x7), abort());
1201 kw
= SCM_PACK (kw_bits
);
1203 nargs
= FRAME_LOCALS_COUNT ();
1205 /* look in optionals for first keyword or last positional */
1206 /* starting after the last required positional arg */
1208 while (/* while we have args */
1210 /* and we still have positionals to fill */
1211 && npositional
< nreq_and_opt
1212 /* and we haven't reached a keyword yet */
1213 && !scm_is_keyword (LOCAL_REF (npositional
)))
1214 /* bind this optional arg (by leaving it in place) */
1216 nkw
= nargs
- npositional
;
1217 /* shuffle non-positional arguments above ntotal */
1218 ALLOC_FRAME (ntotal
+ nkw
);
1221 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1222 /* and fill optionals & keyword args with SCM_UNDEFINED */
1225 LOCAL_SET (n
++, SCM_UNDEFINED
);
1227 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1228 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1230 /* Now bind keywords, in the order given. */
1231 for (n
= 0; n
< nkw
; n
++)
1232 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1235 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1236 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1238 SCM si
= SCM_CDAR (walk
);
1239 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1240 LOCAL_REF (ntotal
+ n
+ 1));
1243 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1244 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1245 LOCAL_REF (ntotal
+ n
)));
1249 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1250 LOCAL_REF (ntotal
+ n
)));
1257 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1258 LOCAL_SET (nreq_and_opt
, rest
);
1261 RESET_FRAME (ntotal
);
1268 * Collect any arguments at or above DST into a list, and store that
1271 VM_DEFINE_OP (27, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1273 scm_t_uint32 dst
, nargs
;
1276 UNPACK_24 (op
, dst
);
1277 nargs
= FRAME_LOCALS_COUNT ();
1281 ALLOC_FRAME (dst
+ 1);
1283 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1287 while (nargs
-- > dst
)
1289 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1290 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1293 RESET_FRAME (dst
+ 1);
1296 LOCAL_SET (dst
, rest
);
1305 * Branching instructions
1310 * Add OFFSET, a signed 24-bit number, to the current instruction
1313 VM_DEFINE_OP (28, br
, "br", OP1 (U8_L24
))
1315 scm_t_int32 offset
= op
;
1316 offset
>>= 8; /* Sign-extending shift. */
1320 /* br-if-true test:24 invert:1 _:7 offset:24
1322 * If the value in TEST is true for the purposes of Scheme, add
1323 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1325 VM_DEFINE_OP (29, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1327 BR_UNARY (x
, scm_is_true (x
));
1330 /* br-if-null test:24 invert:1 _:7 offset:24
1332 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1333 * signed 24-bit number, to the current instruction pointer.
1335 VM_DEFINE_OP (30, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1337 BR_UNARY (x
, scm_is_null (x
));
1340 /* br-if-nil test:24 invert:1 _:7 offset:24
1342 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1343 * number, to the current instruction pointer.
1345 VM_DEFINE_OP (31, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1347 BR_UNARY (x
, scm_is_lisp_false (x
));
1350 /* br-if-pair test:24 invert:1 _:7 offset:24
1352 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1353 * to the current instruction pointer.
1355 VM_DEFINE_OP (32, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1357 BR_UNARY (x
, scm_is_pair (x
));
1360 /* br-if-struct test:24 invert:1 _:7 offset:24
1362 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1363 * number, to the current instruction pointer.
1365 VM_DEFINE_OP (33, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1367 BR_UNARY (x
, SCM_STRUCTP (x
));
1370 /* br-if-char test:24 invert:1 _:7 offset:24
1372 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1373 * to the current instruction pointer.
1375 VM_DEFINE_OP (34, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1377 BR_UNARY (x
, SCM_CHARP (x
));
1380 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1382 * If the value in TEST has the TC7 given in the second word, add
1383 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1385 VM_DEFINE_OP (35, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1387 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1390 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1392 * If the value in A is eq? to the value in B, add OFFSET, a signed
1393 * 24-bit number, to the current instruction pointer.
1395 VM_DEFINE_OP (36, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1397 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1400 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1402 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1403 * 24-bit number, to the current instruction pointer.
1405 VM_DEFINE_OP (37, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1409 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1410 && scm_is_true (scm_eqv_p (x
, y
))));
1413 // FIXME: remove, have compiler inline eqv test instead
1414 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1416 * If the value in A is equal? to the value in B, add OFFSET, a signed
1417 * 24-bit number, to the current instruction pointer.
1419 // FIXME: should sync_ip before calling out?
1420 VM_DEFINE_OP (38, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1424 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1425 && scm_is_true (scm_equal_p (x
, y
))));
1428 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1430 * If the value in A is = to the value in B, add OFFSET, a signed
1431 * 24-bit number, to the current instruction pointer.
1433 VM_DEFINE_OP (39, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1435 BR_ARITHMETIC (==, scm_num_eq_p
);
1438 /* br-if-< a:12 b:12 _:8 offset:24
1440 * If the value in A is < to the value in B, add OFFSET, a signed
1441 * 24-bit number, to the current instruction pointer.
1443 VM_DEFINE_OP (40, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1445 BR_ARITHMETIC (<, scm_less_p
);
1448 /* br-if-<= a:12 b:12 _:8 offset:24
1450 * If the value in A is <= to the value in B, add OFFSET, a signed
1451 * 24-bit number, to the current instruction pointer.
1453 VM_DEFINE_OP (41, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1455 BR_ARITHMETIC (<=, scm_leq_p
);
1462 * Lexical binding instructions
1465 /* mov dst:12 src:12
1467 * Copy a value from one local slot to another.
1469 VM_DEFINE_OP (42, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1474 UNPACK_12_12 (op
, dst
, src
);
1475 LOCAL_SET (dst
, LOCAL_REF (src
));
1480 /* long-mov dst:24 _:8 src:24
1482 * Copy a value from one local slot to another.
1484 VM_DEFINE_OP (43, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1489 UNPACK_24 (op
, dst
);
1490 UNPACK_24 (ip
[1], src
);
1491 LOCAL_SET (dst
, LOCAL_REF (src
));
1496 /* box dst:12 src:12
1498 * Create a new variable holding SRC, and place it in DST.
1500 VM_DEFINE_OP (44, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1502 scm_t_uint16 dst
, src
;
1503 UNPACK_12_12 (op
, dst
, src
);
1504 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1508 /* box-ref dst:12 src:12
1510 * Unpack the variable at SRC into DST, asserting that the variable is
1513 VM_DEFINE_OP (45, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1515 scm_t_uint16 dst
, src
;
1517 UNPACK_12_12 (op
, dst
, src
);
1518 var
= LOCAL_REF (src
);
1519 VM_ASSERT (SCM_VARIABLEP (var
),
1520 vm_error_not_a_variable ("variable-ref", var
));
1521 VM_ASSERT (VARIABLE_BOUNDP (var
),
1522 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1523 LOCAL_SET (dst
, VARIABLE_REF (var
));
1527 /* box-set! dst:12 src:12
1529 * Set the contents of the variable at DST to SET.
1531 VM_DEFINE_OP (46, box_set
, "box-set!", OP1 (U8_U12_U12
))
1533 scm_t_uint16 dst
, src
;
1535 UNPACK_12_12 (op
, dst
, src
);
1536 var
= LOCAL_REF (dst
);
1537 VM_ASSERT (SCM_VARIABLEP (var
),
1538 vm_error_not_a_variable ("variable-set!", var
));
1539 VARIABLE_SET (var
, LOCAL_REF (src
));
1543 /* make-closure dst:24 offset:32 _:8 nfree:24
1545 * Make a new closure, and write it to DST. The code for the closure
1546 * will be found at OFFSET words from the current IP. OFFSET is a
1547 * signed 32-bit integer. Space for NFREE free variables will be
1550 VM_DEFINE_OP (47, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1552 scm_t_uint32 dst
, nfree
, n
;
1556 UNPACK_24 (op
, dst
);
1558 UNPACK_24 (ip
[2], nfree
);
1560 // FIXME: Assert range of nfree?
1561 closure
= scm_words (scm_tc7_program
| (nfree
<< 16), nfree
+ 2);
1562 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1563 // FIXME: Elide these initializations?
1564 for (n
= 0; n
< nfree
; n
++)
1565 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1566 LOCAL_SET (dst
, closure
);
1570 /* free-ref dst:12 src:12 _:8 idx:24
1572 * Load free variable IDX from the closure SRC into local slot DST.
1574 VM_DEFINE_OP (48, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1576 scm_t_uint16 dst
, src
;
1578 UNPACK_12_12 (op
, dst
, src
);
1579 UNPACK_24 (ip
[1], idx
);
1580 /* CHECK_FREE_VARIABLE (src); */
1581 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1585 /* free-set! dst:12 src:12 _8 idx:24
1587 * Set free variable IDX from the closure DST to SRC.
1589 VM_DEFINE_OP (49, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1591 scm_t_uint16 dst
, src
;
1593 UNPACK_12_12 (op
, dst
, src
);
1594 UNPACK_24 (ip
[1], idx
);
1595 /* CHECK_FREE_VARIABLE (src); */
1596 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1604 * Immediates and statically allocated non-immediates
1607 /* make-short-immediate dst:8 low-bits:16
1609 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1612 VM_DEFINE_OP (50, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1617 UNPACK_8_16 (op
, dst
, val
);
1618 LOCAL_SET (dst
, SCM_PACK (val
));
1622 /* make-long-immediate dst:24 low-bits:32
1624 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1627 VM_DEFINE_OP (51, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1632 UNPACK_24 (op
, dst
);
1634 LOCAL_SET (dst
, SCM_PACK (val
));
1638 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1640 * Make an immediate with HIGH-BITS and LOW-BITS.
1642 VM_DEFINE_OP (52, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1647 UNPACK_24 (op
, dst
);
1648 #if SIZEOF_SCM_T_BITS > 4
1653 ASSERT (ip
[1] == 0);
1656 LOCAL_SET (dst
, SCM_PACK (val
));
1660 /* make-non-immediate dst:24 offset:32
1662 * Load a pointer to statically allocated memory into DST. The
1663 * object's memory is will be found OFFSET 32-bit words away from the
1664 * current instruction pointer. OFFSET is a signed value. The
1665 * intention here is that the compiler would produce an object file
1666 * containing the words of a non-immediate object, and this
1667 * instruction creates a pointer to that memory, effectively
1668 * resurrecting that object.
1670 * Whether the object is mutable or immutable depends on where it was
1671 * allocated by the compiler, and loaded by the loader.
1673 VM_DEFINE_OP (53, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1678 scm_t_bits unpacked
;
1680 UNPACK_24 (op
, dst
);
1683 unpacked
= (scm_t_bits
) loc
;
1685 VM_ASSERT (!(unpacked
& 0x7), abort());
1687 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1692 /* static-ref dst:24 offset:32
1694 * Load a SCM value into DST. The SCM value will be fetched from
1695 * memory, OFFSET 32-bit words away from the current instruction
1696 * pointer. OFFSET is a signed value.
1698 * The intention is for this instruction to be used to load constants
1699 * that the compiler is unable to statically allocate, like symbols.
1700 * These values would be initialized when the object file loads.
1702 VM_DEFINE_OP (54, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
1707 scm_t_uintptr loc_bits
;
1709 UNPACK_24 (op
, dst
);
1712 loc_bits
= (scm_t_uintptr
) loc
;
1713 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1715 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1720 /* static-set! src:24 offset:32
1722 * Store a SCM value into memory, OFFSET 32-bit words away from the
1723 * current instruction pointer. OFFSET is a signed value.
1725 VM_DEFINE_OP (55, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1731 UNPACK_24 (op
, src
);
1734 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1736 *((SCM
*) loc
) = LOCAL_REF (src
);
1741 /* static-patch! _:24 dst-offset:32 src-offset:32
1743 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1744 * are signed 32-bit values, indicating a memory address as a number
1745 * of 32-bit words away from the current instruction pointer.
1747 VM_DEFINE_OP (56, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1749 scm_t_int32 dst_offset
, src_offset
;
1756 dst_loc
= (void **) (ip
+ dst_offset
);
1757 src
= ip
+ src_offset
;
1758 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1768 * Mutable top-level bindings
1771 /* There are three slightly different ways to resolve toplevel
1774 1. A toplevel reference outside of a function. These need to be
1775 looked up when the expression is evaluated -- no later, and no
1776 before. They are looked up relative to the module that is
1777 current when the expression is evaluated. For example:
1781 The "resolve" instruction resolves the variable (box), and then
1782 access is via box-ref or box-set!.
1784 2. A toplevel reference inside a function. These are looked up
1785 relative to the module that was current when the function was
1786 defined. Unlike code at the toplevel, which is usually run only
1787 once, these bindings benefit from memoized lookup, in which the
1788 variable resulting from the lookup is cached in the function.
1790 (lambda () (if (foo) a b))
1792 The toplevel-box instruction is equivalent to "resolve", but
1793 caches the resulting variable in statically allocated memory.
1795 3. A reference to an identifier with respect to a particular
1796 module. This can happen for primitive references, and
1797 references residualized by macro expansions. These can always
1798 be cached. Use module-box for these.
1801 /* current-module dst:24
1803 * Store the current module in DST.
1805 VM_DEFINE_OP (57, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1809 UNPACK_24 (op
, dst
);
1812 LOCAL_SET (dst
, scm_current_module ());
1817 /* resolve dst:24 bound?:1 _:7 sym:24
1819 * Resolve SYM in the current module, and place the resulting variable
1822 VM_DEFINE_OP (58, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1828 UNPACK_24 (op
, dst
);
1829 UNPACK_24 (ip
[1], sym
);
1832 var
= scm_lookup (LOCAL_REF (sym
));
1834 VM_ASSERT (VARIABLE_BOUNDP (var
),
1835 vm_error_unbound (fp
[0], LOCAL_REF (sym
)));
1836 LOCAL_SET (dst
, var
);
1841 /* define! sym:12 val:12
1843 * Look up a binding for SYM in the current module, creating it if
1844 * necessary. Set its value to VAL.
1846 VM_DEFINE_OP (59, define
, "define!", OP1 (U8_U12_U12
))
1848 scm_t_uint16 sym
, val
;
1849 UNPACK_12_12 (op
, sym
, val
);
1851 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1855 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1857 * Load a SCM value. The SCM value will be fetched from memory,
1858 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1859 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1862 * Then, if the loaded value is a variable, it is placed in DST, and control
1865 * Otherwise, we have to resolve the variable. In that case we load
1866 * the module from MOD-OFFSET, just as we loaded the variable.
1867 * Usually the module gets set when the closure is created. The name
1868 * is an offset to a symbol.
1870 * We use the module and the symbol to resolve the variable, placing it in
1871 * DST, and caching the resolved variable so that we will hit the cache next
1874 VM_DEFINE_OP (60, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1877 scm_t_int32 var_offset
;
1878 scm_t_uint32
* var_loc_u32
;
1882 UNPACK_24 (op
, dst
);
1884 var_loc_u32
= ip
+ var_offset
;
1885 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1886 var_loc
= (SCM
*) var_loc_u32
;
1889 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1892 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1893 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1894 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1895 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1899 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1900 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1902 mod
= *((SCM
*) mod_loc
);
1903 sym
= *((SCM
*) sym_loc
);
1905 /* If the toplevel scope was captured before modules were
1906 booted, use the root module. */
1907 if (scm_is_false (mod
))
1908 mod
= scm_the_root_module ();
1910 var
= scm_module_lookup (mod
, sym
);
1912 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1917 LOCAL_SET (dst
, var
);
1921 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1923 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1924 * instead of the module itself.
1926 VM_DEFINE_OP (61, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1929 scm_t_int32 var_offset
;
1930 scm_t_uint32
* var_loc_u32
;
1934 UNPACK_24 (op
, dst
);
1936 var_loc_u32
= ip
+ var_offset
;
1937 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1938 var_loc
= (SCM
*) var_loc_u32
;
1941 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1944 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1945 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1946 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
1947 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1951 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
1952 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1954 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
1955 sym
= *((SCM
*) sym_loc
);
1957 if (!scm_module_system_booted_p
)
1959 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
1962 scm_equal_p (modname
,
1963 scm_list_2 (SCM_BOOL_T
,
1964 scm_from_utf8_symbol ("guile"))));
1966 var
= scm_lookup (sym
);
1968 else if (scm_is_true (SCM_CAR (modname
)))
1969 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
1971 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
1974 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1979 LOCAL_SET (dst
, var
);
1986 * The dynamic environment
1989 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
1991 * Push a new prompt on the dynamic stack, with a tag from TAG and a
1992 * handler at HANDLER-OFFSET words from the current IP. The handler
1993 * will expect a multiple-value return as if from a call with the
1994 * procedure at PROC-SLOT.
1996 VM_DEFINE_OP (62, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
1998 scm_t_uint32 tag
, proc_slot
;
2000 scm_t_uint8 escape_only_p
;
2001 scm_t_dynstack_prompt_flags flags
;
2003 UNPACK_24 (op
, tag
);
2004 escape_only_p
= ip
[1] & 0x1;
2005 UNPACK_24 (ip
[1], proc_slot
);
2007 offset
>>= 8; /* Sign extension */
2009 /* Push the prompt onto the dynamic stack. */
2010 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2011 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2013 fp
- vp
->stack_base
,
2014 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2020 /* wind winder:12 unwinder:12
2022 * Push wind and unwind procedures onto the dynamic stack. Note that
2023 * neither are actually called; the compiler should emit calls to wind
2024 * and unwind for the normal dynamic-wind control flow. Also note that
2025 * the compiler should have inserted checks that they wind and unwind
2026 * procs are thunks, if it could not prove that to be the case.
2028 VM_DEFINE_OP (63, wind
, "wind", OP1 (U8_U12_U12
))
2030 scm_t_uint16 winder
, unwinder
;
2031 UNPACK_12_12 (op
, winder
, unwinder
);
2032 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2033 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2039 * A normal exit from the dynamic extent of an expression. Pop the top
2040 * entry off of the dynamic stack.
2042 VM_DEFINE_OP (64, unwind
, "unwind", OP1 (U8_X24
))
2044 scm_dynstack_pop (¤t_thread
->dynstack
);
2048 /* push-fluid fluid:12 value:12
2050 * Dynamically bind N fluids to values. The fluids are expected to be
2051 * allocated in a continguous range on the stack, starting from
2052 * FLUID-BASE. The values do not have this restriction.
2054 VM_DEFINE_OP (65, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2056 scm_t_uint32 fluid
, value
;
2058 UNPACK_12_12 (op
, fluid
, value
);
2060 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2061 LOCAL_REF (fluid
), LOCAL_REF (value
),
2062 current_thread
->dynamic_state
);
2068 * Leave the dynamic extent of a with-fluids expression, restoring the
2069 * fluids to their previous values.
2071 VM_DEFINE_OP (66, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2073 /* This function must not allocate. */
2074 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2075 current_thread
->dynamic_state
);
2079 /* fluid-ref dst:12 src:12
2081 * Reference the fluid in SRC, and place the value in DST.
2083 VM_DEFINE_OP (67, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2085 scm_t_uint16 dst
, src
;
2089 UNPACK_12_12 (op
, dst
, src
);
2090 fluid
= LOCAL_REF (src
);
2091 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2092 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2093 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2095 /* Punt dynstate expansion and error handling to the C proc. */
2097 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2101 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2102 if (scm_is_eq (val
, SCM_UNDEFINED
))
2103 val
= SCM_I_FLUID_DEFAULT (fluid
);
2104 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2105 vm_error_unbound_fluid (SCM_FRAME_PROGRAM (fp
), fluid
));
2106 LOCAL_SET (dst
, val
);
2112 /* fluid-set fluid:12 val:12
2114 * Set the value of the fluid in DST to the value in SRC.
2116 VM_DEFINE_OP (68, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2122 UNPACK_12_12 (op
, a
, b
);
2123 fluid
= LOCAL_REF (a
);
2124 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2125 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2126 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2128 /* Punt dynstate expansion and error handling to the C proc. */
2130 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2133 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2142 * Strings, symbols, and keywords
2145 /* string-length dst:12 src:12
2147 * Store the length of the string in SRC in DST.
2149 VM_DEFINE_OP (69, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2152 if (SCM_LIKELY (scm_is_string (str
)))
2153 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2157 RETURN (scm_string_length (str
));
2161 /* string-ref dst:8 src:8 idx:8
2163 * Fetch the character at position IDX in the string in SRC, and store
2166 VM_DEFINE_OP (70, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2168 scm_t_signed_bits i
= 0;
2170 if (SCM_LIKELY (scm_is_string (str
)
2171 && SCM_I_INUMP (idx
)
2172 && ((i
= SCM_I_INUM (idx
)) >= 0)
2173 && i
< scm_i_string_length (str
)))
2174 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2178 RETURN (scm_string_ref (str
, idx
));
2182 /* No string-set! instruction, as there is no good fast path there. */
2184 /* string-to-number dst:12 src:12
2186 * Parse a string in SRC to a number, and store in DST.
2188 VM_DEFINE_OP (71, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2190 scm_t_uint16 dst
, src
;
2192 UNPACK_12_12 (op
, dst
, src
);
2195 scm_string_to_number (LOCAL_REF (src
),
2196 SCM_UNDEFINED
/* radix = 10 */));
2200 /* string-to-symbol dst:12 src:12
2202 * Parse a string in SRC to a symbol, and store in DST.
2204 VM_DEFINE_OP (72, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2206 scm_t_uint16 dst
, src
;
2208 UNPACK_12_12 (op
, dst
, src
);
2210 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2214 /* symbol->keyword dst:12 src:12
2216 * Make a keyword from the symbol in SRC, and store it in DST.
2218 VM_DEFINE_OP (73, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2220 scm_t_uint16 dst
, src
;
2221 UNPACK_12_12 (op
, dst
, src
);
2223 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2233 /* cons dst:8 car:8 cdr:8
2235 * Cons CAR and CDR, and store the result in DST.
2237 VM_DEFINE_OP (74, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2240 RETURN (scm_cons (x
, y
));
2243 /* car dst:12 src:12
2245 * Place the car of SRC in DST.
2247 VM_DEFINE_OP (75, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2250 VM_VALIDATE_PAIR (x
, "car");
2251 RETURN (SCM_CAR (x
));
2254 /* cdr dst:12 src:12
2256 * Place the cdr of SRC in DST.
2258 VM_DEFINE_OP (76, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2261 VM_VALIDATE_PAIR (x
, "cdr");
2262 RETURN (SCM_CDR (x
));
2265 /* set-car! pair:12 car:12
2267 * Set the car of DST to SRC.
2269 VM_DEFINE_OP (77, set_car
, "set-car!", OP1 (U8_U12_U12
))
2273 UNPACK_12_12 (op
, a
, b
);
2276 VM_VALIDATE_PAIR (x
, "set-car!");
2281 /* set-cdr! pair:12 cdr:12
2283 * Set the cdr of DST to SRC.
2285 VM_DEFINE_OP (78, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2289 UNPACK_12_12 (op
, a
, b
);
2292 VM_VALIDATE_PAIR (x
, "set-car!");
2301 * Numeric operations
2304 /* add dst:8 a:8 b:8
2306 * Add A to B, and place the result in DST.
2308 VM_DEFINE_OP (79, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2310 BINARY_INTEGER_OP (+, scm_sum
);
2313 /* add1 dst:12 src:12
2315 * Add 1 to the value in SRC, and place the result in DST.
2317 VM_DEFINE_OP (80, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2321 /* Check for overflow. We must avoid overflow in the signed
2322 addition below, even if X is not an inum. */
2323 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2327 /* Add 1 to the integer without untagging. */
2328 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2330 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2335 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2338 /* sub dst:8 a:8 b:8
2340 * Subtract B from A, and place the result in DST.
2342 VM_DEFINE_OP (81, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2344 BINARY_INTEGER_OP (-, scm_difference
);
2347 /* sub1 dst:12 src:12
2349 * Subtract 1 from SRC, and place the result in DST.
2351 VM_DEFINE_OP (82, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2355 /* Check for overflow. We must avoid overflow in the signed
2356 subtraction below, even if X is not an inum. */
2357 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2361 /* Substract 1 from the integer without untagging. */
2362 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2364 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2369 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2372 /* mul dst:8 a:8 b:8
2374 * Multiply A and B, and place the result in DST.
2376 VM_DEFINE_OP (83, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2380 RETURN (scm_product (x
, y
));
2383 /* div dst:8 a:8 b:8
2385 * Divide A by B, and place the result in DST.
2387 VM_DEFINE_OP (84, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2391 RETURN (scm_divide (x
, y
));
2394 /* quo dst:8 a:8 b:8
2396 * Divide A by B, and place the quotient in DST.
2398 VM_DEFINE_OP (85, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2402 RETURN (scm_quotient (x
, y
));
2405 /* rem dst:8 a:8 b:8
2407 * Divide A by B, and place the remainder in DST.
2409 VM_DEFINE_OP (86, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2413 RETURN (scm_remainder (x
, y
));
2416 /* mod dst:8 a:8 b:8
2418 * Place the modulo of A by B in DST.
2420 VM_DEFINE_OP (87, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2424 RETURN (scm_modulo (x
, y
));
2427 /* ash dst:8 a:8 b:8
2429 * Shift A arithmetically by B bits, and place the result in DST.
2431 VM_DEFINE_OP (88, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2434 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2436 if (SCM_I_INUM (y
) < 0)
2437 /* Right shift, will be a fixnum. */
2438 RETURN (SCM_I_MAKINUM
2439 (SCM_SRS (SCM_I_INUM (x
),
2440 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2441 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2443 /* Left shift. See comments in scm_ash. */
2445 scm_t_signed_bits nn
, bits_to_shift
;
2447 nn
= SCM_I_INUM (x
);
2448 bits_to_shift
= SCM_I_INUM (y
);
2450 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2452 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2454 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2460 RETURN (scm_ash (x
, y
));
2463 /* logand dst:8 a:8 b:8
2465 * Place the bitwise AND of A and B into DST.
2467 VM_DEFINE_OP (89, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2470 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2471 /* Compute bitwise AND without untagging */
2472 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2474 RETURN (scm_logand (x
, y
));
2477 /* logior dst:8 a:8 b:8
2479 * Place the bitwise inclusive OR of A with B in DST.
2481 VM_DEFINE_OP (90, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2484 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2485 /* Compute bitwise OR without untagging */
2486 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2488 RETURN (scm_logior (x
, y
));
2491 /* logxor dst:8 a:8 b:8
2493 * Place the bitwise exclusive OR of A with B in DST.
2495 VM_DEFINE_OP (91, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2498 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2499 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2501 RETURN (scm_logxor (x
, y
));
2504 /* make-vector/immediate dst:8 length:8 init:8
2506 * Make a short vector of known size and write it to DST. The vector
2507 * will have space for LENGTH slots, an immediate value. They will be
2508 * filled with the value in slot INIT.
2510 VM_DEFINE_OP (92, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2512 scm_t_uint8 dst
, init
;
2513 scm_t_int32 length
, n
;
2516 UNPACK_8_8_8 (op
, dst
, length
, init
);
2518 val
= LOCAL_REF (init
);
2519 vector
= scm_words (scm_tc7_vector
| (length
<< 8), length
+ 1);
2520 for (n
= 0; n
< length
; n
++)
2521 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2522 LOCAL_SET (dst
, vector
);
2526 /* vector-length dst:12 src:12
2528 * Store the length of the vector in SRC in DST.
2530 VM_DEFINE_OP (93, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2533 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2534 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2538 RETURN (scm_vector_length (vect
));
2542 /* vector-ref dst:8 src:8 idx:8
2544 * Fetch the item at position IDX in the vector in SRC, and store it
2547 VM_DEFINE_OP (94, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2549 scm_t_signed_bits i
= 0;
2551 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2552 && SCM_I_INUMP (idx
)
2553 && ((i
= SCM_I_INUM (idx
)) >= 0)
2554 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2555 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2559 RETURN (scm_vector_ref (vect
, idx
));
2563 /* vector-ref/immediate dst:8 src:8 idx:8
2565 * Fill DST with the item IDX elements into the vector at SRC. Useful
2566 * for building data types using vectors.
2568 VM_DEFINE_OP (95, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2570 scm_t_uint8 dst
, src
, idx
;
2573 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2574 v
= LOCAL_REF (src
);
2575 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2576 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2577 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2579 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2583 /* vector-set! dst:8 idx:8 src:8
2585 * Store SRC into the vector DST at index IDX.
2587 VM_DEFINE_OP (96, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2589 scm_t_uint8 dst
, idx_var
, src
;
2591 scm_t_signed_bits i
= 0;
2593 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2594 vect
= LOCAL_REF (dst
);
2595 idx
= LOCAL_REF (idx_var
);
2596 val
= LOCAL_REF (src
);
2598 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2599 && SCM_I_INUMP (idx
)
2600 && ((i
= SCM_I_INUM (idx
)) >= 0)
2601 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2602 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2606 scm_vector_set_x (vect
, idx
, val
);
2611 /* vector-set!/immediate dst:8 idx:8 src:8
2613 * Store SRC into the vector DST at index IDX. Here IDX is an
2616 VM_DEFINE_OP (97, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2618 scm_t_uint8 dst
, idx
, src
;
2621 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2622 vect
= LOCAL_REF (dst
);
2623 val
= LOCAL_REF (src
);
2625 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2626 && idx
< SCM_I_VECTOR_LENGTH (vect
)))
2627 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2631 scm_vector_set_x (vect
, scm_from_uint8 (idx
), val
);
2643 /* struct-vtable dst:12 src:12
2645 * Store the vtable of SRC into DST.
2647 VM_DEFINE_OP (98, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2650 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2651 RETURN (SCM_STRUCT_VTABLE (obj
));
2654 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2656 * Allocate a new struct with VTABLE, and place it in DST. The struct
2657 * will be constructed with space for NFIELDS fields, which should
2658 * correspond to the field count of the VTABLE.
2660 VM_DEFINE_OP (99, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2662 scm_t_uint8 dst
, vtable
, nfields
;
2665 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2668 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2669 LOCAL_SET (dst
, ret
);
2674 /* struct-ref/immediate dst:8 src:8 idx:8
2676 * Fetch the item at slot IDX in the struct in SRC, and store it
2677 * in DST. IDX is an immediate unsigned 8-bit value.
2679 VM_DEFINE_OP (100, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2681 scm_t_uint8 dst
, src
, idx
;
2684 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2686 obj
= LOCAL_REF (src
);
2688 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2689 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2690 SCM_VTABLE_FLAG_SIMPLE
)
2691 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2692 scm_vtable_index_size
)))
2693 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2696 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2699 /* struct-set!/immediate dst:8 idx:8 src:8
2701 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2702 * unsigned 8-bit value.
2704 VM_DEFINE_OP (101, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2706 scm_t_uint8 dst
, idx
, src
;
2709 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2711 obj
= LOCAL_REF (dst
);
2712 val
= LOCAL_REF (src
);
2714 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2715 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2716 SCM_VTABLE_FLAG_SIMPLE
)
2717 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2718 SCM_VTABLE_FLAG_SIMPLE_RW
)
2719 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2720 scm_vtable_index_size
)))
2722 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2727 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2731 /* class-of dst:12 type:12
2733 * Store the vtable of SRC into DST.
2735 VM_DEFINE_OP (102, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2738 if (SCM_INSTANCEP (obj
))
2739 RETURN (SCM_CLASS_OF (obj
));
2741 RETURN (scm_class_of (obj
));
2744 /* slot-ref dst:8 src:8 idx:8
2746 * Fetch the item at slot IDX in the struct in SRC, and store it in
2747 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
2748 * index into the stack.
2750 VM_DEFINE_OP (103, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2752 scm_t_uint8 dst
, src
, idx
;
2753 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2755 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
2759 /* slot-set! dst:8 idx:8 src:8
2761 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
2762 * IDX is an 8-bit immediate value, not an index into the stack.
2764 VM_DEFINE_OP (104, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
2766 scm_t_uint8 dst
, idx
, src
;
2767 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2768 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
2776 * Arrays, packed uniform arrays, and bytevectors.
2779 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2781 * Load the contiguous typed array located at OFFSET 32-bit words away
2782 * from the instruction pointer, and store into DST. LEN is a byte
2783 * length. OFFSET is signed.
2785 VM_DEFINE_OP (105, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2787 scm_t_uint8 dst
, type
, shape
;
2791 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2795 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2801 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
2803 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2805 VM_DEFINE_OP (106, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
2807 scm_t_uint16 dst
, type
, fill
, bounds
;
2808 UNPACK_12_12 (op
, dst
, type
);
2809 UNPACK_12_12 (ip
[1], fill
, bounds
);
2811 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2812 LOCAL_REF (bounds
)));
2816 /* bv-u8-ref dst:8 src:8 idx:8
2817 * bv-s8-ref dst:8 src:8 idx:8
2818 * bv-u16-ref dst:8 src:8 idx:8
2819 * bv-s16-ref dst:8 src:8 idx:8
2820 * bv-u32-ref dst:8 src:8 idx:8
2821 * bv-s32-ref dst:8 src:8 idx:8
2822 * bv-u64-ref dst:8 src:8 idx:8
2823 * bv-s64-ref dst:8 src:8 idx:8
2824 * bv-f32-ref dst:8 src:8 idx:8
2825 * bv-f64-ref dst:8 src:8 idx:8
2827 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2828 * it in DST. All accesses use native endianness.
2830 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2832 scm_t_signed_bits i; \
2833 const scm_t_ ## type *int_ptr; \
2836 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2837 i = SCM_I_INUM (idx); \
2838 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2840 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2842 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2843 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2844 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2848 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2852 #define BV_INT_REF(stem, type, size) \
2854 scm_t_signed_bits i; \
2855 const scm_t_ ## type *int_ptr; \
2858 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2859 i = SCM_I_INUM (idx); \
2860 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2862 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2864 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2865 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2867 scm_t_ ## type x = *int_ptr; \
2868 if (SCM_FIXABLE (x)) \
2869 RETURN (SCM_I_MAKINUM (x)); \
2873 RETURN (scm_from_ ## type (x)); \
2879 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2883 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2885 scm_t_signed_bits i; \
2886 const type *float_ptr; \
2889 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2890 i = SCM_I_INUM (idx); \
2891 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2894 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2896 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2897 && (ALIGNED_P (float_ptr, type)))) \
2898 RETURN (scm_from_double (*float_ptr)); \
2900 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2903 VM_DEFINE_OP (107, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2904 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2906 VM_DEFINE_OP (108, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2907 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2909 VM_DEFINE_OP (109, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2910 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2912 VM_DEFINE_OP (110, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2913 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2915 VM_DEFINE_OP (111, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2916 #if SIZEOF_VOID_P > 4
2917 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2919 BV_INT_REF (u32
, uint32
, 4);
2922 VM_DEFINE_OP (112, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2923 #if SIZEOF_VOID_P > 4
2924 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2926 BV_INT_REF (s32
, int32
, 4);
2929 VM_DEFINE_OP (113, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2930 BV_INT_REF (u64
, uint64
, 8);
2932 VM_DEFINE_OP (114, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2933 BV_INT_REF (s64
, int64
, 8);
2935 VM_DEFINE_OP (115, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2936 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2938 VM_DEFINE_OP (116, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2939 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2941 /* bv-u8-set! dst:8 idx:8 src:8
2942 * bv-s8-set! dst:8 idx:8 src:8
2943 * bv-u16-set! dst:8 idx:8 src:8
2944 * bv-s16-set! dst:8 idx:8 src:8
2945 * bv-u32-set! dst:8 idx:8 src:8
2946 * bv-s32-set! dst:8 idx:8 src:8
2947 * bv-u64-set! dst:8 idx:8 src:8
2948 * bv-s64-set! dst:8 idx:8 src:8
2949 * bv-f32-set! dst:8 idx:8 src:8
2950 * bv-f64-set! dst:8 idx:8 src:8
2952 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2953 * values are written using native endianness.
2955 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2957 scm_t_uint8 dst, idx, src; \
2958 scm_t_signed_bits i, j = 0; \
2959 SCM bv, scm_idx, val; \
2960 scm_t_ ## type *int_ptr; \
2962 UNPACK_8_8_8 (op, dst, idx, src); \
2963 bv = LOCAL_REF (dst); \
2964 scm_idx = LOCAL_REF (idx); \
2965 val = LOCAL_REF (src); \
2966 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2967 i = SCM_I_INUM (scm_idx); \
2968 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2970 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2972 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2973 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2974 && (SCM_I_INUMP (val)) \
2975 && ((j = SCM_I_INUM (val)) >= min) \
2977 *int_ptr = (scm_t_ ## type) j; \
2981 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
2986 #define BV_INT_SET(stem, type, size) \
2988 scm_t_uint8 dst, idx, src; \
2989 scm_t_signed_bits i; \
2990 SCM bv, scm_idx, val; \
2991 scm_t_ ## type *int_ptr; \
2993 UNPACK_8_8_8 (op, dst, idx, src); \
2994 bv = LOCAL_REF (dst); \
2995 scm_idx = LOCAL_REF (idx); \
2996 val = LOCAL_REF (src); \
2997 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2998 i = SCM_I_INUM (scm_idx); \
2999 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3001 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3003 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3004 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3005 *int_ptr = scm_to_ ## type (val); \
3009 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3014 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3016 scm_t_uint8 dst, idx, src; \
3017 scm_t_signed_bits i; \
3018 SCM bv, scm_idx, val; \
3021 UNPACK_8_8_8 (op, dst, idx, src); \
3022 bv = LOCAL_REF (dst); \
3023 scm_idx = LOCAL_REF (idx); \
3024 val = LOCAL_REF (src); \
3025 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3026 i = SCM_I_INUM (scm_idx); \
3027 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3029 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3031 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3032 && (ALIGNED_P (float_ptr, type)))) \
3033 *float_ptr = scm_to_double (val); \
3037 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3042 VM_DEFINE_OP (117, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3043 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3045 VM_DEFINE_OP (118, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3046 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3048 VM_DEFINE_OP (119, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3049 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3051 VM_DEFINE_OP (120, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3052 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3054 VM_DEFINE_OP (121, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3055 #if SIZEOF_VOID_P > 4
3056 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3058 BV_INT_SET (u32
, uint32
, 4);
3061 VM_DEFINE_OP (122, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3062 #if SIZEOF_VOID_P > 4
3063 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3065 BV_INT_SET (s32
, int32
, 4);
3068 VM_DEFINE_OP (123, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3069 BV_INT_SET (u64
, uint64
, 8);
3071 VM_DEFINE_OP (124, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3072 BV_INT_SET (s64
, int64
, 8);
3074 VM_DEFINE_OP (125, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3075 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3077 VM_DEFINE_OP (126, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3078 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3080 END_DISPATCH_SWITCH
;
3082 vm_error_bad_instruction
:
3083 vm_error_bad_instruction (op
);
3085 abort (); /* never reached */
3089 #undef ABORT_CONTINUATION_HOOK
3094 #undef BEGIN_DISPATCH_SWITCH
3095 #undef BINARY_INTEGER_OP
3096 #undef BR_ARITHMETIC
3100 #undef BV_FIXABLE_INT_REF
3101 #undef BV_FIXABLE_INT_SET
3106 #undef CACHE_REGISTER
3107 #undef CHECK_OVERFLOW
3108 #undef END_DISPATCH_SWITCH
3109 #undef FREE_VARIABLE_REF
3118 #undef POP_CONTINUATION_HOOK
3119 #undef PUSH_CONTINUATION_HOOK
3120 #undef RESTORE_CONTINUATION_HOOK
3122 #undef RETURN_ONE_VALUE
3123 #undef RETURN_VALUE_LIST
3128 #undef SYNC_BEFORE_GC
3130 #undef SYNC_REGISTER
3136 #undef VARIABLE_BOUNDP
3139 #undef VM_CHECK_FREE_VARIABLE
3140 #undef VM_CHECK_OBJECT
3141 #undef VM_CHECK_UNDERFLOW
3143 #undef VM_INSTRUCTION_TO_LABEL
3145 #undef VM_VALIDATE_BYTEVECTOR
3146 #undef VM_VALIDATE_PAIR
3147 #undef VM_VALIDATE_STRUCT
3150 (defun renumber-ops ()
3151 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3154 (let ((counter -1)) (goto-char (point-min))
3155 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3157 (number-to-string (setq counter (1+ counter)))