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 vm
, 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 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
443 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
444 scm_i_jmp_buf registers
; /* used for prompts */
446 #ifdef HAVE_LABELS_AS_VALUES
447 static const void **jump_table_pointer
= NULL
;
448 register const void **jump_table JT_REG
;
450 if (SCM_UNLIKELY (!jump_table_pointer
))
453 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
454 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
455 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
456 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
457 FOR_EACH_VM_OPERATION(INIT
);
461 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
462 load instruction at each instruction dispatch. */
463 jump_table
= jump_table_pointer
;
466 if (SCM_I_SETJMP (registers
))
468 /* Non-local return. The values are on the stack, on a new frame
469 set up to call `values' to return the values to the handler.
470 Cache the VM registers back from the vp, and dispatch to the
473 Note, at this point, we must assume that any variable local to
474 vm_engine that can be assigned *has* been assigned. So we need
475 to pull all our state back from the ip/fp/sp.
478 ABORT_CONTINUATION_HOOK ();
482 /* Load previous VM registers. */
485 VM_HANDLE_INTERRUPTS
;
490 ptrdiff_t base_frame_size
;
492 /* Check that we have enough space: 3 words for the boot
493 continuation, 3 + nargs for the procedure application, and 3 for
494 setting up a new frame. */
495 base_frame_size
= 3 + 3 + nargs_
+ 3;
496 vp
->sp
+= base_frame_size
;
498 base
= vp
->sp
+ 1 - base_frame_size
;
500 /* Since it's possible to receive the arguments on the stack itself,
501 and indeed the regular VM invokes us that way, shuffle up the
505 for (i
= nargs_
- 1; i
>= 0; i
--)
506 base
[6 + i
] = argv
[i
];
509 /* Initial frame, saving previous fp and ip, with the boot
511 base
[0] = SCM_PACK (fp
); /* dynamic link */
512 base
[1] = SCM_PACK (ip
); /* ra */
513 base
[2] = vm_boot_continuation
;
515 ip
= (scm_t_uint32
*) vm_boot_continuation_code
;
517 /* MV-call frame, function & arguments */
518 base
[3] = SCM_PACK (fp
); /* dynamic link */
519 base
[4] = SCM_PACK (ip
); /* ra */
521 fp
= vp
->fp
= &base
[5];
522 RESET_FRAME (nargs_
+ 1);
526 while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
528 SCM proc
= SCM_FRAME_PROGRAM (fp
);
530 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
532 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
535 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
537 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
539 /* Shuffle args up. */
542 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
544 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
549 vm_error_wrong_type_apply (proc
);
553 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
556 BEGIN_DISPATCH_SWITCH
;
567 * Bring the VM to a halt, returning all the values from the stack.
569 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
571 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
573 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
583 for (n
= nvals
; n
> 0; n
--)
584 ret
= scm_cons (LOCAL_REF (4 + n
- 1), ret
);
585 ret
= scm_values (ret
);
588 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
589 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
590 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
595 /* call proc:24 _:8 nlocals:24
597 * Call a procedure. PROC is the local corresponding to a procedure.
598 * The three values below PROC will be overwritten by the saved call
599 * frame data. The new frame will have space for NLOCALS locals: one
600 * for the procedure, and the rest for the arguments which should
601 * already have been pushed on.
603 * When the call returns, execution proceeds with the next
604 * instruction. There may be any number of values on the return
605 * stack; the precise number can be had by subtracting the address of
606 * PROC from the post-call SP.
608 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
610 scm_t_uint32 proc
, nlocals
;
613 UNPACK_24 (op
, proc
);
614 UNPACK_24 (ip
[1], nlocals
);
616 VM_HANDLE_INTERRUPTS
;
618 fp
= vp
->fp
= old_fp
+ proc
;
619 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
620 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
622 RESET_FRAME (nlocals
);
624 PUSH_CONTINUATION_HOOK ();
627 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
630 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
634 /* tail-call nlocals:24
636 * Tail-call a procedure. Requires that the procedure and all of the
637 * arguments have already been shuffled into position. Will reset the
640 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
642 scm_t_uint32 nlocals
;
644 UNPACK_24 (op
, nlocals
);
646 VM_HANDLE_INTERRUPTS
;
648 RESET_FRAME (nlocals
);
652 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
655 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
659 /* tail-call/shuffle from:24
661 * Tail-call a procedure. The procedure should already be set to slot
662 * 0. The rest of the args are taken from the frame, starting at
663 * FROM, shuffled down to start at slot 0. This is part of the
664 * implementation of the call-with-values builtin.
666 VM_DEFINE_OP (3, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
668 scm_t_uint32 n
, from
, nlocals
;
670 UNPACK_24 (op
, from
);
672 VM_HANDLE_INTERRUPTS
;
674 VM_ASSERT (from
> 0, abort ());
675 nlocals
= FRAME_LOCALS_COUNT ();
677 for (n
= 0; from
+ n
< nlocals
; n
++)
678 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
684 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
687 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
691 /* receive dst:12 proc:12 _:8 nlocals:24
693 * Receive a single return value from a call whose procedure was in
694 * PROC, asserting that the call actually returned at least one
695 * value. Afterwards, resets the frame to NLOCALS locals.
697 VM_DEFINE_OP (4, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
699 scm_t_uint16 dst
, proc
;
700 scm_t_uint32 nlocals
;
701 UNPACK_12_12 (op
, dst
, proc
);
702 UNPACK_24 (ip
[1], nlocals
);
703 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
704 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
705 RESET_FRAME (nlocals
);
709 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
711 * Receive a return of multiple values from a call whose procedure was
712 * in PROC. If fewer than NVALUES values were returned, signal an
713 * error. Unless ALLOW-EXTRA? is true, require that the number of
714 * return values equals NVALUES exactly. After receive-values has
715 * run, the values can be copied down via `mov'.
717 VM_DEFINE_OP (5, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
719 scm_t_uint32 proc
, nvalues
;
720 UNPACK_24 (op
, proc
);
721 UNPACK_24 (ip
[1], nvalues
);
723 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
724 vm_error_not_enough_values ());
726 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
727 vm_error_wrong_number_of_values (nvalues
));
735 VM_DEFINE_OP (6, return, "return", OP1 (U8_U24
))
739 RETURN_ONE_VALUE (LOCAL_REF (src
));
742 /* return-values _:24
744 * Return a number of values from a call frame. This opcode
745 * corresponds to an application of `values' in tail position. As
746 * with tail calls, we expect that the values have already been
747 * shuffled down to a contiguous array starting at slot 1.
748 * We also expect the frame has already been reset.
750 VM_DEFINE_OP (7, return_values
, "return-values", OP1 (U8_X24
))
754 VM_HANDLE_INTERRUPTS
;
755 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
756 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
758 /* Clear stack frame. */
759 old_fp
[-1] = SCM_BOOL_F
;
760 old_fp
[-2] = SCM_BOOL_F
;
762 POP_CONTINUATION_HOOK (old_fp
);
771 * Specialized call stubs
774 /* subr-call ptr-idx:24
776 * Call a subr, passing all locals in this frame as arguments. Fetch
777 * the foreign pointer from PTR-IDX, a free variable. Return from the
778 * calling frame. This instruction is part of the trampolines
779 * created in gsubr.c, and is not generated by the compiler.
781 VM_DEFINE_OP (8, subr_call
, "subr-call", OP1 (U8_U24
))
783 scm_t_uint32 ptr_idx
;
787 UNPACK_24 (op
, ptr_idx
);
789 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
790 subr
= SCM_POINTER_VALUE (pointer
);
792 VM_HANDLE_INTERRUPTS
;
795 switch (FRAME_LOCALS_COUNT_FROM (1))
804 ret
= subr (fp
[1], fp
[2]);
807 ret
= subr (fp
[1], fp
[2], fp
[3]);
810 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
813 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
816 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
819 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
822 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
825 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
828 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
834 // NULLSTACK_FOR_NONLOCAL_EXIT ();
836 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
837 /* multiple values returned to continuation */
838 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
840 RETURN_ONE_VALUE (ret
);
843 /* foreign-call cif-idx:12 ptr-idx:12
845 * Call a foreign function. Fetch the CIF and foreign pointer from
846 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
847 * frame. Arguments are taken from the stack. This instruction is
848 * part of the trampolines created by the FFI, and is not generated by
851 VM_DEFINE_OP (9, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
853 scm_t_uint16 cif_idx
, ptr_idx
;
854 SCM closure
, cif
, pointer
, ret
;
856 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
858 closure
= LOCAL_REF (0);
859 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
860 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
863 VM_HANDLE_INTERRUPTS
;
865 // FIXME: separate args
866 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), LOCAL_ADDRESS (1));
868 // NULLSTACK_FOR_NONLOCAL_EXIT ();
870 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
871 /* multiple values returned to continuation */
872 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
874 RETURN_ONE_VALUE (ret
);
877 /* continuation-call contregs:24
879 * Return to a continuation, nonlocally. The arguments to the
880 * continuation are taken from the stack. CONTREGS is a free variable
881 * containing the reified continuation. This instruction is part of
882 * the implementation of undelimited continuations, and is not
883 * generated by the compiler.
885 VM_DEFINE_OP (10, continuation_call
, "continuation-call", OP1 (U8_U24
))
888 scm_t_uint32 contregs_idx
;
890 UNPACK_24 (op
, contregs_idx
);
893 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
896 scm_i_check_continuation (contregs
);
897 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
898 scm_i_contregs_vm_cont (contregs
),
899 FRAME_LOCALS_COUNT_FROM (1),
901 scm_i_reinstate_continuation (contregs
);
907 /* compose-continuation cont:24
909 * Compose a partial continution with the current continuation. The
910 * arguments to the continuation are taken from the stack. CONT is a
911 * free variable containing the reified continuation. This
912 * instruction is part of the implementation of partial continuations,
913 * and is not generated by the compiler.
915 VM_DEFINE_OP (11, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
918 scm_t_uint32 cont_idx
;
920 UNPACK_24 (op
, cont_idx
);
921 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
924 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
925 vm_error_continuation_not_rewindable (vmcont
));
926 vm_reinstate_partial_continuation (vm
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
928 ¤t_thread
->dynstack
,
936 * Tail-apply the procedure in local slot 0 to the rest of the
937 * arguments. This instruction is part of the implementation of
938 * `apply', and is not generated by the compiler.
940 VM_DEFINE_OP (12, tail_apply
, "tail-apply", OP1 (U8_X24
))
942 int i
, list_idx
, list_len
, nlocals
;
945 VM_HANDLE_INTERRUPTS
;
947 nlocals
= FRAME_LOCALS_COUNT ();
948 // At a minimum, there should be apply, f, and the list.
949 VM_ASSERT (nlocals
>= 3, abort ());
950 list_idx
= nlocals
- 1;
951 list
= LOCAL_REF (list_idx
);
952 list_len
= scm_ilength (list
);
954 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
956 nlocals
= nlocals
- 2 + list_len
;
957 ALLOC_FRAME (nlocals
);
959 for (i
= 1; i
< list_idx
; i
++)
960 LOCAL_SET (i
- 1, LOCAL_REF (i
));
962 /* Null out these slots, just in case there are less than 2 elements
964 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
965 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
967 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
968 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
972 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
975 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
981 * Capture the current continuation, and tail-apply the procedure in
982 * local slot 1 to it. This instruction is part of the implementation
983 * of `call/cc', and is not generated by the compiler.
985 VM_DEFINE_OP (13, call_cc
, "call/cc", OP1 (U8_X24
))
988 scm_t_dynstack
*dynstack
;
991 VM_HANDLE_INTERRUPTS
;
994 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
995 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
996 SCM_FRAME_DYNAMIC_LINK (fp
),
997 SCM_FRAME_PREVIOUS_SP (fp
),
998 SCM_FRAME_RETURN_ADDRESS (fp
),
1001 /* FIXME: Seems silly to capture the registers here, when they are
1002 already captured in the registers local, which here we are
1003 copying out to the heap; and likewise, the setjmp(®isters)
1004 code already has the non-local return handler. But oh
1006 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1010 LOCAL_SET (0, LOCAL_REF (1));
1011 LOCAL_SET (1, cont
);
1016 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1019 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1025 ABORT_CONTINUATION_HOOK ();
1032 * Abort to a prompt handler. The tag is expected in r1, and the rest
1033 * of the values in the frame are returned to the prompt handler.
1034 * This corresponds to a tail application of abort-to-prompt.
1036 VM_DEFINE_OP (14, abort
, "abort", OP1 (U8_X24
))
1038 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1040 ASSERT (nlocals
>= 2);
1041 /* FIXME: Really we should capture the caller's registers. Until
1042 then, manually advance the IP so that when the prompt resumes,
1043 it continues with the next instruction. */
1046 vm_abort (vm
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1047 SCM_EOL
, LOCAL_ADDRESS (0), ®isters
);
1049 /* vm_abort should not return */
1053 /* builtin-ref dst:12 idx:12
1055 * Load a builtin stub by index into DST.
1057 VM_DEFINE_OP (15, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1059 scm_t_uint16 dst
, idx
;
1061 UNPACK_12_12 (op
, dst
, idx
);
1062 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1071 * Function prologues
1074 /* br-if-nargs-ne expected:24 _:8 offset:24
1075 * br-if-nargs-lt expected:24 _:8 offset:24
1076 * br-if-nargs-gt expected:24 _:8 offset:24
1078 * If the number of actual arguments is not equal, less than, or greater
1079 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1080 * the current instruction pointer.
1082 VM_DEFINE_OP (16, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1086 VM_DEFINE_OP (17, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1090 VM_DEFINE_OP (18, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1095 /* assert-nargs-ee expected:24
1096 * assert-nargs-ge expected:24
1097 * assert-nargs-le expected:24
1099 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1100 * respectively, signal an error.
1102 VM_DEFINE_OP (19, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1104 scm_t_uint32 expected
;
1105 UNPACK_24 (op
, expected
);
1106 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1107 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1110 VM_DEFINE_OP (20, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1112 scm_t_uint32 expected
;
1113 UNPACK_24 (op
, expected
);
1114 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1115 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1118 VM_DEFINE_OP (21, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1120 scm_t_uint32 expected
;
1121 UNPACK_24 (op
, expected
);
1122 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1123 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1127 /* alloc-frame nlocals:24
1129 * Ensure that there is space on the stack for NLOCALS local variables,
1130 * setting them all to SCM_UNDEFINED, except those nargs values that
1131 * were passed as arguments and procedure.
1133 VM_DEFINE_OP (22, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1135 scm_t_uint32 nlocals
, nargs
;
1136 UNPACK_24 (op
, nlocals
);
1138 nargs
= FRAME_LOCALS_COUNT ();
1139 ALLOC_FRAME (nlocals
);
1140 while (nlocals
-- > nargs
)
1141 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1146 /* reset-frame nlocals:24
1148 * Like alloc-frame, but doesn't check that the stack is big enough.
1149 * Used to reset the frame size to something less than the size that
1150 * was previously set via alloc-frame.
1152 VM_DEFINE_OP (23, reset_frame
, "reset-frame", OP1 (U8_U24
))
1154 scm_t_uint32 nlocals
;
1155 UNPACK_24 (op
, nlocals
);
1156 RESET_FRAME (nlocals
);
1160 /* assert-nargs-ee/locals expected:12 nlocals:12
1162 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1163 * number of locals reserved is EXPECTED + NLOCALS.
1165 VM_DEFINE_OP (24, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1167 scm_t_uint16 expected
, nlocals
;
1168 UNPACK_12_12 (op
, expected
, nlocals
);
1169 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1170 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1171 ALLOC_FRAME (expected
+ nlocals
);
1173 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1178 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1180 * Find the first positional argument after NREQ. If it is greater
1181 * than NPOS, jump to OFFSET.
1183 * This instruction is only emitted for functions with multiple
1184 * clauses, and an earlier clause has keywords and no rest arguments.
1185 * See "Case-lambda" in the manual, for more on how case-lambda
1186 * chooses the clause to apply.
1188 VM_DEFINE_OP (25, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1190 scm_t_uint32 nreq
, npos
;
1192 UNPACK_24 (op
, nreq
);
1193 UNPACK_24 (ip
[1], npos
);
1195 /* We can only have too many positionals if there are more
1196 arguments than NPOS. */
1197 if (FRAME_LOCALS_COUNT() > npos
)
1200 for (n
= nreq
; n
< npos
; n
++)
1201 if (scm_is_keyword (LOCAL_REF (n
)))
1203 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1205 scm_t_int32 offset
= ip
[2];
1206 offset
>>= 8; /* Sign-extending shift. */
1213 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1214 * _:8 ntotal:24 kw-offset:32
1216 * Find the last positional argument, and shuffle all the rest above
1217 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1218 * load the constant at KW-OFFSET words from the current IP, and use it
1219 * to bind keyword arguments. If HAS-REST, collect all shuffled
1220 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1221 * the arguments that we shuffled up.
1223 * A macro-mega-instruction.
1225 VM_DEFINE_OP (26, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1227 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1228 scm_t_int32 kw_offset
;
1231 char allow_other_keys
, has_rest
;
1233 UNPACK_24 (op
, nreq
);
1234 allow_other_keys
= ip
[1] & 0x1;
1235 has_rest
= ip
[1] & 0x2;
1236 UNPACK_24 (ip
[1], nreq_and_opt
);
1237 UNPACK_24 (ip
[2], ntotal
);
1239 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1240 VM_ASSERT (!(kw_bits
& 0x7), abort());
1241 kw
= SCM_PACK (kw_bits
);
1243 nargs
= FRAME_LOCALS_COUNT ();
1245 /* look in optionals for first keyword or last positional */
1246 /* starting after the last required positional arg */
1248 while (/* while we have args */
1250 /* and we still have positionals to fill */
1251 && npositional
< nreq_and_opt
1252 /* and we haven't reached a keyword yet */
1253 && !scm_is_keyword (LOCAL_REF (npositional
)))
1254 /* bind this optional arg (by leaving it in place) */
1256 nkw
= nargs
- npositional
;
1257 /* shuffle non-positional arguments above ntotal */
1258 ALLOC_FRAME (ntotal
+ nkw
);
1261 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1262 /* and fill optionals & keyword args with SCM_UNDEFINED */
1265 LOCAL_SET (n
++, SCM_UNDEFINED
);
1267 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1268 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1270 /* Now bind keywords, in the order given. */
1271 for (n
= 0; n
< nkw
; n
++)
1272 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1275 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1276 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1278 SCM si
= SCM_CDAR (walk
);
1279 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1280 LOCAL_REF (ntotal
+ n
+ 1));
1283 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1284 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1285 LOCAL_REF (ntotal
+ n
)));
1289 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1290 LOCAL_REF (ntotal
+ n
)));
1297 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1298 LOCAL_SET (nreq_and_opt
, rest
);
1301 RESET_FRAME (ntotal
);
1308 * Collect any arguments at or above DST into a list, and store that
1311 VM_DEFINE_OP (27, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1313 scm_t_uint32 dst
, nargs
;
1316 UNPACK_24 (op
, dst
);
1317 nargs
= FRAME_LOCALS_COUNT ();
1321 ALLOC_FRAME (dst
+ 1);
1323 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1327 while (nargs
-- > dst
)
1329 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1330 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1333 RESET_FRAME (dst
+ 1);
1336 LOCAL_SET (dst
, rest
);
1345 * Branching instructions
1350 * Add OFFSET, a signed 24-bit number, to the current instruction
1353 VM_DEFINE_OP (28, br
, "br", OP1 (U8_L24
))
1355 scm_t_int32 offset
= op
;
1356 offset
>>= 8; /* Sign-extending shift. */
1360 /* br-if-true test:24 invert:1 _:7 offset:24
1362 * If the value in TEST is true for the purposes of Scheme, add
1363 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1365 VM_DEFINE_OP (29, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1367 BR_UNARY (x
, scm_is_true (x
));
1370 /* br-if-null test:24 invert:1 _:7 offset:24
1372 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1373 * signed 24-bit number, to the current instruction pointer.
1375 VM_DEFINE_OP (30, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1377 BR_UNARY (x
, scm_is_null (x
));
1380 /* br-if-nil test:24 invert:1 _:7 offset:24
1382 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1383 * number, to the current instruction pointer.
1385 VM_DEFINE_OP (31, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1387 BR_UNARY (x
, scm_is_lisp_false (x
));
1390 /* br-if-pair test:24 invert:1 _:7 offset:24
1392 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1393 * to the current instruction pointer.
1395 VM_DEFINE_OP (32, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1397 BR_UNARY (x
, scm_is_pair (x
));
1400 /* br-if-struct test:24 invert:1 _:7 offset:24
1402 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1403 * number, to the current instruction pointer.
1405 VM_DEFINE_OP (33, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1407 BR_UNARY (x
, SCM_STRUCTP (x
));
1410 /* br-if-char test:24 invert:1 _:7 offset:24
1412 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1413 * to the current instruction pointer.
1415 VM_DEFINE_OP (34, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1417 BR_UNARY (x
, SCM_CHARP (x
));
1420 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1422 * If the value in TEST has the TC7 given in the second word, add
1423 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1425 VM_DEFINE_OP (35, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1427 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1430 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1432 * If the value in A is eq? to the value in B, add OFFSET, a signed
1433 * 24-bit number, to the current instruction pointer.
1435 VM_DEFINE_OP (36, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1437 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1440 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1442 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1443 * 24-bit number, to the current instruction pointer.
1445 VM_DEFINE_OP (37, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1449 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1450 && scm_is_true (scm_eqv_p (x
, y
))));
1453 // FIXME: remove, have compiler inline eqv test instead
1454 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1456 * If the value in A is equal? to the value in B, add OFFSET, a signed
1457 * 24-bit number, to the current instruction pointer.
1459 // FIXME: should sync_ip before calling out?
1460 VM_DEFINE_OP (38, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1464 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1465 && scm_is_true (scm_equal_p (x
, y
))));
1468 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1470 * If the value in A is = to the value in B, add OFFSET, a signed
1471 * 24-bit number, to the current instruction pointer.
1473 VM_DEFINE_OP (39, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1475 BR_ARITHMETIC (==, scm_num_eq_p
);
1478 /* br-if-< a:12 b:12 _:8 offset:24
1480 * If the value in A is < to the value in B, add OFFSET, a signed
1481 * 24-bit number, to the current instruction pointer.
1483 VM_DEFINE_OP (40, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1485 BR_ARITHMETIC (<, scm_less_p
);
1488 /* br-if-<= a:12 b:12 _:8 offset:24
1490 * If the value in A is <= to the value in B, add OFFSET, a signed
1491 * 24-bit number, to the current instruction pointer.
1493 VM_DEFINE_OP (41, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1495 BR_ARITHMETIC (<=, scm_leq_p
);
1502 * Lexical binding instructions
1505 /* mov dst:12 src:12
1507 * Copy a value from one local slot to another.
1509 VM_DEFINE_OP (42, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1514 UNPACK_12_12 (op
, dst
, src
);
1515 LOCAL_SET (dst
, LOCAL_REF (src
));
1520 /* long-mov dst:24 _:8 src:24
1522 * Copy a value from one local slot to another.
1524 VM_DEFINE_OP (43, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1529 UNPACK_24 (op
, dst
);
1530 UNPACK_24 (ip
[1], src
);
1531 LOCAL_SET (dst
, LOCAL_REF (src
));
1536 /* box dst:12 src:12
1538 * Create a new variable holding SRC, and place it in DST.
1540 VM_DEFINE_OP (44, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1542 scm_t_uint16 dst
, src
;
1543 UNPACK_12_12 (op
, dst
, src
);
1544 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1548 /* box-ref dst:12 src:12
1550 * Unpack the variable at SRC into DST, asserting that the variable is
1553 VM_DEFINE_OP (45, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1555 scm_t_uint16 dst
, src
;
1557 UNPACK_12_12 (op
, dst
, src
);
1558 var
= LOCAL_REF (src
);
1559 VM_ASSERT (SCM_VARIABLEP (var
),
1560 vm_error_not_a_variable ("variable-ref", var
));
1561 VM_ASSERT (VARIABLE_BOUNDP (var
),
1562 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1563 LOCAL_SET (dst
, VARIABLE_REF (var
));
1567 /* box-set! dst:12 src:12
1569 * Set the contents of the variable at DST to SET.
1571 VM_DEFINE_OP (46, box_set
, "box-set!", OP1 (U8_U12_U12
))
1573 scm_t_uint16 dst
, src
;
1575 UNPACK_12_12 (op
, dst
, src
);
1576 var
= LOCAL_REF (dst
);
1577 VM_ASSERT (SCM_VARIABLEP (var
),
1578 vm_error_not_a_variable ("variable-set!", var
));
1579 VARIABLE_SET (var
, LOCAL_REF (src
));
1583 /* make-closure dst:24 offset:32 _:8 nfree:24
1585 * Make a new closure, and write it to DST. The code for the closure
1586 * will be found at OFFSET words from the current IP. OFFSET is a
1587 * signed 32-bit integer. Space for NFREE free variables will be
1590 VM_DEFINE_OP (47, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1592 scm_t_uint32 dst
, nfree
, n
;
1596 UNPACK_24 (op
, dst
);
1598 UNPACK_24 (ip
[2], nfree
);
1600 // FIXME: Assert range of nfree?
1601 closure
= scm_words (scm_tc7_program
| (nfree
<< 16), nfree
+ 2);
1602 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1603 // FIXME: Elide these initializations?
1604 for (n
= 0; n
< nfree
; n
++)
1605 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1606 LOCAL_SET (dst
, closure
);
1610 /* free-ref dst:12 src:12 _:8 idx:24
1612 * Load free variable IDX from the closure SRC into local slot DST.
1614 VM_DEFINE_OP (48, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1616 scm_t_uint16 dst
, src
;
1618 UNPACK_12_12 (op
, dst
, src
);
1619 UNPACK_24 (ip
[1], idx
);
1620 /* CHECK_FREE_VARIABLE (src); */
1621 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1625 /* free-set! dst:12 src:12 _8 idx:24
1627 * Set free variable IDX from the closure DST to SRC.
1629 VM_DEFINE_OP (49, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1631 scm_t_uint16 dst
, src
;
1633 UNPACK_12_12 (op
, dst
, src
);
1634 UNPACK_24 (ip
[1], idx
);
1635 /* CHECK_FREE_VARIABLE (src); */
1636 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1644 * Immediates and statically allocated non-immediates
1647 /* make-short-immediate dst:8 low-bits:16
1649 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1652 VM_DEFINE_OP (50, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1657 UNPACK_8_16 (op
, dst
, val
);
1658 LOCAL_SET (dst
, SCM_PACK (val
));
1662 /* make-long-immediate dst:24 low-bits:32
1664 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1667 VM_DEFINE_OP (51, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1672 UNPACK_24 (op
, dst
);
1674 LOCAL_SET (dst
, SCM_PACK (val
));
1678 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1680 * Make an immediate with HIGH-BITS and LOW-BITS.
1682 VM_DEFINE_OP (52, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1687 UNPACK_24 (op
, dst
);
1688 #if SIZEOF_SCM_T_BITS > 4
1693 ASSERT (ip
[1] == 0);
1696 LOCAL_SET (dst
, SCM_PACK (val
));
1700 /* make-non-immediate dst:24 offset:32
1702 * Load a pointer to statically allocated memory into DST. The
1703 * object's memory is will be found OFFSET 32-bit words away from the
1704 * current instruction pointer. OFFSET is a signed value. The
1705 * intention here is that the compiler would produce an object file
1706 * containing the words of a non-immediate object, and this
1707 * instruction creates a pointer to that memory, effectively
1708 * resurrecting that object.
1710 * Whether the object is mutable or immutable depends on where it was
1711 * allocated by the compiler, and loaded by the loader.
1713 VM_DEFINE_OP (53, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1718 scm_t_bits unpacked
;
1720 UNPACK_24 (op
, dst
);
1723 unpacked
= (scm_t_bits
) loc
;
1725 VM_ASSERT (!(unpacked
& 0x7), abort());
1727 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1732 /* static-ref dst:24 offset:32
1734 * Load a SCM value into DST. The SCM value will be fetched from
1735 * memory, OFFSET 32-bit words away from the current instruction
1736 * pointer. OFFSET is a signed value.
1738 * The intention is for this instruction to be used to load constants
1739 * that the compiler is unable to statically allocate, like symbols.
1740 * These values would be initialized when the object file loads.
1742 VM_DEFINE_OP (54, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
1747 scm_t_uintptr loc_bits
;
1749 UNPACK_24 (op
, dst
);
1752 loc_bits
= (scm_t_uintptr
) loc
;
1753 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1755 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1760 /* static-set! src:24 offset:32
1762 * Store a SCM value into memory, OFFSET 32-bit words away from the
1763 * current instruction pointer. OFFSET is a signed value.
1765 VM_DEFINE_OP (55, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1771 UNPACK_24 (op
, src
);
1774 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1776 *((SCM
*) loc
) = LOCAL_REF (src
);
1781 /* static-patch! _:24 dst-offset:32 src-offset:32
1783 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1784 * are signed 32-bit values, indicating a memory address as a number
1785 * of 32-bit words away from the current instruction pointer.
1787 VM_DEFINE_OP (56, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1789 scm_t_int32 dst_offset
, src_offset
;
1796 dst_loc
= (void **) (ip
+ dst_offset
);
1797 src
= ip
+ src_offset
;
1798 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1808 * Mutable top-level bindings
1811 /* There are three slightly different ways to resolve toplevel
1814 1. A toplevel reference outside of a function. These need to be
1815 looked up when the expression is evaluated -- no later, and no
1816 before. They are looked up relative to the module that is
1817 current when the expression is evaluated. For example:
1821 The "resolve" instruction resolves the variable (box), and then
1822 access is via box-ref or box-set!.
1824 2. A toplevel reference inside a function. These are looked up
1825 relative to the module that was current when the function was
1826 defined. Unlike code at the toplevel, which is usually run only
1827 once, these bindings benefit from memoized lookup, in which the
1828 variable resulting from the lookup is cached in the function.
1830 (lambda () (if (foo) a b))
1832 The toplevel-box instruction is equivalent to "resolve", but
1833 caches the resulting variable in statically allocated memory.
1835 3. A reference to an identifier with respect to a particular
1836 module. This can happen for primitive references, and
1837 references residualized by macro expansions. These can always
1838 be cached. Use module-box for these.
1841 /* current-module dst:24
1843 * Store the current module in DST.
1845 VM_DEFINE_OP (57, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1849 UNPACK_24 (op
, dst
);
1852 LOCAL_SET (dst
, scm_current_module ());
1857 /* resolve dst:24 bound?:1 _:7 sym:24
1859 * Resolve SYM in the current module, and place the resulting variable
1862 VM_DEFINE_OP (58, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1868 UNPACK_24 (op
, dst
);
1869 UNPACK_24 (ip
[1], sym
);
1872 var
= scm_lookup (LOCAL_REF (sym
));
1874 VM_ASSERT (VARIABLE_BOUNDP (var
),
1875 vm_error_unbound (fp
[0], LOCAL_REF (sym
)));
1876 LOCAL_SET (dst
, var
);
1881 /* define! sym:12 val:12
1883 * Look up a binding for SYM in the current module, creating it if
1884 * necessary. Set its value to VAL.
1886 VM_DEFINE_OP (59, define
, "define!", OP1 (U8_U12_U12
))
1888 scm_t_uint16 sym
, val
;
1889 UNPACK_12_12 (op
, sym
, val
);
1891 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1895 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1897 * Load a SCM value. The SCM value will be fetched from memory,
1898 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1899 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1902 * Then, if the loaded value is a variable, it is placed in DST, and control
1905 * Otherwise, we have to resolve the variable. In that case we load
1906 * the module from MOD-OFFSET, just as we loaded the variable.
1907 * Usually the module gets set when the closure is created. The name
1908 * is an offset to a symbol.
1910 * We use the module and the symbol to resolve the variable, placing it in
1911 * DST, and caching the resolved variable so that we will hit the cache next
1914 VM_DEFINE_OP (60, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1917 scm_t_int32 var_offset
;
1918 scm_t_uint32
* var_loc_u32
;
1922 UNPACK_24 (op
, dst
);
1924 var_loc_u32
= ip
+ var_offset
;
1925 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1926 var_loc
= (SCM
*) var_loc_u32
;
1929 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1932 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1933 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1934 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1935 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1939 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1940 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1942 mod
= *((SCM
*) mod_loc
);
1943 sym
= *((SCM
*) sym_loc
);
1945 /* If the toplevel scope was captured before modules were
1946 booted, use the root module. */
1947 if (scm_is_false (mod
))
1948 mod
= scm_the_root_module ();
1950 var
= scm_module_lookup (mod
, sym
);
1952 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1957 LOCAL_SET (dst
, var
);
1961 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1963 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1964 * instead of the module itself.
1966 VM_DEFINE_OP (61, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1969 scm_t_int32 var_offset
;
1970 scm_t_uint32
* var_loc_u32
;
1974 UNPACK_24 (op
, dst
);
1976 var_loc_u32
= ip
+ var_offset
;
1977 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1978 var_loc
= (SCM
*) var_loc_u32
;
1981 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1984 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1985 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1986 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
1987 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1991 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
1992 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1994 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
1995 sym
= *((SCM
*) sym_loc
);
1997 if (!scm_module_system_booted_p
)
1999 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
2002 scm_equal_p (modname
,
2003 scm_list_2 (SCM_BOOL_T
,
2004 scm_from_utf8_symbol ("guile"))));
2006 var
= scm_lookup (sym
);
2008 else if (scm_is_true (SCM_CAR (modname
)))
2009 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2011 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2014 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
2019 LOCAL_SET (dst
, var
);
2026 * The dynamic environment
2029 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2031 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2032 * handler at HANDLER-OFFSET words from the current IP. The handler
2033 * will expect a multiple-value return as if from a call with the
2034 * procedure at PROC-SLOT.
2036 VM_DEFINE_OP (62, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2038 scm_t_uint32 tag
, proc_slot
;
2040 scm_t_uint8 escape_only_p
;
2041 scm_t_dynstack_prompt_flags flags
;
2043 UNPACK_24 (op
, tag
);
2044 escape_only_p
= ip
[1] & 0x1;
2045 UNPACK_24 (ip
[1], proc_slot
);
2047 offset
>>= 8; /* Sign extension */
2049 /* Push the prompt onto the dynamic stack. */
2050 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2051 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2053 fp
- vp
->stack_base
,
2054 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2060 /* wind winder:12 unwinder:12
2062 * Push wind and unwind procedures onto the dynamic stack. Note that
2063 * neither are actually called; the compiler should emit calls to wind
2064 * and unwind for the normal dynamic-wind control flow. Also note that
2065 * the compiler should have inserted checks that they wind and unwind
2066 * procs are thunks, if it could not prove that to be the case.
2068 VM_DEFINE_OP (63, wind
, "wind", OP1 (U8_U12_U12
))
2070 scm_t_uint16 winder
, unwinder
;
2071 UNPACK_12_12 (op
, winder
, unwinder
);
2072 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2073 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2079 * A normal exit from the dynamic extent of an expression. Pop the top
2080 * entry off of the dynamic stack.
2082 VM_DEFINE_OP (64, unwind
, "unwind", OP1 (U8_X24
))
2084 scm_dynstack_pop (¤t_thread
->dynstack
);
2088 /* push-fluid fluid:12 value:12
2090 * Dynamically bind N fluids to values. The fluids are expected to be
2091 * allocated in a continguous range on the stack, starting from
2092 * FLUID-BASE. The values do not have this restriction.
2094 VM_DEFINE_OP (65, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2096 scm_t_uint32 fluid
, value
;
2098 UNPACK_12_12 (op
, fluid
, value
);
2100 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2101 LOCAL_REF (fluid
), LOCAL_REF (value
),
2102 current_thread
->dynamic_state
);
2108 * Leave the dynamic extent of a with-fluids expression, restoring the
2109 * fluids to their previous values.
2111 VM_DEFINE_OP (66, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2113 /* This function must not allocate. */
2114 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2115 current_thread
->dynamic_state
);
2119 /* fluid-ref dst:12 src:12
2121 * Reference the fluid in SRC, and place the value in DST.
2123 VM_DEFINE_OP (67, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2125 scm_t_uint16 dst
, src
;
2129 UNPACK_12_12 (op
, dst
, src
);
2130 fluid
= LOCAL_REF (src
);
2131 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2132 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2133 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2135 /* Punt dynstate expansion and error handling to the C proc. */
2137 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2141 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2142 if (scm_is_eq (val
, SCM_UNDEFINED
))
2143 val
= SCM_I_FLUID_DEFAULT (fluid
);
2144 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2145 vm_error_unbound_fluid (program
, fluid
));
2146 LOCAL_SET (dst
, val
);
2152 /* fluid-set fluid:12 val:12
2154 * Set the value of the fluid in DST to the value in SRC.
2156 VM_DEFINE_OP (68, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2162 UNPACK_12_12 (op
, a
, b
);
2163 fluid
= LOCAL_REF (a
);
2164 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2165 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2166 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2168 /* Punt dynstate expansion and error handling to the C proc. */
2170 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2173 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2182 * Strings, symbols, and keywords
2185 /* string-length dst:12 src:12
2187 * Store the length of the string in SRC in DST.
2189 VM_DEFINE_OP (69, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2192 if (SCM_LIKELY (scm_is_string (str
)))
2193 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2197 RETURN (scm_string_length (str
));
2201 /* string-ref dst:8 src:8 idx:8
2203 * Fetch the character at position IDX in the string in SRC, and store
2206 VM_DEFINE_OP (70, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2208 scm_t_signed_bits i
= 0;
2210 if (SCM_LIKELY (scm_is_string (str
)
2211 && SCM_I_INUMP (idx
)
2212 && ((i
= SCM_I_INUM (idx
)) >= 0)
2213 && i
< scm_i_string_length (str
)))
2214 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2218 RETURN (scm_string_ref (str
, idx
));
2222 /* No string-set! instruction, as there is no good fast path there. */
2224 /* string-to-number dst:12 src:12
2226 * Parse a string in SRC to a number, and store in DST.
2228 VM_DEFINE_OP (71, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2230 scm_t_uint16 dst
, src
;
2232 UNPACK_12_12 (op
, dst
, src
);
2235 scm_string_to_number (LOCAL_REF (src
),
2236 SCM_UNDEFINED
/* radix = 10 */));
2240 /* string-to-symbol dst:12 src:12
2242 * Parse a string in SRC to a symbol, and store in DST.
2244 VM_DEFINE_OP (72, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2246 scm_t_uint16 dst
, src
;
2248 UNPACK_12_12 (op
, dst
, src
);
2250 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2254 /* symbol->keyword dst:12 src:12
2256 * Make a keyword from the symbol in SRC, and store it in DST.
2258 VM_DEFINE_OP (73, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2260 scm_t_uint16 dst
, src
;
2261 UNPACK_12_12 (op
, dst
, src
);
2263 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2273 /* cons dst:8 car:8 cdr:8
2275 * Cons CAR and CDR, and store the result in DST.
2277 VM_DEFINE_OP (74, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2280 RETURN (scm_cons (x
, y
));
2283 /* car dst:12 src:12
2285 * Place the car of SRC in DST.
2287 VM_DEFINE_OP (75, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2290 VM_VALIDATE_PAIR (x
, "car");
2291 RETURN (SCM_CAR (x
));
2294 /* cdr dst:12 src:12
2296 * Place the cdr of SRC in DST.
2298 VM_DEFINE_OP (76, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2301 VM_VALIDATE_PAIR (x
, "cdr");
2302 RETURN (SCM_CDR (x
));
2305 /* set-car! pair:12 car:12
2307 * Set the car of DST to SRC.
2309 VM_DEFINE_OP (77, set_car
, "set-car!", OP1 (U8_U12_U12
))
2313 UNPACK_12_12 (op
, a
, b
);
2316 VM_VALIDATE_PAIR (x
, "set-car!");
2321 /* set-cdr! pair:12 cdr:12
2323 * Set the cdr of DST to SRC.
2325 VM_DEFINE_OP (78, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2329 UNPACK_12_12 (op
, a
, b
);
2332 VM_VALIDATE_PAIR (x
, "set-car!");
2341 * Numeric operations
2344 /* add dst:8 a:8 b:8
2346 * Add A to B, and place the result in DST.
2348 VM_DEFINE_OP (79, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2350 BINARY_INTEGER_OP (+, scm_sum
);
2353 /* add1 dst:12 src:12
2355 * Add 1 to the value in SRC, and place the result in DST.
2357 VM_DEFINE_OP (80, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2361 /* Check for overflow. We must avoid overflow in the signed
2362 addition below, even if X is not an inum. */
2363 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2367 /* Add 1 to the integer without untagging. */
2368 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2370 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2375 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2378 /* sub dst:8 a:8 b:8
2380 * Subtract B from A, and place the result in DST.
2382 VM_DEFINE_OP (81, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2384 BINARY_INTEGER_OP (-, scm_difference
);
2387 /* sub1 dst:12 src:12
2389 * Subtract 1 from SRC, and place the result in DST.
2391 VM_DEFINE_OP (82, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2395 /* Check for overflow. We must avoid overflow in the signed
2396 subtraction below, even if X is not an inum. */
2397 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2401 /* Substract 1 from the integer without untagging. */
2402 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2404 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2409 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2412 /* mul dst:8 a:8 b:8
2414 * Multiply A and B, and place the result in DST.
2416 VM_DEFINE_OP (83, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2420 RETURN (scm_product (x
, y
));
2423 /* div dst:8 a:8 b:8
2425 * Divide A by B, and place the result in DST.
2427 VM_DEFINE_OP (84, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2431 RETURN (scm_divide (x
, y
));
2434 /* quo dst:8 a:8 b:8
2436 * Divide A by B, and place the quotient in DST.
2438 VM_DEFINE_OP (85, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2442 RETURN (scm_quotient (x
, y
));
2445 /* rem dst:8 a:8 b:8
2447 * Divide A by B, and place the remainder in DST.
2449 VM_DEFINE_OP (86, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2453 RETURN (scm_remainder (x
, y
));
2456 /* mod dst:8 a:8 b:8
2458 * Place the modulo of A by B in DST.
2460 VM_DEFINE_OP (87, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2464 RETURN (scm_modulo (x
, y
));
2467 /* ash dst:8 a:8 b:8
2469 * Shift A arithmetically by B bits, and place the result in DST.
2471 VM_DEFINE_OP (88, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2474 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2476 if (SCM_I_INUM (y
) < 0)
2477 /* Right shift, will be a fixnum. */
2478 RETURN (SCM_I_MAKINUM
2479 (SCM_SRS (SCM_I_INUM (x
),
2480 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2481 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2483 /* Left shift. See comments in scm_ash. */
2485 scm_t_signed_bits nn
, bits_to_shift
;
2487 nn
= SCM_I_INUM (x
);
2488 bits_to_shift
= SCM_I_INUM (y
);
2490 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2492 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2494 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2500 RETURN (scm_ash (x
, y
));
2503 /* logand dst:8 a:8 b:8
2505 * Place the bitwise AND of A and B into DST.
2507 VM_DEFINE_OP (89, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2510 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2511 /* Compute bitwise AND without untagging */
2512 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2514 RETURN (scm_logand (x
, y
));
2517 /* logior dst:8 a:8 b:8
2519 * Place the bitwise inclusive OR of A with B in DST.
2521 VM_DEFINE_OP (90, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2524 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2525 /* Compute bitwise OR without untagging */
2526 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2528 RETURN (scm_logior (x
, y
));
2531 /* logxor dst:8 a:8 b:8
2533 * Place the bitwise exclusive OR of A with B in DST.
2535 VM_DEFINE_OP (91, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2538 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2539 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2541 RETURN (scm_logxor (x
, y
));
2544 /* make-vector/immediate dst:8 length:8 init:8
2546 * Make a short vector of known size and write it to DST. The vector
2547 * will have space for LENGTH slots, an immediate value. They will be
2548 * filled with the value in slot INIT.
2550 VM_DEFINE_OP (92, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2552 scm_t_uint8 dst
, init
;
2553 scm_t_int32 length
, n
;
2556 UNPACK_8_8_8 (op
, dst
, length
, init
);
2558 val
= LOCAL_REF (init
);
2559 vector
= scm_words (scm_tc7_vector
| (length
<< 8), length
+ 1);
2560 for (n
= 0; n
< length
; n
++)
2561 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2562 LOCAL_SET (dst
, vector
);
2566 /* vector-length dst:12 src:12
2568 * Store the length of the vector in SRC in DST.
2570 VM_DEFINE_OP (93, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2573 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2574 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2578 RETURN (scm_vector_length (vect
));
2582 /* vector-ref dst:8 src:8 idx:8
2584 * Fetch the item at position IDX in the vector in SRC, and store it
2587 VM_DEFINE_OP (94, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2589 scm_t_signed_bits i
= 0;
2591 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2592 && SCM_I_INUMP (idx
)
2593 && ((i
= SCM_I_INUM (idx
)) >= 0)
2594 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2595 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2599 RETURN (scm_vector_ref (vect
, idx
));
2603 /* vector-ref/immediate dst:8 src:8 idx:8
2605 * Fill DST with the item IDX elements into the vector at SRC. Useful
2606 * for building data types using vectors.
2608 VM_DEFINE_OP (95, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2610 scm_t_uint8 dst
, src
, idx
;
2613 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2614 v
= LOCAL_REF (src
);
2615 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2616 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2617 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2619 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2623 /* vector-set! dst:8 idx:8 src:8
2625 * Store SRC into the vector DST at index IDX.
2627 VM_DEFINE_OP (96, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2629 scm_t_uint8 dst
, idx_var
, src
;
2631 scm_t_signed_bits i
= 0;
2633 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2634 vect
= LOCAL_REF (dst
);
2635 idx
= LOCAL_REF (idx_var
);
2636 val
= LOCAL_REF (src
);
2638 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2639 && SCM_I_INUMP (idx
)
2640 && ((i
= SCM_I_INUM (idx
)) >= 0)
2641 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2642 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2646 scm_vector_set_x (vect
, idx
, val
);
2651 /* vector-set!/immediate dst:8 idx:8 src:8
2653 * Store SRC into the vector DST at index IDX. Here IDX is an
2656 VM_DEFINE_OP (97, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2658 scm_t_uint8 dst
, idx
, src
;
2661 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2662 vect
= LOCAL_REF (dst
);
2663 val
= LOCAL_REF (src
);
2665 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2666 && idx
< SCM_I_VECTOR_LENGTH (vect
)))
2667 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2671 scm_vector_set_x (vect
, scm_from_uint8 (idx
), val
);
2683 /* struct-vtable dst:12 src:12
2685 * Store the vtable of SRC into DST.
2687 VM_DEFINE_OP (98, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2690 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2691 RETURN (SCM_STRUCT_VTABLE (obj
));
2694 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2696 * Allocate a new struct with VTABLE, and place it in DST. The struct
2697 * will be constructed with space for NFIELDS fields, which should
2698 * correspond to the field count of the VTABLE.
2700 VM_DEFINE_OP (99, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2702 scm_t_uint8 dst
, vtable
, nfields
;
2705 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2708 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2709 LOCAL_SET (dst
, ret
);
2714 /* struct-ref/immediate dst:8 src:8 idx:8
2716 * Fetch the item at slot IDX in the struct in SRC, and store it
2717 * in DST. IDX is an immediate unsigned 8-bit value.
2719 VM_DEFINE_OP (100, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2721 scm_t_uint8 dst
, src
, idx
;
2724 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2726 obj
= LOCAL_REF (src
);
2728 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2729 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2730 SCM_VTABLE_FLAG_SIMPLE
)
2731 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2732 scm_vtable_index_size
)))
2733 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2736 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2739 /* struct-set!/immediate dst:8 idx:8 src:8
2741 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2742 * unsigned 8-bit value.
2744 VM_DEFINE_OP (101, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2746 scm_t_uint8 dst
, idx
, src
;
2749 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2751 obj
= LOCAL_REF (dst
);
2752 val
= LOCAL_REF (src
);
2754 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2755 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2756 SCM_VTABLE_FLAG_SIMPLE
)
2757 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2758 SCM_VTABLE_FLAG_SIMPLE_RW
)
2759 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2760 scm_vtable_index_size
)))
2762 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2767 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2771 /* class-of dst:12 type:12
2773 * Store the vtable of SRC into DST.
2775 VM_DEFINE_OP (102, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2778 if (SCM_INSTANCEP (obj
))
2779 RETURN (SCM_CLASS_OF (obj
));
2781 RETURN (scm_class_of (obj
));
2784 /* slot-ref dst:8 src:8 idx:8
2786 * Fetch the item at slot IDX in the struct in SRC, and store it in
2787 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
2788 * index into the stack.
2790 VM_DEFINE_OP (103, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2792 scm_t_uint8 dst
, src
, idx
;
2793 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2795 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
2799 /* slot-set! dst:8 idx:8 src:8
2801 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
2802 * IDX is an 8-bit immediate value, not an index into the stack.
2804 VM_DEFINE_OP (104, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
2806 scm_t_uint8 dst
, idx
, src
;
2807 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2808 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
2816 * Arrays, packed uniform arrays, and bytevectors.
2819 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2821 * Load the contiguous typed array located at OFFSET 32-bit words away
2822 * from the instruction pointer, and store into DST. LEN is a byte
2823 * length. OFFSET is signed.
2825 VM_DEFINE_OP (105, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2827 scm_t_uint8 dst
, type
, shape
;
2831 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2835 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2841 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
2843 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2845 VM_DEFINE_OP (106, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
2847 scm_t_uint16 dst
, type
, fill
, bounds
;
2848 UNPACK_12_12 (op
, dst
, type
);
2849 UNPACK_12_12 (ip
[1], fill
, bounds
);
2851 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2852 LOCAL_REF (bounds
)));
2856 /* bv-u8-ref dst:8 src:8 idx:8
2857 * bv-s8-ref dst:8 src:8 idx:8
2858 * bv-u16-ref dst:8 src:8 idx:8
2859 * bv-s16-ref dst:8 src:8 idx:8
2860 * bv-u32-ref dst:8 src:8 idx:8
2861 * bv-s32-ref dst:8 src:8 idx:8
2862 * bv-u64-ref dst:8 src:8 idx:8
2863 * bv-s64-ref dst:8 src:8 idx:8
2864 * bv-f32-ref dst:8 src:8 idx:8
2865 * bv-f64-ref dst:8 src:8 idx:8
2867 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2868 * it in DST. All accesses use native endianness.
2870 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2872 scm_t_signed_bits i; \
2873 const scm_t_ ## type *int_ptr; \
2876 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2877 i = SCM_I_INUM (idx); \
2878 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2880 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2882 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2883 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2884 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2888 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2892 #define BV_INT_REF(stem, type, size) \
2894 scm_t_signed_bits i; \
2895 const scm_t_ ## type *int_ptr; \
2898 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2899 i = SCM_I_INUM (idx); \
2900 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2902 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2904 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2905 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2907 scm_t_ ## type x = *int_ptr; \
2908 if (SCM_FIXABLE (x)) \
2909 RETURN (SCM_I_MAKINUM (x)); \
2913 RETURN (scm_from_ ## type (x)); \
2919 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2923 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2925 scm_t_signed_bits i; \
2926 const type *float_ptr; \
2929 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2930 i = SCM_I_INUM (idx); \
2931 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2934 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2936 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2937 && (ALIGNED_P (float_ptr, type)))) \
2938 RETURN (scm_from_double (*float_ptr)); \
2940 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2943 VM_DEFINE_OP (107, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2944 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2946 VM_DEFINE_OP (108, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2947 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2949 VM_DEFINE_OP (109, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2950 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2952 VM_DEFINE_OP (110, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2953 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2955 VM_DEFINE_OP (111, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2956 #if SIZEOF_VOID_P > 4
2957 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2959 BV_INT_REF (u32
, uint32
, 4);
2962 VM_DEFINE_OP (112, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2963 #if SIZEOF_VOID_P > 4
2964 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2966 BV_INT_REF (s32
, int32
, 4);
2969 VM_DEFINE_OP (113, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2970 BV_INT_REF (u64
, uint64
, 8);
2972 VM_DEFINE_OP (114, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2973 BV_INT_REF (s64
, int64
, 8);
2975 VM_DEFINE_OP (115, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2976 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2978 VM_DEFINE_OP (116, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2979 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2981 /* bv-u8-set! dst:8 idx:8 src:8
2982 * bv-s8-set! dst:8 idx:8 src:8
2983 * bv-u16-set! dst:8 idx:8 src:8
2984 * bv-s16-set! dst:8 idx:8 src:8
2985 * bv-u32-set! dst:8 idx:8 src:8
2986 * bv-s32-set! dst:8 idx:8 src:8
2987 * bv-u64-set! dst:8 idx:8 src:8
2988 * bv-s64-set! dst:8 idx:8 src:8
2989 * bv-f32-set! dst:8 idx:8 src:8
2990 * bv-f64-set! dst:8 idx:8 src:8
2992 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2993 * values are written using native endianness.
2995 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2997 scm_t_uint8 dst, idx, src; \
2998 scm_t_signed_bits i, j = 0; \
2999 SCM bv, scm_idx, val; \
3000 scm_t_ ## type *int_ptr; \
3002 UNPACK_8_8_8 (op, dst, idx, src); \
3003 bv = LOCAL_REF (dst); \
3004 scm_idx = LOCAL_REF (idx); \
3005 val = LOCAL_REF (src); \
3006 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3007 i = SCM_I_INUM (scm_idx); \
3008 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3010 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3012 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3013 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3014 && (SCM_I_INUMP (val)) \
3015 && ((j = SCM_I_INUM (val)) >= min) \
3017 *int_ptr = (scm_t_ ## type) j; \
3021 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3026 #define BV_INT_SET(stem, type, size) \
3028 scm_t_uint8 dst, idx, src; \
3029 scm_t_signed_bits i; \
3030 SCM bv, scm_idx, val; \
3031 scm_t_ ## type *int_ptr; \
3033 UNPACK_8_8_8 (op, dst, idx, src); \
3034 bv = LOCAL_REF (dst); \
3035 scm_idx = LOCAL_REF (idx); \
3036 val = LOCAL_REF (src); \
3037 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3038 i = SCM_I_INUM (scm_idx); \
3039 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3041 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3043 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3044 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3045 *int_ptr = scm_to_ ## type (val); \
3049 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3054 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3056 scm_t_uint8 dst, idx, src; \
3057 scm_t_signed_bits i; \
3058 SCM bv, scm_idx, val; \
3061 UNPACK_8_8_8 (op, dst, idx, src); \
3062 bv = LOCAL_REF (dst); \
3063 scm_idx = LOCAL_REF (idx); \
3064 val = LOCAL_REF (src); \
3065 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3066 i = SCM_I_INUM (scm_idx); \
3067 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3069 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3071 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3072 && (ALIGNED_P (float_ptr, type)))) \
3073 *float_ptr = scm_to_double (val); \
3077 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3082 VM_DEFINE_OP (117, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3083 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3085 VM_DEFINE_OP (118, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3086 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3088 VM_DEFINE_OP (119, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3089 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3091 VM_DEFINE_OP (120, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3092 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3094 VM_DEFINE_OP (121, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3095 #if SIZEOF_VOID_P > 4
3096 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3098 BV_INT_SET (u32
, uint32
, 4);
3101 VM_DEFINE_OP (122, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3102 #if SIZEOF_VOID_P > 4
3103 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3105 BV_INT_SET (s32
, int32
, 4);
3108 VM_DEFINE_OP (123, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3109 BV_INT_SET (u64
, uint64
, 8);
3111 VM_DEFINE_OP (124, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3112 BV_INT_SET (s64
, int64
, 8);
3114 VM_DEFINE_OP (125, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3115 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3117 VM_DEFINE_OP (126, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3118 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3120 END_DISPATCH_SWITCH
;
3122 vm_error_bad_instruction
:
3123 vm_error_bad_instruction (op
);
3125 abort (); /* never reached */
3129 #undef ABORT_CONTINUATION_HOOK
3134 #undef BEGIN_DISPATCH_SWITCH
3135 #undef BINARY_INTEGER_OP
3136 #undef BR_ARITHMETIC
3140 #undef BV_FIXABLE_INT_REF
3141 #undef BV_FIXABLE_INT_SET
3146 #undef CACHE_REGISTER
3147 #undef CHECK_OVERFLOW
3148 #undef END_DISPATCH_SWITCH
3149 #undef FREE_VARIABLE_REF
3158 #undef POP_CONTINUATION_HOOK
3159 #undef PUSH_CONTINUATION_HOOK
3160 #undef RESTORE_CONTINUATION_HOOK
3162 #undef RETURN_ONE_VALUE
3163 #undef RETURN_VALUE_LIST
3168 #undef SYNC_BEFORE_GC
3170 #undef SYNC_REGISTER
3176 #undef VARIABLE_BOUNDP
3179 #undef VM_CHECK_FREE_VARIABLE
3180 #undef VM_CHECK_OBJECT
3181 #undef VM_CHECK_UNDERFLOW
3183 #undef VM_INSTRUCTION_TO_LABEL
3185 #undef VM_VALIDATE_BYTEVECTOR
3186 #undef VM_VALIDATE_PAIR
3187 #undef VM_VALIDATE_STRUCT
3190 (defun renumber-ops ()
3191 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3194 (let ((counter -1)) (goto-char (point-min))
3195 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3197 (number-to-string (setq counter (1+ counter)))