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 (struct scm_vm
*vp
, SCM program
, SCM
*argv
, size_t nargs_
)
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_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
443 scm_i_jmp_buf registers
; /* used for prompts */
445 #ifdef HAVE_LABELS_AS_VALUES
446 static const void **jump_table_pointer
= NULL
;
447 register const void **jump_table JT_REG
;
449 if (SCM_UNLIKELY (!jump_table_pointer
))
452 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
453 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
454 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
455 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
456 FOR_EACH_VM_OPERATION(INIT
);
460 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
461 load instruction at each instruction dispatch. */
462 jump_table
= jump_table_pointer
;
465 if (SCM_I_SETJMP (registers
))
467 /* Non-local return. The values are on the stack, on a new frame
468 set up to call `values' to return the values to the handler.
469 Cache the VM registers back from the vp, and dispatch to the
472 Note, at this point, we must assume that any variable local to
473 vm_engine that can be assigned *has* been assigned. So we need
474 to pull all our state back from the ip/fp/sp.
477 ABORT_CONTINUATION_HOOK ();
481 /* Load previous VM registers. */
484 VM_HANDLE_INTERRUPTS
;
489 ptrdiff_t base_frame_size
;
491 /* Check that we have enough space: 3 words for the boot
492 continuation, 3 + nargs for the procedure application, and 3 for
493 setting up a new frame. */
494 base_frame_size
= 3 + 3 + nargs_
+ 3;
495 vp
->sp
+= base_frame_size
;
497 base
= vp
->sp
+ 1 - base_frame_size
;
499 /* Since it's possible to receive the arguments on the stack itself,
500 and indeed the regular VM invokes us that way, shuffle up the
504 for (i
= nargs_
- 1; i
>= 0; i
--)
505 base
[6 + i
] = argv
[i
];
508 /* Initial frame, saving previous fp and ip, with the boot
510 base
[0] = SCM_PACK (fp
); /* dynamic link */
511 base
[1] = SCM_PACK (ip
); /* ra */
512 base
[2] = vm_boot_continuation
;
514 ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
516 /* MV-call frame, function & arguments */
517 base
[3] = SCM_PACK (fp
); /* dynamic link */
518 base
[4] = SCM_PACK (ip
); /* ra */
520 fp
= vp
->fp
= &base
[5];
521 RESET_FRAME (nargs_
+ 1);
525 while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
527 SCM proc
= SCM_FRAME_PROGRAM (fp
);
529 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
531 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
534 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
536 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
538 /* Shuffle args up. */
541 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
543 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
548 vm_error_wrong_type_apply (proc
);
552 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
555 BEGIN_DISPATCH_SWITCH
;
566 * Bring the VM to a halt, returning all the values from the stack.
568 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
570 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
572 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
582 for (n
= nvals
; n
> 0; n
--)
583 ret
= scm_cons (LOCAL_REF (4 + n
- 1), ret
);
584 ret
= scm_values (ret
);
587 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
588 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
589 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
594 /* call proc:24 _:8 nlocals:24
596 * Call a procedure. PROC is the local corresponding to a procedure.
597 * The three values below PROC will be overwritten by the saved call
598 * frame data. The new frame will have space for NLOCALS locals: one
599 * for the procedure, and the rest for the arguments which should
600 * already have been pushed on.
602 * When the call returns, execution proceeds with the next
603 * instruction. There may be any number of values on the return
604 * stack; the precise number can be had by subtracting the address of
605 * PROC from the post-call SP.
607 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
609 scm_t_uint32 proc
, nlocals
;
612 UNPACK_24 (op
, proc
);
613 UNPACK_24 (ip
[1], nlocals
);
615 VM_HANDLE_INTERRUPTS
;
617 fp
= vp
->fp
= old_fp
+ proc
;
618 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
619 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
621 RESET_FRAME (nlocals
);
623 PUSH_CONTINUATION_HOOK ();
626 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
629 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
633 /* tail-call nlocals:24
635 * Tail-call a procedure. Requires that the procedure and all of the
636 * arguments have already been shuffled into position. Will reset the
639 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
641 scm_t_uint32 nlocals
;
643 UNPACK_24 (op
, nlocals
);
645 VM_HANDLE_INTERRUPTS
;
647 RESET_FRAME (nlocals
);
651 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
654 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
658 /* tail-call/shuffle from:24
660 * Tail-call a procedure. The procedure should already be set to slot
661 * 0. The rest of the args are taken from the frame, starting at
662 * FROM, shuffled down to start at slot 0. This is part of the
663 * implementation of the call-with-values builtin.
665 VM_DEFINE_OP (3, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
667 scm_t_uint32 n
, from
, nlocals
;
669 UNPACK_24 (op
, from
);
671 VM_HANDLE_INTERRUPTS
;
673 VM_ASSERT (from
> 0, abort ());
674 nlocals
= FRAME_LOCALS_COUNT ();
676 for (n
= 0; from
+ n
< nlocals
; n
++)
677 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
683 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
686 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
690 /* receive dst:12 proc:12 _:8 nlocals:24
692 * Receive a single return value from a call whose procedure was in
693 * PROC, asserting that the call actually returned at least one
694 * value. Afterwards, resets the frame to NLOCALS locals.
696 VM_DEFINE_OP (4, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
698 scm_t_uint16 dst
, proc
;
699 scm_t_uint32 nlocals
;
700 UNPACK_12_12 (op
, dst
, proc
);
701 UNPACK_24 (ip
[1], nlocals
);
702 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
703 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
704 RESET_FRAME (nlocals
);
708 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
710 * Receive a return of multiple values from a call whose procedure was
711 * in PROC. If fewer than NVALUES values were returned, signal an
712 * error. Unless ALLOW-EXTRA? is true, require that the number of
713 * return values equals NVALUES exactly. After receive-values has
714 * run, the values can be copied down via `mov'.
716 VM_DEFINE_OP (5, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
718 scm_t_uint32 proc
, nvalues
;
719 UNPACK_24 (op
, proc
);
720 UNPACK_24 (ip
[1], nvalues
);
722 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
723 vm_error_not_enough_values ());
725 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
726 vm_error_wrong_number_of_values (nvalues
));
734 VM_DEFINE_OP (6, return, "return", OP1 (U8_U24
))
738 RETURN_ONE_VALUE (LOCAL_REF (src
));
741 /* return-values _:24
743 * Return a number of values from a call frame. This opcode
744 * corresponds to an application of `values' in tail position. As
745 * with tail calls, we expect that the values have already been
746 * shuffled down to a contiguous array starting at slot 1.
747 * We also expect the frame has already been reset.
749 VM_DEFINE_OP (7, return_values
, "return-values", OP1 (U8_X24
))
753 VM_HANDLE_INTERRUPTS
;
754 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
755 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
757 /* Clear stack frame. */
758 old_fp
[-1] = SCM_BOOL_F
;
759 old_fp
[-2] = SCM_BOOL_F
;
761 POP_CONTINUATION_HOOK (old_fp
);
770 * Specialized call stubs
773 /* subr-call ptr-idx:24
775 * Call a subr, passing all locals in this frame as arguments. Fetch
776 * the foreign pointer from PTR-IDX, a free variable. Return from the
777 * calling frame. This instruction is part of the trampolines
778 * created in gsubr.c, and is not generated by the compiler.
780 VM_DEFINE_OP (8, subr_call
, "subr-call", OP1 (U8_U24
))
782 scm_t_uint32 ptr_idx
;
786 UNPACK_24 (op
, ptr_idx
);
788 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
789 subr
= SCM_POINTER_VALUE (pointer
);
791 VM_HANDLE_INTERRUPTS
;
794 switch (FRAME_LOCALS_COUNT_FROM (1))
803 ret
= subr (fp
[1], fp
[2]);
806 ret
= subr (fp
[1], fp
[2], fp
[3]);
809 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
812 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
815 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
818 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
821 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
824 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
827 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
833 // NULLSTACK_FOR_NONLOCAL_EXIT ();
835 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
836 /* multiple values returned to continuation */
837 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
839 RETURN_ONE_VALUE (ret
);
842 /* foreign-call cif-idx:12 ptr-idx:12
844 * Call a foreign function. Fetch the CIF and foreign pointer from
845 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
846 * frame. Arguments are taken from the stack. This instruction is
847 * part of the trampolines created by the FFI, and is not generated by
850 VM_DEFINE_OP (9, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
852 scm_t_uint16 cif_idx
, ptr_idx
;
853 SCM closure
, cif
, pointer
, ret
;
855 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
857 closure
= LOCAL_REF (0);
858 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
859 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
862 VM_HANDLE_INTERRUPTS
;
864 // FIXME: separate args
865 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), LOCAL_ADDRESS (1));
867 // NULLSTACK_FOR_NONLOCAL_EXIT ();
869 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
870 /* multiple values returned to continuation */
871 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
873 RETURN_ONE_VALUE (ret
);
876 /* continuation-call contregs:24
878 * Return to a continuation, nonlocally. The arguments to the
879 * continuation are taken from the stack. CONTREGS is a free variable
880 * containing the reified continuation. This instruction is part of
881 * the implementation of undelimited continuations, and is not
882 * generated by the compiler.
884 VM_DEFINE_OP (10, continuation_call
, "continuation-call", OP1 (U8_U24
))
887 scm_t_uint32 contregs_idx
;
889 UNPACK_24 (op
, contregs_idx
);
892 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
895 scm_i_check_continuation (contregs
);
896 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
897 scm_i_contregs_vm_cont (contregs
),
898 FRAME_LOCALS_COUNT_FROM (1),
900 scm_i_reinstate_continuation (contregs
);
906 /* compose-continuation cont:24
908 * Compose a partial continution with the current continuation. The
909 * arguments to the continuation are taken from the stack. CONT is a
910 * free variable containing the reified continuation. This
911 * instruction is part of the implementation of partial continuations,
912 * and is not generated by the compiler.
914 VM_DEFINE_OP (11, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
917 scm_t_uint32 cont_idx
;
919 UNPACK_24 (op
, cont_idx
);
920 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
923 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
924 vm_error_continuation_not_rewindable (vmcont
));
925 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
927 ¤t_thread
->dynstack
,
935 * Tail-apply the procedure in local slot 0 to the rest of the
936 * arguments. This instruction is part of the implementation of
937 * `apply', and is not generated by the compiler.
939 VM_DEFINE_OP (12, tail_apply
, "tail-apply", OP1 (U8_X24
))
941 int i
, list_idx
, list_len
, nlocals
;
944 VM_HANDLE_INTERRUPTS
;
946 nlocals
= FRAME_LOCALS_COUNT ();
947 // At a minimum, there should be apply, f, and the list.
948 VM_ASSERT (nlocals
>= 3, abort ());
949 list_idx
= nlocals
- 1;
950 list
= LOCAL_REF (list_idx
);
951 list_len
= scm_ilength (list
);
953 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
955 nlocals
= nlocals
- 2 + list_len
;
956 ALLOC_FRAME (nlocals
);
958 for (i
= 1; i
< list_idx
; i
++)
959 LOCAL_SET (i
- 1, LOCAL_REF (i
));
961 /* Null out these slots, just in case there are less than 2 elements
963 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
964 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
966 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
967 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
971 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
974 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
980 * Capture the current continuation, and tail-apply the procedure in
981 * local slot 1 to it. This instruction is part of the implementation
982 * of `call/cc', and is not generated by the compiler.
984 VM_DEFINE_OP (13, call_cc
, "call/cc", OP1 (U8_X24
))
987 scm_t_dynstack
*dynstack
;
990 VM_HANDLE_INTERRUPTS
;
993 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
994 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
995 SCM_FRAME_DYNAMIC_LINK (fp
),
996 SCM_FRAME_PREVIOUS_SP (fp
),
997 SCM_FRAME_RETURN_ADDRESS (fp
),
1000 /* FIXME: Seems silly to capture the registers here, when they are
1001 already captured in the registers local, which here we are
1002 copying out to the heap; and likewise, the setjmp(®isters)
1003 code already has the non-local return handler. But oh
1005 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
1009 LOCAL_SET (0, LOCAL_REF (1));
1010 LOCAL_SET (1, cont
);
1015 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1018 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1024 ABORT_CONTINUATION_HOOK ();
1031 * Abort to a prompt handler. The tag is expected in r1, and the rest
1032 * of the values in the frame are returned to the prompt handler.
1033 * This corresponds to a tail application of abort-to-prompt.
1035 VM_DEFINE_OP (14, abort
, "abort", OP1 (U8_X24
))
1037 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1039 ASSERT (nlocals
>= 2);
1040 /* FIXME: Really we should capture the caller's registers. Until
1041 then, manually advance the IP so that when the prompt resumes,
1042 it continues with the next instruction. */
1045 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1046 SCM_EOL
, LOCAL_ADDRESS (0), ®isters
);
1048 /* vm_abort should not return */
1052 /* builtin-ref dst:12 idx:12
1054 * Load a builtin stub by index into DST.
1056 VM_DEFINE_OP (15, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1058 scm_t_uint16 dst
, idx
;
1060 UNPACK_12_12 (op
, dst
, idx
);
1061 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1070 * Function prologues
1073 /* br-if-nargs-ne expected:24 _:8 offset:24
1074 * br-if-nargs-lt expected:24 _:8 offset:24
1075 * br-if-nargs-gt expected:24 _:8 offset:24
1077 * If the number of actual arguments is not equal, less than, or greater
1078 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1079 * the current instruction pointer.
1081 VM_DEFINE_OP (16, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1085 VM_DEFINE_OP (17, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1089 VM_DEFINE_OP (18, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1094 /* assert-nargs-ee expected:24
1095 * assert-nargs-ge expected:24
1096 * assert-nargs-le expected:24
1098 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1099 * respectively, signal an error.
1101 VM_DEFINE_OP (19, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1103 scm_t_uint32 expected
;
1104 UNPACK_24 (op
, expected
);
1105 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1106 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1109 VM_DEFINE_OP (20, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1111 scm_t_uint32 expected
;
1112 UNPACK_24 (op
, expected
);
1113 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1114 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1117 VM_DEFINE_OP (21, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1119 scm_t_uint32 expected
;
1120 UNPACK_24 (op
, expected
);
1121 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1122 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1126 /* alloc-frame nlocals:24
1128 * Ensure that there is space on the stack for NLOCALS local variables,
1129 * setting them all to SCM_UNDEFINED, except those nargs values that
1130 * were passed as arguments and procedure.
1132 VM_DEFINE_OP (22, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1134 scm_t_uint32 nlocals
, nargs
;
1135 UNPACK_24 (op
, nlocals
);
1137 nargs
= FRAME_LOCALS_COUNT ();
1138 ALLOC_FRAME (nlocals
);
1139 while (nlocals
-- > nargs
)
1140 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1145 /* reset-frame nlocals:24
1147 * Like alloc-frame, but doesn't check that the stack is big enough.
1148 * Used to reset the frame size to something less than the size that
1149 * was previously set via alloc-frame.
1151 VM_DEFINE_OP (23, reset_frame
, "reset-frame", OP1 (U8_U24
))
1153 scm_t_uint32 nlocals
;
1154 UNPACK_24 (op
, nlocals
);
1155 RESET_FRAME (nlocals
);
1159 /* assert-nargs-ee/locals expected:12 nlocals:12
1161 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1162 * number of locals reserved is EXPECTED + NLOCALS.
1164 VM_DEFINE_OP (24, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1166 scm_t_uint16 expected
, nlocals
;
1167 UNPACK_12_12 (op
, expected
, nlocals
);
1168 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1169 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1170 ALLOC_FRAME (expected
+ nlocals
);
1172 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1177 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1179 * Find the first positional argument after NREQ. If it is greater
1180 * than NPOS, jump to OFFSET.
1182 * This instruction is only emitted for functions with multiple
1183 * clauses, and an earlier clause has keywords and no rest arguments.
1184 * See "Case-lambda" in the manual, for more on how case-lambda
1185 * chooses the clause to apply.
1187 VM_DEFINE_OP (25, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1189 scm_t_uint32 nreq
, npos
;
1191 UNPACK_24 (op
, nreq
);
1192 UNPACK_24 (ip
[1], npos
);
1194 /* We can only have too many positionals if there are more
1195 arguments than NPOS. */
1196 if (FRAME_LOCALS_COUNT() > npos
)
1199 for (n
= nreq
; n
< npos
; n
++)
1200 if (scm_is_keyword (LOCAL_REF (n
)))
1202 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1204 scm_t_int32 offset
= ip
[2];
1205 offset
>>= 8; /* Sign-extending shift. */
1212 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1213 * _:8 ntotal:24 kw-offset:32
1215 * Find the last positional argument, and shuffle all the rest above
1216 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1217 * load the constant at KW-OFFSET words from the current IP, and use it
1218 * to bind keyword arguments. If HAS-REST, collect all shuffled
1219 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1220 * the arguments that we shuffled up.
1222 * A macro-mega-instruction.
1224 VM_DEFINE_OP (26, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1226 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1227 scm_t_int32 kw_offset
;
1230 char allow_other_keys
, has_rest
;
1232 UNPACK_24 (op
, nreq
);
1233 allow_other_keys
= ip
[1] & 0x1;
1234 has_rest
= ip
[1] & 0x2;
1235 UNPACK_24 (ip
[1], nreq_and_opt
);
1236 UNPACK_24 (ip
[2], ntotal
);
1238 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1239 VM_ASSERT (!(kw_bits
& 0x7), abort());
1240 kw
= SCM_PACK (kw_bits
);
1242 nargs
= FRAME_LOCALS_COUNT ();
1244 /* look in optionals for first keyword or last positional */
1245 /* starting after the last required positional arg */
1247 while (/* while we have args */
1249 /* and we still have positionals to fill */
1250 && npositional
< nreq_and_opt
1251 /* and we haven't reached a keyword yet */
1252 && !scm_is_keyword (LOCAL_REF (npositional
)))
1253 /* bind this optional arg (by leaving it in place) */
1255 nkw
= nargs
- npositional
;
1256 /* shuffle non-positional arguments above ntotal */
1257 ALLOC_FRAME (ntotal
+ nkw
);
1260 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1261 /* and fill optionals & keyword args with SCM_UNDEFINED */
1264 LOCAL_SET (n
++, SCM_UNDEFINED
);
1266 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1267 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1269 /* Now bind keywords, in the order given. */
1270 for (n
= 0; n
< nkw
; n
++)
1271 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1274 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1275 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1277 SCM si
= SCM_CDAR (walk
);
1278 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1279 LOCAL_REF (ntotal
+ n
+ 1));
1282 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1283 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1284 LOCAL_REF (ntotal
+ n
)));
1288 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1289 LOCAL_REF (ntotal
+ n
)));
1296 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1297 LOCAL_SET (nreq_and_opt
, rest
);
1300 RESET_FRAME (ntotal
);
1307 * Collect any arguments at or above DST into a list, and store that
1310 VM_DEFINE_OP (27, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1312 scm_t_uint32 dst
, nargs
;
1315 UNPACK_24 (op
, dst
);
1316 nargs
= FRAME_LOCALS_COUNT ();
1320 ALLOC_FRAME (dst
+ 1);
1322 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1326 while (nargs
-- > dst
)
1328 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1329 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1332 RESET_FRAME (dst
+ 1);
1335 LOCAL_SET (dst
, rest
);
1344 * Branching instructions
1349 * Add OFFSET, a signed 24-bit number, to the current instruction
1352 VM_DEFINE_OP (28, br
, "br", OP1 (U8_L24
))
1354 scm_t_int32 offset
= op
;
1355 offset
>>= 8; /* Sign-extending shift. */
1359 /* br-if-true test:24 invert:1 _:7 offset:24
1361 * If the value in TEST is true for the purposes of Scheme, add
1362 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1364 VM_DEFINE_OP (29, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1366 BR_UNARY (x
, scm_is_true (x
));
1369 /* br-if-null test:24 invert:1 _:7 offset:24
1371 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1372 * signed 24-bit number, to the current instruction pointer.
1374 VM_DEFINE_OP (30, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1376 BR_UNARY (x
, scm_is_null (x
));
1379 /* br-if-nil test:24 invert:1 _:7 offset:24
1381 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1382 * number, to the current instruction pointer.
1384 VM_DEFINE_OP (31, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1386 BR_UNARY (x
, scm_is_lisp_false (x
));
1389 /* br-if-pair test:24 invert:1 _:7 offset:24
1391 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1392 * to the current instruction pointer.
1394 VM_DEFINE_OP (32, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1396 BR_UNARY (x
, scm_is_pair (x
));
1399 /* br-if-struct test:24 invert:1 _:7 offset:24
1401 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1402 * number, to the current instruction pointer.
1404 VM_DEFINE_OP (33, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1406 BR_UNARY (x
, SCM_STRUCTP (x
));
1409 /* br-if-char test:24 invert:1 _:7 offset:24
1411 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1412 * to the current instruction pointer.
1414 VM_DEFINE_OP (34, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1416 BR_UNARY (x
, SCM_CHARP (x
));
1419 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1421 * If the value in TEST has the TC7 given in the second word, add
1422 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1424 VM_DEFINE_OP (35, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1426 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1429 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1431 * If the value in A is eq? to the value in B, add OFFSET, a signed
1432 * 24-bit number, to the current instruction pointer.
1434 VM_DEFINE_OP (36, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1436 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1439 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1441 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1442 * 24-bit number, to the current instruction pointer.
1444 VM_DEFINE_OP (37, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1448 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1449 && scm_is_true (scm_eqv_p (x
, y
))));
1452 // FIXME: remove, have compiler inline eqv test instead
1453 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1455 * If the value in A is equal? to the value in B, add OFFSET, a signed
1456 * 24-bit number, to the current instruction pointer.
1458 // FIXME: should sync_ip before calling out?
1459 VM_DEFINE_OP (38, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1463 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1464 && scm_is_true (scm_equal_p (x
, y
))));
1467 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1469 * If the value in A is = to the value in B, add OFFSET, a signed
1470 * 24-bit number, to the current instruction pointer.
1472 VM_DEFINE_OP (39, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1474 BR_ARITHMETIC (==, scm_num_eq_p
);
1477 /* br-if-< a:12 b:12 _:8 offset:24
1479 * If the value in A is < to the value in B, add OFFSET, a signed
1480 * 24-bit number, to the current instruction pointer.
1482 VM_DEFINE_OP (40, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1484 BR_ARITHMETIC (<, scm_less_p
);
1487 /* br-if-<= a:12 b:12 _:8 offset:24
1489 * If the value in A is <= to the value in B, add OFFSET, a signed
1490 * 24-bit number, to the current instruction pointer.
1492 VM_DEFINE_OP (41, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1494 BR_ARITHMETIC (<=, scm_leq_p
);
1501 * Lexical binding instructions
1504 /* mov dst:12 src:12
1506 * Copy a value from one local slot to another.
1508 VM_DEFINE_OP (42, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1513 UNPACK_12_12 (op
, dst
, src
);
1514 LOCAL_SET (dst
, LOCAL_REF (src
));
1519 /* long-mov dst:24 _:8 src:24
1521 * Copy a value from one local slot to another.
1523 VM_DEFINE_OP (43, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1528 UNPACK_24 (op
, dst
);
1529 UNPACK_24 (ip
[1], src
);
1530 LOCAL_SET (dst
, LOCAL_REF (src
));
1535 /* box dst:12 src:12
1537 * Create a new variable holding SRC, and place it in DST.
1539 VM_DEFINE_OP (44, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1541 scm_t_uint16 dst
, src
;
1542 UNPACK_12_12 (op
, dst
, src
);
1543 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1547 /* box-ref dst:12 src:12
1549 * Unpack the variable at SRC into DST, asserting that the variable is
1552 VM_DEFINE_OP (45, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1554 scm_t_uint16 dst
, src
;
1556 UNPACK_12_12 (op
, dst
, src
);
1557 var
= LOCAL_REF (src
);
1558 VM_ASSERT (SCM_VARIABLEP (var
),
1559 vm_error_not_a_variable ("variable-ref", var
));
1560 VM_ASSERT (VARIABLE_BOUNDP (var
),
1561 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1562 LOCAL_SET (dst
, VARIABLE_REF (var
));
1566 /* box-set! dst:12 src:12
1568 * Set the contents of the variable at DST to SET.
1570 VM_DEFINE_OP (46, box_set
, "box-set!", OP1 (U8_U12_U12
))
1572 scm_t_uint16 dst
, src
;
1574 UNPACK_12_12 (op
, dst
, src
);
1575 var
= LOCAL_REF (dst
);
1576 VM_ASSERT (SCM_VARIABLEP (var
),
1577 vm_error_not_a_variable ("variable-set!", var
));
1578 VARIABLE_SET (var
, LOCAL_REF (src
));
1582 /* make-closure dst:24 offset:32 _:8 nfree:24
1584 * Make a new closure, and write it to DST. The code for the closure
1585 * will be found at OFFSET words from the current IP. OFFSET is a
1586 * signed 32-bit integer. Space for NFREE free variables will be
1589 VM_DEFINE_OP (47, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1591 scm_t_uint32 dst
, nfree
, n
;
1595 UNPACK_24 (op
, dst
);
1597 UNPACK_24 (ip
[2], nfree
);
1599 // FIXME: Assert range of nfree?
1600 closure
= scm_words (scm_tc7_program
| (nfree
<< 16), nfree
+ 2);
1601 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1602 // FIXME: Elide these initializations?
1603 for (n
= 0; n
< nfree
; n
++)
1604 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1605 LOCAL_SET (dst
, closure
);
1609 /* free-ref dst:12 src:12 _:8 idx:24
1611 * Load free variable IDX from the closure SRC into local slot DST.
1613 VM_DEFINE_OP (48, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1615 scm_t_uint16 dst
, src
;
1617 UNPACK_12_12 (op
, dst
, src
);
1618 UNPACK_24 (ip
[1], idx
);
1619 /* CHECK_FREE_VARIABLE (src); */
1620 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1624 /* free-set! dst:12 src:12 _8 idx:24
1626 * Set free variable IDX from the closure DST to SRC.
1628 VM_DEFINE_OP (49, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1630 scm_t_uint16 dst
, src
;
1632 UNPACK_12_12 (op
, dst
, src
);
1633 UNPACK_24 (ip
[1], idx
);
1634 /* CHECK_FREE_VARIABLE (src); */
1635 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1643 * Immediates and statically allocated non-immediates
1646 /* make-short-immediate dst:8 low-bits:16
1648 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1651 VM_DEFINE_OP (50, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1656 UNPACK_8_16 (op
, dst
, val
);
1657 LOCAL_SET (dst
, SCM_PACK (val
));
1661 /* make-long-immediate dst:24 low-bits:32
1663 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1666 VM_DEFINE_OP (51, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1671 UNPACK_24 (op
, dst
);
1673 LOCAL_SET (dst
, SCM_PACK (val
));
1677 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1679 * Make an immediate with HIGH-BITS and LOW-BITS.
1681 VM_DEFINE_OP (52, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1686 UNPACK_24 (op
, dst
);
1687 #if SIZEOF_SCM_T_BITS > 4
1692 ASSERT (ip
[1] == 0);
1695 LOCAL_SET (dst
, SCM_PACK (val
));
1699 /* make-non-immediate dst:24 offset:32
1701 * Load a pointer to statically allocated memory into DST. The
1702 * object's memory is will be found OFFSET 32-bit words away from the
1703 * current instruction pointer. OFFSET is a signed value. The
1704 * intention here is that the compiler would produce an object file
1705 * containing the words of a non-immediate object, and this
1706 * instruction creates a pointer to that memory, effectively
1707 * resurrecting that object.
1709 * Whether the object is mutable or immutable depends on where it was
1710 * allocated by the compiler, and loaded by the loader.
1712 VM_DEFINE_OP (53, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1717 scm_t_bits unpacked
;
1719 UNPACK_24 (op
, dst
);
1722 unpacked
= (scm_t_bits
) loc
;
1724 VM_ASSERT (!(unpacked
& 0x7), abort());
1726 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1731 /* static-ref dst:24 offset:32
1733 * Load a SCM value into DST. The SCM value will be fetched from
1734 * memory, OFFSET 32-bit words away from the current instruction
1735 * pointer. OFFSET is a signed value.
1737 * The intention is for this instruction to be used to load constants
1738 * that the compiler is unable to statically allocate, like symbols.
1739 * These values would be initialized when the object file loads.
1741 VM_DEFINE_OP (54, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
1746 scm_t_uintptr loc_bits
;
1748 UNPACK_24 (op
, dst
);
1751 loc_bits
= (scm_t_uintptr
) loc
;
1752 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1754 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1759 /* static-set! src:24 offset:32
1761 * Store a SCM value into memory, OFFSET 32-bit words away from the
1762 * current instruction pointer. OFFSET is a signed value.
1764 VM_DEFINE_OP (55, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1770 UNPACK_24 (op
, src
);
1773 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1775 *((SCM
*) loc
) = LOCAL_REF (src
);
1780 /* static-patch! _:24 dst-offset:32 src-offset:32
1782 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1783 * are signed 32-bit values, indicating a memory address as a number
1784 * of 32-bit words away from the current instruction pointer.
1786 VM_DEFINE_OP (56, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1788 scm_t_int32 dst_offset
, src_offset
;
1795 dst_loc
= (void **) (ip
+ dst_offset
);
1796 src
= ip
+ src_offset
;
1797 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1807 * Mutable top-level bindings
1810 /* There are three slightly different ways to resolve toplevel
1813 1. A toplevel reference outside of a function. These need to be
1814 looked up when the expression is evaluated -- no later, and no
1815 before. They are looked up relative to the module that is
1816 current when the expression is evaluated. For example:
1820 The "resolve" instruction resolves the variable (box), and then
1821 access is via box-ref or box-set!.
1823 2. A toplevel reference inside a function. These are looked up
1824 relative to the module that was current when the function was
1825 defined. Unlike code at the toplevel, which is usually run only
1826 once, these bindings benefit from memoized lookup, in which the
1827 variable resulting from the lookup is cached in the function.
1829 (lambda () (if (foo) a b))
1831 The toplevel-box instruction is equivalent to "resolve", but
1832 caches the resulting variable in statically allocated memory.
1834 3. A reference to an identifier with respect to a particular
1835 module. This can happen for primitive references, and
1836 references residualized by macro expansions. These can always
1837 be cached. Use module-box for these.
1840 /* current-module dst:24
1842 * Store the current module in DST.
1844 VM_DEFINE_OP (57, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1848 UNPACK_24 (op
, dst
);
1851 LOCAL_SET (dst
, scm_current_module ());
1856 /* resolve dst:24 bound?:1 _:7 sym:24
1858 * Resolve SYM in the current module, and place the resulting variable
1861 VM_DEFINE_OP (58, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1867 UNPACK_24 (op
, dst
);
1868 UNPACK_24 (ip
[1], sym
);
1871 var
= scm_lookup (LOCAL_REF (sym
));
1873 VM_ASSERT (VARIABLE_BOUNDP (var
),
1874 vm_error_unbound (fp
[0], LOCAL_REF (sym
)));
1875 LOCAL_SET (dst
, var
);
1880 /* define! sym:12 val:12
1882 * Look up a binding for SYM in the current module, creating it if
1883 * necessary. Set its value to VAL.
1885 VM_DEFINE_OP (59, define
, "define!", OP1 (U8_U12_U12
))
1887 scm_t_uint16 sym
, val
;
1888 UNPACK_12_12 (op
, sym
, val
);
1890 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1894 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1896 * Load a SCM value. The SCM value will be fetched from memory,
1897 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1898 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1901 * Then, if the loaded value is a variable, it is placed in DST, and control
1904 * Otherwise, we have to resolve the variable. In that case we load
1905 * the module from MOD-OFFSET, just as we loaded the variable.
1906 * Usually the module gets set when the closure is created. The name
1907 * is an offset to a symbol.
1909 * We use the module and the symbol to resolve the variable, placing it in
1910 * DST, and caching the resolved variable so that we will hit the cache next
1913 VM_DEFINE_OP (60, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1916 scm_t_int32 var_offset
;
1917 scm_t_uint32
* var_loc_u32
;
1921 UNPACK_24 (op
, dst
);
1923 var_loc_u32
= ip
+ var_offset
;
1924 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1925 var_loc
= (SCM
*) var_loc_u32
;
1928 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1931 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1932 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1933 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1934 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1938 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1939 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1941 mod
= *((SCM
*) mod_loc
);
1942 sym
= *((SCM
*) sym_loc
);
1944 /* If the toplevel scope was captured before modules were
1945 booted, use the root module. */
1946 if (scm_is_false (mod
))
1947 mod
= scm_the_root_module ();
1949 var
= scm_module_lookup (mod
, sym
);
1951 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], 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 (61, 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
)
1998 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
2001 scm_equal_p (modname
,
2002 scm_list_2 (SCM_BOOL_T
,
2003 scm_from_utf8_symbol ("guile"))));
2005 var
= scm_lookup (sym
);
2007 else if (scm_is_true (SCM_CAR (modname
)))
2008 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2010 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2013 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], 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 (62, 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 (¤t_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 (63, wind
, "wind", OP1 (U8_U12_U12
))
2069 scm_t_uint16 winder
, unwinder
;
2070 UNPACK_12_12 (op
, winder
, unwinder
);
2071 scm_dynstack_push_dynwind (¤t_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 (64, unwind
, "unwind", OP1 (U8_X24
))
2083 scm_dynstack_pop (¤t_thread
->dynstack
);
2087 /* push-fluid fluid:12 value:12
2089 * Dynamically bind N fluids to values. The fluids are expected to be
2090 * allocated in a continguous range on the stack, starting from
2091 * FLUID-BASE. The values do not have this restriction.
2093 VM_DEFINE_OP (65, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2095 scm_t_uint32 fluid
, value
;
2097 UNPACK_12_12 (op
, fluid
, value
);
2099 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2100 LOCAL_REF (fluid
), LOCAL_REF (value
),
2101 current_thread
->dynamic_state
);
2107 * Leave the dynamic extent of a with-fluids expression, restoring the
2108 * fluids to their previous values.
2110 VM_DEFINE_OP (66, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2112 /* This function must not allocate. */
2113 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2114 current_thread
->dynamic_state
);
2118 /* fluid-ref dst:12 src:12
2120 * Reference the fluid in SRC, and place the value in DST.
2122 VM_DEFINE_OP (67, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2124 scm_t_uint16 dst
, src
;
2128 UNPACK_12_12 (op
, dst
, src
);
2129 fluid
= LOCAL_REF (src
);
2130 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2131 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2132 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2134 /* Punt dynstate expansion and error handling to the C proc. */
2136 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2140 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2141 if (scm_is_eq (val
, SCM_UNDEFINED
))
2142 val
= SCM_I_FLUID_DEFAULT (fluid
);
2143 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2144 vm_error_unbound_fluid (program
, fluid
));
2145 LOCAL_SET (dst
, val
);
2151 /* fluid-set fluid:12 val:12
2153 * Set the value of the fluid in DST to the value in SRC.
2155 VM_DEFINE_OP (68, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2161 UNPACK_12_12 (op
, a
, b
);
2162 fluid
= LOCAL_REF (a
);
2163 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2164 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2165 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2167 /* Punt dynstate expansion and error handling to the C proc. */
2169 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2172 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2181 * Strings, symbols, and keywords
2184 /* string-length dst:12 src:12
2186 * Store the length of the string in SRC in DST.
2188 VM_DEFINE_OP (69, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2191 if (SCM_LIKELY (scm_is_string (str
)))
2192 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2196 RETURN (scm_string_length (str
));
2200 /* string-ref dst:8 src:8 idx:8
2202 * Fetch the character at position IDX in the string in SRC, and store
2205 VM_DEFINE_OP (70, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2207 scm_t_signed_bits i
= 0;
2209 if (SCM_LIKELY (scm_is_string (str
)
2210 && SCM_I_INUMP (idx
)
2211 && ((i
= SCM_I_INUM (idx
)) >= 0)
2212 && i
< scm_i_string_length (str
)))
2213 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2217 RETURN (scm_string_ref (str
, idx
));
2221 /* No string-set! instruction, as there is no good fast path there. */
2223 /* string-to-number dst:12 src:12
2225 * Parse a string in SRC to a number, and store in DST.
2227 VM_DEFINE_OP (71, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2229 scm_t_uint16 dst
, src
;
2231 UNPACK_12_12 (op
, dst
, src
);
2234 scm_string_to_number (LOCAL_REF (src
),
2235 SCM_UNDEFINED
/* radix = 10 */));
2239 /* string-to-symbol dst:12 src:12
2241 * Parse a string in SRC to a symbol, and store in DST.
2243 VM_DEFINE_OP (72, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2245 scm_t_uint16 dst
, src
;
2247 UNPACK_12_12 (op
, dst
, src
);
2249 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2253 /* symbol->keyword dst:12 src:12
2255 * Make a keyword from the symbol in SRC, and store it in DST.
2257 VM_DEFINE_OP (73, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2259 scm_t_uint16 dst
, src
;
2260 UNPACK_12_12 (op
, dst
, src
);
2262 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2272 /* cons dst:8 car:8 cdr:8
2274 * Cons CAR and CDR, and store the result in DST.
2276 VM_DEFINE_OP (74, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2279 RETURN (scm_cons (x
, y
));
2282 /* car dst:12 src:12
2284 * Place the car of SRC in DST.
2286 VM_DEFINE_OP (75, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2289 VM_VALIDATE_PAIR (x
, "car");
2290 RETURN (SCM_CAR (x
));
2293 /* cdr dst:12 src:12
2295 * Place the cdr of SRC in DST.
2297 VM_DEFINE_OP (76, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2300 VM_VALIDATE_PAIR (x
, "cdr");
2301 RETURN (SCM_CDR (x
));
2304 /* set-car! pair:12 car:12
2306 * Set the car of DST to SRC.
2308 VM_DEFINE_OP (77, set_car
, "set-car!", OP1 (U8_U12_U12
))
2312 UNPACK_12_12 (op
, a
, b
);
2315 VM_VALIDATE_PAIR (x
, "set-car!");
2320 /* set-cdr! pair:12 cdr:12
2322 * Set the cdr of DST to SRC.
2324 VM_DEFINE_OP (78, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2328 UNPACK_12_12 (op
, a
, b
);
2331 VM_VALIDATE_PAIR (x
, "set-car!");
2340 * Numeric operations
2343 /* add dst:8 a:8 b:8
2345 * Add A to B, and place the result in DST.
2347 VM_DEFINE_OP (79, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2349 BINARY_INTEGER_OP (+, scm_sum
);
2352 /* add1 dst:12 src:12
2354 * Add 1 to the value in SRC, and place the result in DST.
2356 VM_DEFINE_OP (80, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2360 /* Check for overflow. We must avoid overflow in the signed
2361 addition below, even if X is not an inum. */
2362 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2366 /* Add 1 to the integer without untagging. */
2367 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2369 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2374 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2377 /* sub dst:8 a:8 b:8
2379 * Subtract B from A, and place the result in DST.
2381 VM_DEFINE_OP (81, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2383 BINARY_INTEGER_OP (-, scm_difference
);
2386 /* sub1 dst:12 src:12
2388 * Subtract 1 from SRC, and place the result in DST.
2390 VM_DEFINE_OP (82, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2394 /* Check for overflow. We must avoid overflow in the signed
2395 subtraction below, even if X is not an inum. */
2396 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2400 /* Substract 1 from the integer without untagging. */
2401 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2403 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2408 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2411 /* mul dst:8 a:8 b:8
2413 * Multiply A and B, and place the result in DST.
2415 VM_DEFINE_OP (83, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2419 RETURN (scm_product (x
, y
));
2422 /* div dst:8 a:8 b:8
2424 * Divide A by B, and place the result in DST.
2426 VM_DEFINE_OP (84, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2430 RETURN (scm_divide (x
, y
));
2433 /* quo dst:8 a:8 b:8
2435 * Divide A by B, and place the quotient in DST.
2437 VM_DEFINE_OP (85, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2441 RETURN (scm_quotient (x
, y
));
2444 /* rem dst:8 a:8 b:8
2446 * Divide A by B, and place the remainder in DST.
2448 VM_DEFINE_OP (86, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2452 RETURN (scm_remainder (x
, y
));
2455 /* mod dst:8 a:8 b:8
2457 * Place the modulo of A by B in DST.
2459 VM_DEFINE_OP (87, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2463 RETURN (scm_modulo (x
, y
));
2466 /* ash dst:8 a:8 b:8
2468 * Shift A arithmetically by B bits, and place the result in DST.
2470 VM_DEFINE_OP (88, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2473 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2475 if (SCM_I_INUM (y
) < 0)
2476 /* Right shift, will be a fixnum. */
2477 RETURN (SCM_I_MAKINUM
2478 (SCM_SRS (SCM_I_INUM (x
),
2479 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2480 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2482 /* Left shift. See comments in scm_ash. */
2484 scm_t_signed_bits nn
, bits_to_shift
;
2486 nn
= SCM_I_INUM (x
);
2487 bits_to_shift
= SCM_I_INUM (y
);
2489 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2491 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2493 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2499 RETURN (scm_ash (x
, y
));
2502 /* logand dst:8 a:8 b:8
2504 * Place the bitwise AND of A and B into DST.
2506 VM_DEFINE_OP (89, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2509 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2510 /* Compute bitwise AND without untagging */
2511 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2513 RETURN (scm_logand (x
, y
));
2516 /* logior dst:8 a:8 b:8
2518 * Place the bitwise inclusive OR of A with B in DST.
2520 VM_DEFINE_OP (90, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2523 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2524 /* Compute bitwise OR without untagging */
2525 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2527 RETURN (scm_logior (x
, y
));
2530 /* logxor dst:8 a:8 b:8
2532 * Place the bitwise exclusive OR of A with B in DST.
2534 VM_DEFINE_OP (91, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2537 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2538 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2540 RETURN (scm_logxor (x
, y
));
2543 /* make-vector/immediate dst:8 length:8 init:8
2545 * Make a short vector of known size and write it to DST. The vector
2546 * will have space for LENGTH slots, an immediate value. They will be
2547 * filled with the value in slot INIT.
2549 VM_DEFINE_OP (92, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2551 scm_t_uint8 dst
, init
;
2552 scm_t_int32 length
, n
;
2555 UNPACK_8_8_8 (op
, dst
, length
, init
);
2557 val
= LOCAL_REF (init
);
2558 vector
= scm_words (scm_tc7_vector
| (length
<< 8), length
+ 1);
2559 for (n
= 0; n
< length
; n
++)
2560 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2561 LOCAL_SET (dst
, vector
);
2565 /* vector-length dst:12 src:12
2567 * Store the length of the vector in SRC in DST.
2569 VM_DEFINE_OP (93, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2572 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2573 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2577 RETURN (scm_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 (94, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2588 scm_t_signed_bits i
= 0;
2590 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2591 && SCM_I_INUMP (idx
)
2592 && ((i
= SCM_I_INUM (idx
)) >= 0)
2593 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2594 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2598 RETURN (scm_vector_ref (vect
, idx
));
2602 /* vector-ref/immediate dst:8 src:8 idx:8
2604 * Fill DST with the item IDX elements into the vector at SRC. Useful
2605 * for building data types using vectors.
2607 VM_DEFINE_OP (95, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2609 scm_t_uint8 dst
, src
, idx
;
2612 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2613 v
= LOCAL_REF (src
);
2614 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2615 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2616 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2618 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2622 /* vector-set! dst:8 idx:8 src:8
2624 * Store SRC into the vector DST at index IDX.
2626 VM_DEFINE_OP (96, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2628 scm_t_uint8 dst
, idx_var
, src
;
2630 scm_t_signed_bits i
= 0;
2632 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2633 vect
= LOCAL_REF (dst
);
2634 idx
= LOCAL_REF (idx_var
);
2635 val
= LOCAL_REF (src
);
2637 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2638 && SCM_I_INUMP (idx
)
2639 && ((i
= SCM_I_INUM (idx
)) >= 0)
2640 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2641 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2645 scm_vector_set_x (vect
, idx
, val
);
2650 /* vector-set!/immediate dst:8 idx:8 src:8
2652 * Store SRC into the vector DST at index IDX. Here IDX is an
2655 VM_DEFINE_OP (97, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2657 scm_t_uint8 dst
, idx
, src
;
2660 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2661 vect
= LOCAL_REF (dst
);
2662 val
= LOCAL_REF (src
);
2664 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2665 && idx
< SCM_I_VECTOR_LENGTH (vect
)))
2666 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2670 scm_vector_set_x (vect
, scm_from_uint8 (idx
), val
);
2682 /* struct-vtable dst:12 src:12
2684 * Store the vtable of SRC into DST.
2686 VM_DEFINE_OP (98, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2689 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2690 RETURN (SCM_STRUCT_VTABLE (obj
));
2693 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2695 * Allocate a new struct with VTABLE, and place it in DST. The struct
2696 * will be constructed with space for NFIELDS fields, which should
2697 * correspond to the field count of the VTABLE.
2699 VM_DEFINE_OP (99, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2701 scm_t_uint8 dst
, vtable
, nfields
;
2704 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2707 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2708 LOCAL_SET (dst
, ret
);
2713 /* struct-ref/immediate dst:8 src:8 idx:8
2715 * Fetch the item at slot IDX in the struct in SRC, and store it
2716 * in DST. IDX is an immediate unsigned 8-bit value.
2718 VM_DEFINE_OP (100, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2720 scm_t_uint8 dst
, src
, idx
;
2723 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2725 obj
= LOCAL_REF (src
);
2727 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2728 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2729 SCM_VTABLE_FLAG_SIMPLE
)
2730 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2731 scm_vtable_index_size
)))
2732 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2735 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2738 /* struct-set!/immediate dst:8 idx:8 src:8
2740 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2741 * unsigned 8-bit value.
2743 VM_DEFINE_OP (101, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2745 scm_t_uint8 dst
, idx
, src
;
2748 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2750 obj
= LOCAL_REF (dst
);
2751 val
= LOCAL_REF (src
);
2753 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2754 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2755 SCM_VTABLE_FLAG_SIMPLE
)
2756 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2757 SCM_VTABLE_FLAG_SIMPLE_RW
)
2758 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2759 scm_vtable_index_size
)))
2761 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2766 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2770 /* class-of dst:12 type:12
2772 * Store the vtable of SRC into DST.
2774 VM_DEFINE_OP (102, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2777 if (SCM_INSTANCEP (obj
))
2778 RETURN (SCM_CLASS_OF (obj
));
2780 RETURN (scm_class_of (obj
));
2783 /* slot-ref dst:8 src:8 idx:8
2785 * Fetch the item at slot IDX in the struct in SRC, and store it in
2786 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
2787 * index into the stack.
2789 VM_DEFINE_OP (103, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2791 scm_t_uint8 dst
, src
, idx
;
2792 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2794 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
2798 /* slot-set! dst:8 idx:8 src:8
2800 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
2801 * IDX is an 8-bit immediate value, not an index into the stack.
2803 VM_DEFINE_OP (104, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
2805 scm_t_uint8 dst
, idx
, src
;
2806 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2807 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
2815 * Arrays, packed uniform arrays, and bytevectors.
2818 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2820 * Load the contiguous typed array located at OFFSET 32-bit words away
2821 * from the instruction pointer, and store into DST. LEN is a byte
2822 * length. OFFSET is signed.
2824 VM_DEFINE_OP (105, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2826 scm_t_uint8 dst
, type
, shape
;
2830 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2834 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2840 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
2842 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2844 VM_DEFINE_OP (106, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
2846 scm_t_uint16 dst
, type
, fill
, bounds
;
2847 UNPACK_12_12 (op
, dst
, type
);
2848 UNPACK_12_12 (ip
[1], fill
, bounds
);
2850 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2851 LOCAL_REF (bounds
)));
2855 /* bv-u8-ref dst:8 src:8 idx:8
2856 * bv-s8-ref dst:8 src:8 idx:8
2857 * bv-u16-ref dst:8 src:8 idx:8
2858 * bv-s16-ref dst:8 src:8 idx:8
2859 * bv-u32-ref dst:8 src:8 idx:8
2860 * bv-s32-ref dst:8 src:8 idx:8
2861 * bv-u64-ref dst:8 src:8 idx:8
2862 * bv-s64-ref dst:8 src:8 idx:8
2863 * bv-f32-ref dst:8 src:8 idx:8
2864 * bv-f64-ref dst:8 src:8 idx:8
2866 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2867 * it in DST. All accesses use native endianness.
2869 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2871 scm_t_signed_bits i; \
2872 const scm_t_ ## type *int_ptr; \
2875 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2876 i = SCM_I_INUM (idx); \
2877 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2879 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2881 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2882 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2883 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2887 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2891 #define BV_INT_REF(stem, type, size) \
2893 scm_t_signed_bits i; \
2894 const scm_t_ ## type *int_ptr; \
2897 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2898 i = SCM_I_INUM (idx); \
2899 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2901 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2903 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2904 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2906 scm_t_ ## type x = *int_ptr; \
2907 if (SCM_FIXABLE (x)) \
2908 RETURN (SCM_I_MAKINUM (x)); \
2912 RETURN (scm_from_ ## type (x)); \
2918 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2922 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2924 scm_t_signed_bits i; \
2925 const type *float_ptr; \
2928 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2929 i = SCM_I_INUM (idx); \
2930 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2933 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2935 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2936 && (ALIGNED_P (float_ptr, type)))) \
2937 RETURN (scm_from_double (*float_ptr)); \
2939 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2942 VM_DEFINE_OP (107, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2943 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2945 VM_DEFINE_OP (108, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2946 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2948 VM_DEFINE_OP (109, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2949 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2951 VM_DEFINE_OP (110, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2952 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2954 VM_DEFINE_OP (111, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2955 #if SIZEOF_VOID_P > 4
2956 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2958 BV_INT_REF (u32
, uint32
, 4);
2961 VM_DEFINE_OP (112, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2962 #if SIZEOF_VOID_P > 4
2963 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2965 BV_INT_REF (s32
, int32
, 4);
2968 VM_DEFINE_OP (113, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2969 BV_INT_REF (u64
, uint64
, 8);
2971 VM_DEFINE_OP (114, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2972 BV_INT_REF (s64
, int64
, 8);
2974 VM_DEFINE_OP (115, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2975 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2977 VM_DEFINE_OP (116, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2978 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2980 /* bv-u8-set! dst:8 idx:8 src:8
2981 * bv-s8-set! dst:8 idx:8 src:8
2982 * bv-u16-set! dst:8 idx:8 src:8
2983 * bv-s16-set! dst:8 idx:8 src:8
2984 * bv-u32-set! dst:8 idx:8 src:8
2985 * bv-s32-set! dst:8 idx:8 src:8
2986 * bv-u64-set! dst:8 idx:8 src:8
2987 * bv-s64-set! dst:8 idx:8 src:8
2988 * bv-f32-set! dst:8 idx:8 src:8
2989 * bv-f64-set! dst:8 idx:8 src:8
2991 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2992 * values are written using native endianness.
2994 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2996 scm_t_uint8 dst, idx, src; \
2997 scm_t_signed_bits i, j = 0; \
2998 SCM bv, scm_idx, val; \
2999 scm_t_ ## type *int_ptr; \
3001 UNPACK_8_8_8 (op, dst, idx, src); \
3002 bv = LOCAL_REF (dst); \
3003 scm_idx = LOCAL_REF (idx); \
3004 val = LOCAL_REF (src); \
3005 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3006 i = SCM_I_INUM (scm_idx); \
3007 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3009 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3011 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3012 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3013 && (SCM_I_INUMP (val)) \
3014 && ((j = SCM_I_INUM (val)) >= min) \
3016 *int_ptr = (scm_t_ ## type) j; \
3020 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3025 #define BV_INT_SET(stem, type, size) \
3027 scm_t_uint8 dst, idx, src; \
3028 scm_t_signed_bits i; \
3029 SCM bv, scm_idx, val; \
3030 scm_t_ ## type *int_ptr; \
3032 UNPACK_8_8_8 (op, dst, idx, src); \
3033 bv = LOCAL_REF (dst); \
3034 scm_idx = LOCAL_REF (idx); \
3035 val = LOCAL_REF (src); \
3036 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3037 i = SCM_I_INUM (scm_idx); \
3038 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3040 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3042 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3043 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3044 *int_ptr = scm_to_ ## type (val); \
3048 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3053 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3055 scm_t_uint8 dst, idx, src; \
3056 scm_t_signed_bits i; \
3057 SCM bv, scm_idx, val; \
3060 UNPACK_8_8_8 (op, dst, idx, src); \
3061 bv = LOCAL_REF (dst); \
3062 scm_idx = LOCAL_REF (idx); \
3063 val = LOCAL_REF (src); \
3064 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3065 i = SCM_I_INUM (scm_idx); \
3066 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3068 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3070 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3071 && (ALIGNED_P (float_ptr, type)))) \
3072 *float_ptr = scm_to_double (val); \
3076 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3081 VM_DEFINE_OP (117, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3082 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3084 VM_DEFINE_OP (118, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3085 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3087 VM_DEFINE_OP (119, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3088 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3090 VM_DEFINE_OP (120, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3091 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3093 VM_DEFINE_OP (121, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3094 #if SIZEOF_VOID_P > 4
3095 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3097 BV_INT_SET (u32
, uint32
, 4);
3100 VM_DEFINE_OP (122, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3101 #if SIZEOF_VOID_P > 4
3102 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3104 BV_INT_SET (s32
, int32
, 4);
3107 VM_DEFINE_OP (123, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3108 BV_INT_SET (u64
, uint64
, 8);
3110 VM_DEFINE_OP (124, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3111 BV_INT_SET (s64
, int64
, 8);
3113 VM_DEFINE_OP (125, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3114 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3116 VM_DEFINE_OP (126, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3117 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3119 END_DISPATCH_SWITCH
;
3121 vm_error_bad_instruction
:
3122 vm_error_bad_instruction (op
);
3124 abort (); /* never reached */
3128 #undef ABORT_CONTINUATION_HOOK
3133 #undef BEGIN_DISPATCH_SWITCH
3134 #undef BINARY_INTEGER_OP
3135 #undef BR_ARITHMETIC
3139 #undef BV_FIXABLE_INT_REF
3140 #undef BV_FIXABLE_INT_SET
3145 #undef CACHE_REGISTER
3146 #undef CHECK_OVERFLOW
3147 #undef END_DISPATCH_SWITCH
3148 #undef FREE_VARIABLE_REF
3157 #undef POP_CONTINUATION_HOOK
3158 #undef PUSH_CONTINUATION_HOOK
3159 #undef RESTORE_CONTINUATION_HOOK
3161 #undef RETURN_ONE_VALUE
3162 #undef RETURN_VALUE_LIST
3167 #undef SYNC_BEFORE_GC
3169 #undef SYNC_REGISTER
3175 #undef VARIABLE_BOUNDP
3178 #undef VM_CHECK_FREE_VARIABLE
3179 #undef VM_CHECK_OBJECT
3180 #undef VM_CHECK_UNDERFLOW
3182 #undef VM_INSTRUCTION_TO_LABEL
3184 #undef VM_VALIDATE_BYTEVECTOR
3185 #undef VM_VALIDATE_PAIR
3186 #undef VM_VALIDATE_STRUCT
3189 (defun renumber-ops ()
3190 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3193 (let ((counter -1)) (goto-char (point-min))
3194 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3196 (number-to-string (setq counter (1+ counter)))