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_IP ())
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
162 #define SYNC_IP() vp->ip = (ip)
165 /* After advancing vp->sp, but before writing any stack slots, check
166 that it is actually in bounds. If it is not in bounds, currently we
167 signal an error. In the future we may expand the stack instead,
168 possibly by moving it elsewhere, therefore no pointer into the stack
169 besides FP is valid across a CHECK_OVERFLOW call. Be careful! */
170 #define CHECK_OVERFLOW() \
172 if (SCM_UNLIKELY (vp->sp >= vp->stack_limit)) \
175 vm_expand_stack (vp); \
180 /* Reserve stack space for a frame. Will check that there is sufficient
181 stack space for N locals, including the procedure. Invoke after
182 preparing the new frame and setting the fp and ip. */
183 #define ALLOC_FRAME(n) \
185 vp->sp = LOCAL_ADDRESS (n - 1); \
189 /* Reset the current frame to hold N locals. Used when we know that no
190 stack expansion is needed. */
191 #define RESET_FRAME(n) \
193 vp->sp = LOCAL_ADDRESS (n - 1); \
196 /* Compute the number of locals in the frame. At a call, this is equal
197 to the number of actual arguments when a function is first called,
198 plus one for the function. */
199 #define FRAME_LOCALS_COUNT_FROM(slot) \
200 (vp->sp + 1 - LOCAL_ADDRESS (slot))
201 #define FRAME_LOCALS_COUNT() \
202 FRAME_LOCALS_COUNT_FROM (0)
204 /* Restore registers after returning from a frame. */
205 #define RESTORE_FRAME() \
210 #define CACHE_REGISTER() \
216 #ifdef HAVE_LABELS_AS_VALUES
217 # define BEGIN_DISPATCH_SWITCH /* */
218 # define END_DISPATCH_SWITCH /* */
225 goto *jump_table[op & 0xff]; \
228 # define VM_DEFINE_OP(opcode, tag, name, meta) \
231 # define BEGIN_DISPATCH_SWITCH \
237 # define END_DISPATCH_SWITCH \
246 # define VM_DEFINE_OP(opcode, tag, name, meta) \
251 #define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
252 #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
253 #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
255 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
256 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
257 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
259 #define RETURN_ONE_VALUE(ret) \
263 VM_HANDLE_INTERRUPTS; \
264 ip = SCM_FRAME_RETURN_ADDRESS (fp); \
265 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
267 old_fp[-1] = SCM_BOOL_F; \
268 old_fp[-2] = SCM_BOOL_F; \
270 SCM_FRAME_LOCAL (old_fp, 1) = val; \
271 vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
272 POP_CONTINUATION_HOOK (old_fp); \
276 /* While we could generate the list-unrolling code here, it's fine for
277 now to just tail-call (apply values vals). */
278 #define RETURN_VALUE_LIST(vals_) \
281 VM_HANDLE_INTERRUPTS; \
282 fp[0] = vm_builtin_apply; \
283 fp[1] = vm_builtin_values; \
286 ip = (scm_t_uint32 *) vm_builtin_apply_code; \
287 goto op_tail_apply; \
290 #define BR_NARGS(rel) \
291 scm_t_uint32 expected; \
292 UNPACK_24 (op, expected); \
293 if (FRAME_LOCALS_COUNT() rel expected) \
295 scm_t_int32 offset = ip[1]; \
296 offset >>= 8; /* Sign-extending shift. */ \
301 #define BR_UNARY(x, exp) \
304 UNPACK_24 (op, test); \
305 x = LOCAL_REF (test); \
306 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
308 scm_t_int32 offset = ip[1]; \
309 offset >>= 8; /* Sign-extending shift. */ \
311 VM_HANDLE_INTERRUPTS; \
316 #define BR_BINARY(x, y, exp) \
319 UNPACK_12_12 (op, a, b); \
322 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
324 scm_t_int32 offset = ip[1]; \
325 offset >>= 8; /* Sign-extending shift. */ \
327 VM_HANDLE_INTERRUPTS; \
332 #define BR_ARITHMETIC(crel,srel) \
336 UNPACK_12_12 (op, a, b); \
339 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
341 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
342 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
343 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
345 scm_t_int32 offset = ip[1]; \
346 offset >>= 8; /* Sign-extending shift. */ \
348 VM_HANDLE_INTERRUPTS; \
358 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
360 scm_t_int32 offset = ip[1]; \
361 offset >>= 8; /* Sign-extending shift. */ \
363 VM_HANDLE_INTERRUPTS; \
371 scm_t_uint16 dst, src; \
373 UNPACK_12_12 (op, dst, src); \
375 #define ARGS2(a1, a2) \
376 scm_t_uint8 dst, src1, src2; \
378 UNPACK_8_8_8 (op, dst, src1, src2); \
379 a1 = LOCAL_REF (src1); \
380 a2 = LOCAL_REF (src2)
382 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
384 /* The maximum/minimum tagged integers. */
386 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
388 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
390 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
391 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
393 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
396 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
398 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
399 if (SCM_FIXABLE (n)) \
400 RETURN (SCM_I_MAKINUM (n)); \
403 RETURN (SFUNC (x, y)); \
406 #define VM_VALIDATE_PAIR(x, proc) \
407 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
409 #define VM_VALIDATE_STRUCT(obj, proc) \
410 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
412 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
413 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
415 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
416 #define ALIGNED_P(ptr, type) \
417 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
420 VM_NAME (scm_i_thread
*current_thread
, struct scm_vm
*vp
,
421 scm_i_jmp_buf
*registers
, int resume
)
423 /* Instruction pointer: A pointer to the opcode that is currently
425 register scm_t_uint32
*ip IP_REG
;
427 /* Frame pointer: A pointer into the stack, off of which we index
428 arguments and local variables. Pushed at function calls, popped on
430 register SCM
*fp FP_REG
;
432 /* Current opcode: A cache of *ip. */
433 register scm_t_uint32 op
;
435 #ifdef HAVE_LABELS_AS_VALUES
436 static const void *jump_table_
[256] = {
437 #define LABEL_ADDR(opcode, tag, name, meta) &&op_##tag,
438 FOR_EACH_VM_OPERATION(LABEL_ADDR
)
441 register const void **jump_table JT_REG
;
442 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
443 load instruction at each instruction dispatch. */
444 jump_table
= jump_table_
;
447 /* Load VM registers. */
450 VM_HANDLE_INTERRUPTS
;
452 /* Usually a call to the VM happens on application, with the boot
453 continuation on the next frame. Sometimes it happens after a
454 non-local exit however; in that case the VM state is all set up,
455 and we have but to jump to the next opcode. */
456 if (SCM_UNLIKELY (resume
))
460 while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
462 SCM proc
= SCM_FRAME_PROGRAM (fp
);
464 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
466 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
469 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
471 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
473 /* Shuffle args up. */
476 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
478 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
483 vm_error_wrong_type_apply (proc
);
487 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
490 BEGIN_DISPATCH_SWITCH
;
501 * Bring the VM to a halt, returning all the values from the stack.
503 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
505 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
507 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
516 for (n
= nvals
; n
> 0; n
--)
517 ret
= scm_cons (LOCAL_REF (4 + n
- 1), ret
);
518 ret
= scm_values (ret
);
521 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
522 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
523 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
528 /* call proc:24 _:8 nlocals:24
530 * Call a procedure. PROC is the local corresponding to a procedure.
531 * The three values below PROC will be overwritten by the saved call
532 * frame data. The new frame will have space for NLOCALS locals: one
533 * for the procedure, and the rest for the arguments which should
534 * already have been pushed on.
536 * When the call returns, execution proceeds with the next
537 * instruction. There may be any number of values on the return
538 * stack; the precise number can be had by subtracting the address of
539 * PROC from the post-call SP.
541 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
543 scm_t_uint32 proc
, nlocals
;
546 UNPACK_24 (op
, proc
);
547 UNPACK_24 (ip
[1], nlocals
);
549 VM_HANDLE_INTERRUPTS
;
551 fp
= vp
->fp
= old_fp
+ proc
;
552 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
553 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
555 RESET_FRAME (nlocals
);
557 PUSH_CONTINUATION_HOOK ();
560 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
563 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
567 /* tail-call nlocals:24
569 * Tail-call a procedure. Requires that the procedure and all of the
570 * arguments have already been shuffled into position. Will reset the
573 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
575 scm_t_uint32 nlocals
;
577 UNPACK_24 (op
, nlocals
);
579 VM_HANDLE_INTERRUPTS
;
581 RESET_FRAME (nlocals
);
585 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
588 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
592 /* tail-call/shuffle from:24
594 * Tail-call a procedure. The procedure should already be set to slot
595 * 0. The rest of the args are taken from the frame, starting at
596 * FROM, shuffled down to start at slot 0. This is part of the
597 * implementation of the call-with-values builtin.
599 VM_DEFINE_OP (3, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
601 scm_t_uint32 n
, from
, nlocals
;
603 UNPACK_24 (op
, from
);
605 VM_HANDLE_INTERRUPTS
;
607 VM_ASSERT (from
> 0, abort ());
608 nlocals
= FRAME_LOCALS_COUNT ();
610 for (n
= 0; from
+ n
< nlocals
; n
++)
611 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
617 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
620 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
624 /* receive dst:12 proc:12 _:8 nlocals:24
626 * Receive a single return value from a call whose procedure was in
627 * PROC, asserting that the call actually returned at least one
628 * value. Afterwards, resets the frame to NLOCALS locals.
630 VM_DEFINE_OP (4, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
632 scm_t_uint16 dst
, proc
;
633 scm_t_uint32 nlocals
;
634 UNPACK_12_12 (op
, dst
, proc
);
635 UNPACK_24 (ip
[1], nlocals
);
636 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
637 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
638 RESET_FRAME (nlocals
);
642 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
644 * Receive a return of multiple values from a call whose procedure was
645 * in PROC. If fewer than NVALUES values were returned, signal an
646 * error. Unless ALLOW-EXTRA? is true, require that the number of
647 * return values equals NVALUES exactly. After receive-values has
648 * run, the values can be copied down via `mov'.
650 VM_DEFINE_OP (5, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
652 scm_t_uint32 proc
, nvalues
;
653 UNPACK_24 (op
, proc
);
654 UNPACK_24 (ip
[1], nvalues
);
656 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
657 vm_error_not_enough_values ());
659 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
660 vm_error_wrong_number_of_values (nvalues
));
668 VM_DEFINE_OP (6, return, "return", OP1 (U8_U24
))
672 RETURN_ONE_VALUE (LOCAL_REF (src
));
675 /* return-values _:24
677 * Return a number of values from a call frame. This opcode
678 * corresponds to an application of `values' in tail position. As
679 * with tail calls, we expect that the values have already been
680 * shuffled down to a contiguous array starting at slot 1.
681 * We also expect the frame has already been reset.
683 VM_DEFINE_OP (7, return_values
, "return-values", OP1 (U8_X24
))
687 VM_HANDLE_INTERRUPTS
;
688 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
689 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
691 /* Clear stack frame. */
692 old_fp
[-1] = SCM_BOOL_F
;
693 old_fp
[-2] = SCM_BOOL_F
;
695 POP_CONTINUATION_HOOK (old_fp
);
704 * Specialized call stubs
707 /* subr-call ptr-idx:24
709 * Call a subr, passing all locals in this frame as arguments. Fetch
710 * the foreign pointer from PTR-IDX, a free variable. Return from the
711 * calling frame. This instruction is part of the trampolines
712 * created in gsubr.c, and is not generated by the compiler.
714 VM_DEFINE_OP (8, subr_call
, "subr-call", OP1 (U8_U24
))
716 scm_t_uint32 ptr_idx
;
720 UNPACK_24 (op
, ptr_idx
);
722 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
723 subr
= SCM_POINTER_VALUE (pointer
);
725 VM_HANDLE_INTERRUPTS
;
728 switch (FRAME_LOCALS_COUNT_FROM (1))
737 ret
= subr (fp
[1], fp
[2]);
740 ret
= subr (fp
[1], fp
[2], fp
[3]);
743 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
746 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
749 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
752 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
755 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
758 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
761 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
767 // NULLSTACK_FOR_NONLOCAL_EXIT ();
769 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
770 /* multiple values returned to continuation */
771 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
773 RETURN_ONE_VALUE (ret
);
776 /* foreign-call cif-idx:12 ptr-idx:12
778 * Call a foreign function. Fetch the CIF and foreign pointer from
779 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
780 * frame. Arguments are taken from the stack. This instruction is
781 * part of the trampolines created by the FFI, and is not generated by
784 VM_DEFINE_OP (9, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
786 scm_t_uint16 cif_idx
, ptr_idx
;
787 SCM closure
, cif
, pointer
, ret
;
789 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
791 closure
= LOCAL_REF (0);
792 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
793 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
796 VM_HANDLE_INTERRUPTS
;
798 // FIXME: separate args
799 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), LOCAL_ADDRESS (1));
801 // NULLSTACK_FOR_NONLOCAL_EXIT ();
803 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
804 /* multiple values returned to continuation */
805 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
807 RETURN_ONE_VALUE (ret
);
810 /* continuation-call contregs:24
812 * Return to a continuation, nonlocally. The arguments to the
813 * continuation are taken from the stack. CONTREGS is a free variable
814 * containing the reified continuation. This instruction is part of
815 * the implementation of undelimited continuations, and is not
816 * generated by the compiler.
818 VM_DEFINE_OP (10, continuation_call
, "continuation-call", OP1 (U8_U24
))
821 scm_t_uint32 contregs_idx
;
823 UNPACK_24 (op
, contregs_idx
);
826 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
829 scm_i_check_continuation (contregs
);
830 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
831 scm_i_contregs_vm_cont (contregs
),
832 FRAME_LOCALS_COUNT_FROM (1),
834 scm_i_reinstate_continuation (contregs
);
840 /* compose-continuation cont:24
842 * Compose a partial continution with the current continuation. The
843 * arguments to the continuation are taken from the stack. CONT is a
844 * free variable containing the reified continuation. This
845 * instruction is part of the implementation of partial continuations,
846 * and is not generated by the compiler.
848 VM_DEFINE_OP (11, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
851 scm_t_uint32 cont_idx
;
853 UNPACK_24 (op
, cont_idx
);
854 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
857 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
858 vm_error_continuation_not_rewindable (vmcont
));
859 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
861 ¤t_thread
->dynstack
,
869 * Tail-apply the procedure in local slot 0 to the rest of the
870 * arguments. This instruction is part of the implementation of
871 * `apply', and is not generated by the compiler.
873 VM_DEFINE_OP (12, tail_apply
, "tail-apply", OP1 (U8_X24
))
875 int i
, list_idx
, list_len
, nlocals
;
878 VM_HANDLE_INTERRUPTS
;
880 nlocals
= FRAME_LOCALS_COUNT ();
881 // At a minimum, there should be apply, f, and the list.
882 VM_ASSERT (nlocals
>= 3, abort ());
883 list_idx
= nlocals
- 1;
884 list
= LOCAL_REF (list_idx
);
885 list_len
= scm_ilength (list
);
887 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
889 nlocals
= nlocals
- 2 + list_len
;
890 ALLOC_FRAME (nlocals
);
892 for (i
= 1; i
< list_idx
; i
++)
893 LOCAL_SET (i
- 1, LOCAL_REF (i
));
895 /* Null out these slots, just in case there are less than 2 elements
897 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
898 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
900 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
901 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
905 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
908 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
914 * Capture the current continuation, and tail-apply the procedure in
915 * local slot 1 to it. This instruction is part of the implementation
916 * of `call/cc', and is not generated by the compiler.
918 VM_DEFINE_OP (13, call_cc
, "call/cc", OP1 (U8_X24
))
921 scm_t_dynstack
*dynstack
;
924 VM_HANDLE_INTERRUPTS
;
927 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
928 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
929 SCM_FRAME_DYNAMIC_LINK (fp
),
930 SCM_FRAME_PREVIOUS_SP (fp
),
931 SCM_FRAME_RETURN_ADDRESS (fp
),
934 /* FIXME: Seems silly to capture the registers here, when they are
935 already captured in the registers local, which here we are
936 copying out to the heap; and likewise, the setjmp(®isters)
937 code already has the non-local return handler. But oh
939 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
943 LOCAL_SET (0, LOCAL_REF (1));
949 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
952 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
958 ABORT_CONTINUATION_HOOK ();
965 * Abort to a prompt handler. The tag is expected in r1, and the rest
966 * of the values in the frame are returned to the prompt handler.
967 * This corresponds to a tail application of abort-to-prompt.
969 VM_DEFINE_OP (14, abort
, "abort", OP1 (U8_X24
))
971 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
973 ASSERT (nlocals
>= 2);
974 /* FIXME: Really we should capture the caller's registers. Until
975 then, manually advance the IP so that when the prompt resumes,
976 it continues with the next instruction. */
979 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
980 SCM_EOL
, LOCAL_ADDRESS (0), registers
);
982 /* vm_abort should not return */
986 /* builtin-ref dst:12 idx:12
988 * Load a builtin stub by index into DST.
990 VM_DEFINE_OP (15, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
992 scm_t_uint16 dst
, idx
;
994 UNPACK_12_12 (op
, dst
, idx
);
995 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1004 * Function prologues
1007 /* br-if-nargs-ne expected:24 _:8 offset:24
1008 * br-if-nargs-lt expected:24 _:8 offset:24
1009 * br-if-nargs-gt expected:24 _:8 offset:24
1011 * If the number of actual arguments is not equal, less than, or greater
1012 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1013 * the current instruction pointer.
1015 VM_DEFINE_OP (16, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1019 VM_DEFINE_OP (17, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1023 VM_DEFINE_OP (18, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1028 /* assert-nargs-ee expected:24
1029 * assert-nargs-ge expected:24
1030 * assert-nargs-le expected:24
1032 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1033 * respectively, signal an error.
1035 VM_DEFINE_OP (19, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1037 scm_t_uint32 expected
;
1038 UNPACK_24 (op
, expected
);
1039 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1040 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1043 VM_DEFINE_OP (20, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1045 scm_t_uint32 expected
;
1046 UNPACK_24 (op
, expected
);
1047 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1048 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1051 VM_DEFINE_OP (21, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1053 scm_t_uint32 expected
;
1054 UNPACK_24 (op
, expected
);
1055 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1056 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1060 /* alloc-frame nlocals:24
1062 * Ensure that there is space on the stack for NLOCALS local variables,
1063 * setting them all to SCM_UNDEFINED, except those nargs values that
1064 * were passed as arguments and procedure.
1066 VM_DEFINE_OP (22, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1068 scm_t_uint32 nlocals
, nargs
;
1069 UNPACK_24 (op
, nlocals
);
1071 nargs
= FRAME_LOCALS_COUNT ();
1072 ALLOC_FRAME (nlocals
);
1073 while (nlocals
-- > nargs
)
1074 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1079 /* reset-frame nlocals:24
1081 * Like alloc-frame, but doesn't check that the stack is big enough.
1082 * Used to reset the frame size to something less than the size that
1083 * was previously set via alloc-frame.
1085 VM_DEFINE_OP (23, reset_frame
, "reset-frame", OP1 (U8_U24
))
1087 scm_t_uint32 nlocals
;
1088 UNPACK_24 (op
, nlocals
);
1089 RESET_FRAME (nlocals
);
1093 /* assert-nargs-ee/locals expected:12 nlocals:12
1095 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1096 * number of locals reserved is EXPECTED + NLOCALS.
1098 VM_DEFINE_OP (24, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1100 scm_t_uint16 expected
, nlocals
;
1101 UNPACK_12_12 (op
, expected
, nlocals
);
1102 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1103 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1104 ALLOC_FRAME (expected
+ nlocals
);
1106 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1111 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1113 * Find the first positional argument after NREQ. If it is greater
1114 * than NPOS, jump to OFFSET.
1116 * This instruction is only emitted for functions with multiple
1117 * clauses, and an earlier clause has keywords and no rest arguments.
1118 * See "Case-lambda" in the manual, for more on how case-lambda
1119 * chooses the clause to apply.
1121 VM_DEFINE_OP (25, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1123 scm_t_uint32 nreq
, npos
;
1125 UNPACK_24 (op
, nreq
);
1126 UNPACK_24 (ip
[1], npos
);
1128 /* We can only have too many positionals if there are more
1129 arguments than NPOS. */
1130 if (FRAME_LOCALS_COUNT() > npos
)
1133 for (n
= nreq
; n
< npos
; n
++)
1134 if (scm_is_keyword (LOCAL_REF (n
)))
1136 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1138 scm_t_int32 offset
= ip
[2];
1139 offset
>>= 8; /* Sign-extending shift. */
1146 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1147 * _:8 ntotal:24 kw-offset:32
1149 * Find the last positional argument, and shuffle all the rest above
1150 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1151 * load the constant at KW-OFFSET words from the current IP, and use it
1152 * to bind keyword arguments. If HAS-REST, collect all shuffled
1153 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1154 * the arguments that we shuffled up.
1156 * A macro-mega-instruction.
1158 VM_DEFINE_OP (26, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1160 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1161 scm_t_int32 kw_offset
;
1164 char allow_other_keys
, has_rest
;
1166 UNPACK_24 (op
, nreq
);
1167 allow_other_keys
= ip
[1] & 0x1;
1168 has_rest
= ip
[1] & 0x2;
1169 UNPACK_24 (ip
[1], nreq_and_opt
);
1170 UNPACK_24 (ip
[2], ntotal
);
1172 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1173 VM_ASSERT (!(kw_bits
& 0x7), abort());
1174 kw
= SCM_PACK (kw_bits
);
1176 nargs
= FRAME_LOCALS_COUNT ();
1178 /* look in optionals for first keyword or last positional */
1179 /* starting after the last required positional arg */
1181 while (/* while we have args */
1183 /* and we still have positionals to fill */
1184 && npositional
< nreq_and_opt
1185 /* and we haven't reached a keyword yet */
1186 && !scm_is_keyword (LOCAL_REF (npositional
)))
1187 /* bind this optional arg (by leaving it in place) */
1189 nkw
= nargs
- npositional
;
1190 /* shuffle non-positional arguments above ntotal */
1191 ALLOC_FRAME (ntotal
+ nkw
);
1194 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1195 /* and fill optionals & keyword args with SCM_UNDEFINED */
1198 LOCAL_SET (n
++, SCM_UNDEFINED
);
1200 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1201 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1203 /* Now bind keywords, in the order given. */
1204 for (n
= 0; n
< nkw
; n
++)
1205 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1208 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1209 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1211 SCM si
= SCM_CDAR (walk
);
1212 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1213 LOCAL_REF (ntotal
+ n
+ 1));
1216 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1217 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1218 LOCAL_REF (ntotal
+ n
)));
1222 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1223 LOCAL_REF (ntotal
+ n
)));
1230 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1231 LOCAL_SET (nreq_and_opt
, rest
);
1234 RESET_FRAME (ntotal
);
1241 * Collect any arguments at or above DST into a list, and store that
1244 VM_DEFINE_OP (27, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1246 scm_t_uint32 dst
, nargs
;
1249 UNPACK_24 (op
, dst
);
1250 nargs
= FRAME_LOCALS_COUNT ();
1254 ALLOC_FRAME (dst
+ 1);
1256 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1260 while (nargs
-- > dst
)
1262 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1263 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1266 RESET_FRAME (dst
+ 1);
1269 LOCAL_SET (dst
, rest
);
1278 * Branching instructions
1283 * Add OFFSET, a signed 24-bit number, to the current instruction
1286 VM_DEFINE_OP (28, br
, "br", OP1 (U8_L24
))
1288 scm_t_int32 offset
= op
;
1289 offset
>>= 8; /* Sign-extending shift. */
1293 /* br-if-true test:24 invert:1 _:7 offset:24
1295 * If the value in TEST is true for the purposes of Scheme, add
1296 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1298 VM_DEFINE_OP (29, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1300 BR_UNARY (x
, scm_is_true (x
));
1303 /* br-if-null test:24 invert:1 _:7 offset:24
1305 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1306 * signed 24-bit number, to the current instruction pointer.
1308 VM_DEFINE_OP (30, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1310 BR_UNARY (x
, scm_is_null (x
));
1313 /* br-if-nil test:24 invert:1 _:7 offset:24
1315 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1316 * number, to the current instruction pointer.
1318 VM_DEFINE_OP (31, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1320 BR_UNARY (x
, scm_is_lisp_false (x
));
1323 /* br-if-pair test:24 invert:1 _:7 offset:24
1325 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1326 * to the current instruction pointer.
1328 VM_DEFINE_OP (32, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1330 BR_UNARY (x
, scm_is_pair (x
));
1333 /* br-if-struct test:24 invert:1 _:7 offset:24
1335 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1336 * number, to the current instruction pointer.
1338 VM_DEFINE_OP (33, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1340 BR_UNARY (x
, SCM_STRUCTP (x
));
1343 /* br-if-char test:24 invert:1 _:7 offset:24
1345 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1346 * to the current instruction pointer.
1348 VM_DEFINE_OP (34, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1350 BR_UNARY (x
, SCM_CHARP (x
));
1353 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1355 * If the value in TEST has the TC7 given in the second word, add
1356 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1358 VM_DEFINE_OP (35, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1360 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1363 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1365 * If the value in A is eq? to the value in B, add OFFSET, a signed
1366 * 24-bit number, to the current instruction pointer.
1368 VM_DEFINE_OP (36, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1370 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1373 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1375 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1376 * 24-bit number, to the current instruction pointer.
1378 VM_DEFINE_OP (37, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1382 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1383 && scm_is_true (scm_eqv_p (x
, y
))));
1386 // FIXME: remove, have compiler inline eqv test instead
1387 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1389 * If the value in A is equal? to the value in B, add OFFSET, a signed
1390 * 24-bit number, to the current instruction pointer.
1392 // FIXME: should sync_ip before calling out?
1393 VM_DEFINE_OP (38, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1397 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1398 && scm_is_true (scm_equal_p (x
, y
))));
1401 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1403 * If the value in A is = to the value in B, add OFFSET, a signed
1404 * 24-bit number, to the current instruction pointer.
1406 VM_DEFINE_OP (39, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1408 BR_ARITHMETIC (==, scm_num_eq_p
);
1411 /* br-if-< a:12 b:12 _:8 offset:24
1413 * If the value in A is < to the value in B, add OFFSET, a signed
1414 * 24-bit number, to the current instruction pointer.
1416 VM_DEFINE_OP (40, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1418 BR_ARITHMETIC (<, scm_less_p
);
1421 /* br-if-<= a:12 b:12 _:8 offset:24
1423 * If the value in A is <= to the value in B, add OFFSET, a signed
1424 * 24-bit number, to the current instruction pointer.
1426 VM_DEFINE_OP (41, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1428 BR_ARITHMETIC (<=, scm_leq_p
);
1435 * Lexical binding instructions
1438 /* mov dst:12 src:12
1440 * Copy a value from one local slot to another.
1442 VM_DEFINE_OP (42, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1447 UNPACK_12_12 (op
, dst
, src
);
1448 LOCAL_SET (dst
, LOCAL_REF (src
));
1453 /* long-mov dst:24 _:8 src:24
1455 * Copy a value from one local slot to another.
1457 VM_DEFINE_OP (43, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1462 UNPACK_24 (op
, dst
);
1463 UNPACK_24 (ip
[1], src
);
1464 LOCAL_SET (dst
, LOCAL_REF (src
));
1469 /* box dst:12 src:12
1471 * Create a new variable holding SRC, and place it in DST.
1473 VM_DEFINE_OP (44, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1475 scm_t_uint16 dst
, src
;
1476 UNPACK_12_12 (op
, dst
, src
);
1477 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1481 /* box-ref dst:12 src:12
1483 * Unpack the variable at SRC into DST, asserting that the variable is
1486 VM_DEFINE_OP (45, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1488 scm_t_uint16 dst
, src
;
1490 UNPACK_12_12 (op
, dst
, src
);
1491 var
= LOCAL_REF (src
);
1492 VM_ASSERT (SCM_VARIABLEP (var
),
1493 vm_error_not_a_variable ("variable-ref", var
));
1494 VM_ASSERT (VARIABLE_BOUNDP (var
),
1495 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1496 LOCAL_SET (dst
, VARIABLE_REF (var
));
1500 /* box-set! dst:12 src:12
1502 * Set the contents of the variable at DST to SET.
1504 VM_DEFINE_OP (46, box_set
, "box-set!", OP1 (U8_U12_U12
))
1506 scm_t_uint16 dst
, src
;
1508 UNPACK_12_12 (op
, dst
, src
);
1509 var
= LOCAL_REF (dst
);
1510 VM_ASSERT (SCM_VARIABLEP (var
),
1511 vm_error_not_a_variable ("variable-set!", var
));
1512 VARIABLE_SET (var
, LOCAL_REF (src
));
1516 /* make-closure dst:24 offset:32 _:8 nfree:24
1518 * Make a new closure, and write it to DST. The code for the closure
1519 * will be found at OFFSET words from the current IP. OFFSET is a
1520 * signed 32-bit integer. Space for NFREE free variables will be
1523 VM_DEFINE_OP (47, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1525 scm_t_uint32 dst
, nfree
, n
;
1529 UNPACK_24 (op
, dst
);
1531 UNPACK_24 (ip
[2], nfree
);
1533 // FIXME: Assert range of nfree?
1534 closure
= scm_words (scm_tc7_program
| (nfree
<< 16), nfree
+ 2);
1535 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1536 // FIXME: Elide these initializations?
1537 for (n
= 0; n
< nfree
; n
++)
1538 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1539 LOCAL_SET (dst
, closure
);
1543 /* free-ref dst:12 src:12 _:8 idx:24
1545 * Load free variable IDX from the closure SRC into local slot DST.
1547 VM_DEFINE_OP (48, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1549 scm_t_uint16 dst
, src
;
1551 UNPACK_12_12 (op
, dst
, src
);
1552 UNPACK_24 (ip
[1], idx
);
1553 /* CHECK_FREE_VARIABLE (src); */
1554 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1558 /* free-set! dst:12 src:12 _8 idx:24
1560 * Set free variable IDX from the closure DST to SRC.
1562 VM_DEFINE_OP (49, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1564 scm_t_uint16 dst
, src
;
1566 UNPACK_12_12 (op
, dst
, src
);
1567 UNPACK_24 (ip
[1], idx
);
1568 /* CHECK_FREE_VARIABLE (src); */
1569 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1577 * Immediates and statically allocated non-immediates
1580 /* make-short-immediate dst:8 low-bits:16
1582 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1585 VM_DEFINE_OP (50, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1590 UNPACK_8_16 (op
, dst
, val
);
1591 LOCAL_SET (dst
, SCM_PACK (val
));
1595 /* make-long-immediate dst:24 low-bits:32
1597 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1600 VM_DEFINE_OP (51, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1605 UNPACK_24 (op
, dst
);
1607 LOCAL_SET (dst
, SCM_PACK (val
));
1611 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1613 * Make an immediate with HIGH-BITS and LOW-BITS.
1615 VM_DEFINE_OP (52, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1620 UNPACK_24 (op
, dst
);
1621 #if SIZEOF_SCM_T_BITS > 4
1626 ASSERT (ip
[1] == 0);
1629 LOCAL_SET (dst
, SCM_PACK (val
));
1633 /* make-non-immediate dst:24 offset:32
1635 * Load a pointer to statically allocated memory into DST. The
1636 * object's memory is will be found OFFSET 32-bit words away from the
1637 * current instruction pointer. OFFSET is a signed value. The
1638 * intention here is that the compiler would produce an object file
1639 * containing the words of a non-immediate object, and this
1640 * instruction creates a pointer to that memory, effectively
1641 * resurrecting that object.
1643 * Whether the object is mutable or immutable depends on where it was
1644 * allocated by the compiler, and loaded by the loader.
1646 VM_DEFINE_OP (53, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1651 scm_t_bits unpacked
;
1653 UNPACK_24 (op
, dst
);
1656 unpacked
= (scm_t_bits
) loc
;
1658 VM_ASSERT (!(unpacked
& 0x7), abort());
1660 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1665 /* static-ref dst:24 offset:32
1667 * Load a SCM value into DST. The SCM value will be fetched from
1668 * memory, OFFSET 32-bit words away from the current instruction
1669 * pointer. OFFSET is a signed value.
1671 * The intention is for this instruction to be used to load constants
1672 * that the compiler is unable to statically allocate, like symbols.
1673 * These values would be initialized when the object file loads.
1675 VM_DEFINE_OP (54, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
1680 scm_t_uintptr loc_bits
;
1682 UNPACK_24 (op
, dst
);
1685 loc_bits
= (scm_t_uintptr
) loc
;
1686 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1688 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1693 /* static-set! src:24 offset:32
1695 * Store a SCM value into memory, OFFSET 32-bit words away from the
1696 * current instruction pointer. OFFSET is a signed value.
1698 VM_DEFINE_OP (55, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1704 UNPACK_24 (op
, src
);
1707 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1709 *((SCM
*) loc
) = LOCAL_REF (src
);
1714 /* static-patch! _:24 dst-offset:32 src-offset:32
1716 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1717 * are signed 32-bit values, indicating a memory address as a number
1718 * of 32-bit words away from the current instruction pointer.
1720 VM_DEFINE_OP (56, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1722 scm_t_int32 dst_offset
, src_offset
;
1729 dst_loc
= (void **) (ip
+ dst_offset
);
1730 src
= ip
+ src_offset
;
1731 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1741 * Mutable top-level bindings
1744 /* There are three slightly different ways to resolve toplevel
1747 1. A toplevel reference outside of a function. These need to be
1748 looked up when the expression is evaluated -- no later, and no
1749 before. They are looked up relative to the module that is
1750 current when the expression is evaluated. For example:
1754 The "resolve" instruction resolves the variable (box), and then
1755 access is via box-ref or box-set!.
1757 2. A toplevel reference inside a function. These are looked up
1758 relative to the module that was current when the function was
1759 defined. Unlike code at the toplevel, which is usually run only
1760 once, these bindings benefit from memoized lookup, in which the
1761 variable resulting from the lookup is cached in the function.
1763 (lambda () (if (foo) a b))
1765 The toplevel-box instruction is equivalent to "resolve", but
1766 caches the resulting variable in statically allocated memory.
1768 3. A reference to an identifier with respect to a particular
1769 module. This can happen for primitive references, and
1770 references residualized by macro expansions. These can always
1771 be cached. Use module-box for these.
1774 /* current-module dst:24
1776 * Store the current module in DST.
1778 VM_DEFINE_OP (57, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1782 UNPACK_24 (op
, dst
);
1785 LOCAL_SET (dst
, scm_current_module ());
1790 /* resolve dst:24 bound?:1 _:7 sym:24
1792 * Resolve SYM in the current module, and place the resulting variable
1795 VM_DEFINE_OP (58, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1801 UNPACK_24 (op
, dst
);
1802 UNPACK_24 (ip
[1], sym
);
1805 var
= scm_lookup (LOCAL_REF (sym
));
1807 VM_ASSERT (VARIABLE_BOUNDP (var
),
1808 vm_error_unbound (fp
[0], LOCAL_REF (sym
)));
1809 LOCAL_SET (dst
, var
);
1814 /* define! sym:12 val:12
1816 * Look up a binding for SYM in the current module, creating it if
1817 * necessary. Set its value to VAL.
1819 VM_DEFINE_OP (59, define
, "define!", OP1 (U8_U12_U12
))
1821 scm_t_uint16 sym
, val
;
1822 UNPACK_12_12 (op
, sym
, val
);
1824 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1828 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1830 * Load a SCM value. The SCM value will be fetched from memory,
1831 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1832 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1835 * Then, if the loaded value is a variable, it is placed in DST, and control
1838 * Otherwise, we have to resolve the variable. In that case we load
1839 * the module from MOD-OFFSET, just as we loaded the variable.
1840 * Usually the module gets set when the closure is created. The name
1841 * is an offset to a symbol.
1843 * We use the module and the symbol to resolve the variable, placing it in
1844 * DST, and caching the resolved variable so that we will hit the cache next
1847 VM_DEFINE_OP (60, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1850 scm_t_int32 var_offset
;
1851 scm_t_uint32
* var_loc_u32
;
1855 UNPACK_24 (op
, dst
);
1857 var_loc_u32
= ip
+ var_offset
;
1858 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1859 var_loc
= (SCM
*) var_loc_u32
;
1862 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1865 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1866 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1867 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1868 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1872 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1873 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1875 mod
= *((SCM
*) mod_loc
);
1876 sym
= *((SCM
*) sym_loc
);
1878 /* If the toplevel scope was captured before modules were
1879 booted, use the root module. */
1880 if (scm_is_false (mod
))
1881 mod
= scm_the_root_module ();
1883 var
= scm_module_lookup (mod
, sym
);
1885 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1890 LOCAL_SET (dst
, var
);
1894 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1896 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1897 * instead of the module itself.
1899 VM_DEFINE_OP (61, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1902 scm_t_int32 var_offset
;
1903 scm_t_uint32
* var_loc_u32
;
1907 UNPACK_24 (op
, dst
);
1909 var_loc_u32
= ip
+ var_offset
;
1910 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1911 var_loc
= (SCM
*) var_loc_u32
;
1914 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1917 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1918 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1919 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
1920 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1924 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
1925 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1927 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
1928 sym
= *((SCM
*) sym_loc
);
1930 if (!scm_module_system_booted_p
)
1932 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
1935 scm_equal_p (modname
,
1936 scm_list_2 (SCM_BOOL_T
,
1937 scm_from_utf8_symbol ("guile"))));
1939 var
= scm_lookup (sym
);
1941 else if (scm_is_true (SCM_CAR (modname
)))
1942 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
1944 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
1947 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1952 LOCAL_SET (dst
, var
);
1959 * The dynamic environment
1962 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
1964 * Push a new prompt on the dynamic stack, with a tag from TAG and a
1965 * handler at HANDLER-OFFSET words from the current IP. The handler
1966 * will expect a multiple-value return as if from a call with the
1967 * procedure at PROC-SLOT.
1969 VM_DEFINE_OP (62, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
1971 scm_t_uint32 tag
, proc_slot
;
1973 scm_t_uint8 escape_only_p
;
1974 scm_t_dynstack_prompt_flags flags
;
1976 UNPACK_24 (op
, tag
);
1977 escape_only_p
= ip
[1] & 0x1;
1978 UNPACK_24 (ip
[1], proc_slot
);
1980 offset
>>= 8; /* Sign extension */
1982 /* Push the prompt onto the dynamic stack. */
1983 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
1984 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
1986 fp
- vp
->stack_base
,
1987 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
1993 /* wind winder:12 unwinder:12
1995 * Push wind and unwind procedures onto the dynamic stack. Note that
1996 * neither are actually called; the compiler should emit calls to wind
1997 * and unwind for the normal dynamic-wind control flow. Also note that
1998 * the compiler should have inserted checks that they wind and unwind
1999 * procs are thunks, if it could not prove that to be the case.
2001 VM_DEFINE_OP (63, wind
, "wind", OP1 (U8_U12_U12
))
2003 scm_t_uint16 winder
, unwinder
;
2004 UNPACK_12_12 (op
, winder
, unwinder
);
2005 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2006 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2012 * A normal exit from the dynamic extent of an expression. Pop the top
2013 * entry off of the dynamic stack.
2015 VM_DEFINE_OP (64, unwind
, "unwind", OP1 (U8_X24
))
2017 scm_dynstack_pop (¤t_thread
->dynstack
);
2021 /* push-fluid fluid:12 value:12
2023 * Dynamically bind N fluids to values. The fluids are expected to be
2024 * allocated in a continguous range on the stack, starting from
2025 * FLUID-BASE. The values do not have this restriction.
2027 VM_DEFINE_OP (65, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2029 scm_t_uint32 fluid
, value
;
2031 UNPACK_12_12 (op
, fluid
, value
);
2033 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2034 LOCAL_REF (fluid
), LOCAL_REF (value
),
2035 current_thread
->dynamic_state
);
2041 * Leave the dynamic extent of a with-fluids expression, restoring the
2042 * fluids to their previous values.
2044 VM_DEFINE_OP (66, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2046 /* This function must not allocate. */
2047 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2048 current_thread
->dynamic_state
);
2052 /* fluid-ref dst:12 src:12
2054 * Reference the fluid in SRC, and place the value in DST.
2056 VM_DEFINE_OP (67, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2058 scm_t_uint16 dst
, src
;
2062 UNPACK_12_12 (op
, dst
, src
);
2063 fluid
= LOCAL_REF (src
);
2064 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2065 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2066 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2068 /* Punt dynstate expansion and error handling to the C proc. */
2070 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2074 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2075 if (scm_is_eq (val
, SCM_UNDEFINED
))
2076 val
= SCM_I_FLUID_DEFAULT (fluid
);
2077 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2078 vm_error_unbound_fluid (SCM_FRAME_PROGRAM (fp
), fluid
));
2079 LOCAL_SET (dst
, val
);
2085 /* fluid-set fluid:12 val:12
2087 * Set the value of the fluid in DST to the value in SRC.
2089 VM_DEFINE_OP (68, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2095 UNPACK_12_12 (op
, a
, b
);
2096 fluid
= LOCAL_REF (a
);
2097 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2098 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2099 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2101 /* Punt dynstate expansion and error handling to the C proc. */
2103 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2106 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2115 * Strings, symbols, and keywords
2118 /* string-length dst:12 src:12
2120 * Store the length of the string in SRC in DST.
2122 VM_DEFINE_OP (69, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2125 if (SCM_LIKELY (scm_is_string (str
)))
2126 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2130 RETURN (scm_string_length (str
));
2134 /* string-ref dst:8 src:8 idx:8
2136 * Fetch the character at position IDX in the string in SRC, and store
2139 VM_DEFINE_OP (70, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2141 scm_t_signed_bits i
= 0;
2143 if (SCM_LIKELY (scm_is_string (str
)
2144 && SCM_I_INUMP (idx
)
2145 && ((i
= SCM_I_INUM (idx
)) >= 0)
2146 && i
< scm_i_string_length (str
)))
2147 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2151 RETURN (scm_string_ref (str
, idx
));
2155 /* No string-set! instruction, as there is no good fast path there. */
2157 /* string-to-number dst:12 src:12
2159 * Parse a string in SRC to a number, and store in DST.
2161 VM_DEFINE_OP (71, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2163 scm_t_uint16 dst
, src
;
2165 UNPACK_12_12 (op
, dst
, src
);
2168 scm_string_to_number (LOCAL_REF (src
),
2169 SCM_UNDEFINED
/* radix = 10 */));
2173 /* string-to-symbol dst:12 src:12
2175 * Parse a string in SRC to a symbol, and store in DST.
2177 VM_DEFINE_OP (72, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2179 scm_t_uint16 dst
, src
;
2181 UNPACK_12_12 (op
, dst
, src
);
2183 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2187 /* symbol->keyword dst:12 src:12
2189 * Make a keyword from the symbol in SRC, and store it in DST.
2191 VM_DEFINE_OP (73, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2193 scm_t_uint16 dst
, src
;
2194 UNPACK_12_12 (op
, dst
, src
);
2196 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2206 /* cons dst:8 car:8 cdr:8
2208 * Cons CAR and CDR, and store the result in DST.
2210 VM_DEFINE_OP (74, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2213 RETURN (scm_cons (x
, y
));
2216 /* car dst:12 src:12
2218 * Place the car of SRC in DST.
2220 VM_DEFINE_OP (75, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2223 VM_VALIDATE_PAIR (x
, "car");
2224 RETURN (SCM_CAR (x
));
2227 /* cdr dst:12 src:12
2229 * Place the cdr of SRC in DST.
2231 VM_DEFINE_OP (76, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2234 VM_VALIDATE_PAIR (x
, "cdr");
2235 RETURN (SCM_CDR (x
));
2238 /* set-car! pair:12 car:12
2240 * Set the car of DST to SRC.
2242 VM_DEFINE_OP (77, set_car
, "set-car!", OP1 (U8_U12_U12
))
2246 UNPACK_12_12 (op
, a
, b
);
2249 VM_VALIDATE_PAIR (x
, "set-car!");
2254 /* set-cdr! pair:12 cdr:12
2256 * Set the cdr of DST to SRC.
2258 VM_DEFINE_OP (78, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2262 UNPACK_12_12 (op
, a
, b
);
2265 VM_VALIDATE_PAIR (x
, "set-car!");
2274 * Numeric operations
2277 /* add dst:8 a:8 b:8
2279 * Add A to B, and place the result in DST.
2281 VM_DEFINE_OP (79, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2283 BINARY_INTEGER_OP (+, scm_sum
);
2286 /* add1 dst:12 src:12
2288 * Add 1 to the value in SRC, and place the result in DST.
2290 VM_DEFINE_OP (80, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2294 /* Check for overflow. We must avoid overflow in the signed
2295 addition below, even if X is not an inum. */
2296 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2300 /* Add 1 to the integer without untagging. */
2301 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2303 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2308 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2311 /* sub dst:8 a:8 b:8
2313 * Subtract B from A, and place the result in DST.
2315 VM_DEFINE_OP (81, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2317 BINARY_INTEGER_OP (-, scm_difference
);
2320 /* sub1 dst:12 src:12
2322 * Subtract 1 from SRC, and place the result in DST.
2324 VM_DEFINE_OP (82, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2328 /* Check for overflow. We must avoid overflow in the signed
2329 subtraction below, even if X is not an inum. */
2330 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2334 /* Substract 1 from the integer without untagging. */
2335 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2337 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2342 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2345 /* mul dst:8 a:8 b:8
2347 * Multiply A and B, and place the result in DST.
2349 VM_DEFINE_OP (83, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2353 RETURN (scm_product (x
, y
));
2356 /* div dst:8 a:8 b:8
2358 * Divide A by B, and place the result in DST.
2360 VM_DEFINE_OP (84, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2364 RETURN (scm_divide (x
, y
));
2367 /* quo dst:8 a:8 b:8
2369 * Divide A by B, and place the quotient in DST.
2371 VM_DEFINE_OP (85, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2375 RETURN (scm_quotient (x
, y
));
2378 /* rem dst:8 a:8 b:8
2380 * Divide A by B, and place the remainder in DST.
2382 VM_DEFINE_OP (86, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2386 RETURN (scm_remainder (x
, y
));
2389 /* mod dst:8 a:8 b:8
2391 * Place the modulo of A by B in DST.
2393 VM_DEFINE_OP (87, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2397 RETURN (scm_modulo (x
, y
));
2400 /* ash dst:8 a:8 b:8
2402 * Shift A arithmetically by B bits, and place the result in DST.
2404 VM_DEFINE_OP (88, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2407 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2409 if (SCM_I_INUM (y
) < 0)
2410 /* Right shift, will be a fixnum. */
2411 RETURN (SCM_I_MAKINUM
2412 (SCM_SRS (SCM_I_INUM (x
),
2413 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2414 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2416 /* Left shift. See comments in scm_ash. */
2418 scm_t_signed_bits nn
, bits_to_shift
;
2420 nn
= SCM_I_INUM (x
);
2421 bits_to_shift
= SCM_I_INUM (y
);
2423 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2425 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2427 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2433 RETURN (scm_ash (x
, y
));
2436 /* logand dst:8 a:8 b:8
2438 * Place the bitwise AND of A and B into DST.
2440 VM_DEFINE_OP (89, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2443 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2444 /* Compute bitwise AND without untagging */
2445 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2447 RETURN (scm_logand (x
, y
));
2450 /* logior dst:8 a:8 b:8
2452 * Place the bitwise inclusive OR of A with B in DST.
2454 VM_DEFINE_OP (90, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2457 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2458 /* Compute bitwise OR without untagging */
2459 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2461 RETURN (scm_logior (x
, y
));
2464 /* logxor dst:8 a:8 b:8
2466 * Place the bitwise exclusive OR of A with B in DST.
2468 VM_DEFINE_OP (91, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2471 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2472 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2474 RETURN (scm_logxor (x
, y
));
2477 /* make-vector/immediate dst:8 length:8 init:8
2479 * Make a short vector of known size and write it to DST. The vector
2480 * will have space for LENGTH slots, an immediate value. They will be
2481 * filled with the value in slot INIT.
2483 VM_DEFINE_OP (92, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2485 scm_t_uint8 dst
, init
;
2486 scm_t_int32 length
, n
;
2489 UNPACK_8_8_8 (op
, dst
, length
, init
);
2491 val
= LOCAL_REF (init
);
2492 vector
= scm_words (scm_tc7_vector
| (length
<< 8), length
+ 1);
2493 for (n
= 0; n
< length
; n
++)
2494 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2495 LOCAL_SET (dst
, vector
);
2499 /* vector-length dst:12 src:12
2501 * Store the length of the vector in SRC in DST.
2503 VM_DEFINE_OP (93, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2506 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2507 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2511 RETURN (scm_vector_length (vect
));
2515 /* vector-ref dst:8 src:8 idx:8
2517 * Fetch the item at position IDX in the vector in SRC, and store it
2520 VM_DEFINE_OP (94, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2522 scm_t_signed_bits i
= 0;
2524 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2525 && SCM_I_INUMP (idx
)
2526 && ((i
= SCM_I_INUM (idx
)) >= 0)
2527 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2528 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2532 RETURN (scm_vector_ref (vect
, idx
));
2536 /* vector-ref/immediate dst:8 src:8 idx:8
2538 * Fill DST with the item IDX elements into the vector at SRC. Useful
2539 * for building data types using vectors.
2541 VM_DEFINE_OP (95, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2543 scm_t_uint8 dst
, src
, idx
;
2546 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2547 v
= LOCAL_REF (src
);
2548 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2549 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2550 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2552 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2556 /* vector-set! dst:8 idx:8 src:8
2558 * Store SRC into the vector DST at index IDX.
2560 VM_DEFINE_OP (96, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2562 scm_t_uint8 dst
, idx_var
, src
;
2564 scm_t_signed_bits i
= 0;
2566 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2567 vect
= LOCAL_REF (dst
);
2568 idx
= LOCAL_REF (idx_var
);
2569 val
= LOCAL_REF (src
);
2571 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2572 && SCM_I_INUMP (idx
)
2573 && ((i
= SCM_I_INUM (idx
)) >= 0)
2574 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2575 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2579 scm_vector_set_x (vect
, idx
, val
);
2584 /* vector-set!/immediate dst:8 idx:8 src:8
2586 * Store SRC into the vector DST at index IDX. Here IDX is an
2589 VM_DEFINE_OP (97, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2591 scm_t_uint8 dst
, idx
, src
;
2594 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2595 vect
= LOCAL_REF (dst
);
2596 val
= LOCAL_REF (src
);
2598 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2599 && idx
< SCM_I_VECTOR_LENGTH (vect
)))
2600 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2604 scm_vector_set_x (vect
, scm_from_uint8 (idx
), val
);
2616 /* struct-vtable dst:12 src:12
2618 * Store the vtable of SRC into DST.
2620 VM_DEFINE_OP (98, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2623 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2624 RETURN (SCM_STRUCT_VTABLE (obj
));
2627 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2629 * Allocate a new struct with VTABLE, and place it in DST. The struct
2630 * will be constructed with space for NFIELDS fields, which should
2631 * correspond to the field count of the VTABLE.
2633 VM_DEFINE_OP (99, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2635 scm_t_uint8 dst
, vtable
, nfields
;
2638 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2641 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2642 LOCAL_SET (dst
, ret
);
2647 /* struct-ref/immediate dst:8 src:8 idx:8
2649 * Fetch the item at slot IDX in the struct in SRC, and store it
2650 * in DST. IDX is an immediate unsigned 8-bit value.
2652 VM_DEFINE_OP (100, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2654 scm_t_uint8 dst
, src
, idx
;
2657 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2659 obj
= LOCAL_REF (src
);
2661 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2662 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2663 SCM_VTABLE_FLAG_SIMPLE
)
2664 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2665 scm_vtable_index_size
)))
2666 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2669 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2672 /* struct-set!/immediate dst:8 idx:8 src:8
2674 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2675 * unsigned 8-bit value.
2677 VM_DEFINE_OP (101, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2679 scm_t_uint8 dst
, idx
, src
;
2682 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2684 obj
= LOCAL_REF (dst
);
2685 val
= LOCAL_REF (src
);
2687 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2688 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2689 SCM_VTABLE_FLAG_SIMPLE
)
2690 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2691 SCM_VTABLE_FLAG_SIMPLE_RW
)
2692 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2693 scm_vtable_index_size
)))
2695 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2700 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2704 /* class-of dst:12 type:12
2706 * Store the vtable of SRC into DST.
2708 VM_DEFINE_OP (102, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2711 if (SCM_INSTANCEP (obj
))
2712 RETURN (SCM_CLASS_OF (obj
));
2714 RETURN (scm_class_of (obj
));
2717 /* slot-ref dst:8 src:8 idx:8
2719 * Fetch the item at slot IDX in the struct in SRC, and store it in
2720 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
2721 * index into the stack.
2723 VM_DEFINE_OP (103, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2725 scm_t_uint8 dst
, src
, idx
;
2726 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2728 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
2732 /* slot-set! dst:8 idx:8 src:8
2734 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
2735 * IDX is an 8-bit immediate value, not an index into the stack.
2737 VM_DEFINE_OP (104, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
2739 scm_t_uint8 dst
, idx
, src
;
2740 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2741 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
2749 * Arrays, packed uniform arrays, and bytevectors.
2752 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2754 * Load the contiguous typed array located at OFFSET 32-bit words away
2755 * from the instruction pointer, and store into DST. LEN is a byte
2756 * length. OFFSET is signed.
2758 VM_DEFINE_OP (105, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2760 scm_t_uint8 dst
, type
, shape
;
2764 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2768 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2774 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
2776 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2778 VM_DEFINE_OP (106, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
2780 scm_t_uint16 dst
, type
, fill
, bounds
;
2781 UNPACK_12_12 (op
, dst
, type
);
2782 UNPACK_12_12 (ip
[1], fill
, bounds
);
2784 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2785 LOCAL_REF (bounds
)));
2789 /* bv-u8-ref dst:8 src:8 idx:8
2790 * bv-s8-ref dst:8 src:8 idx:8
2791 * bv-u16-ref dst:8 src:8 idx:8
2792 * bv-s16-ref dst:8 src:8 idx:8
2793 * bv-u32-ref dst:8 src:8 idx:8
2794 * bv-s32-ref dst:8 src:8 idx:8
2795 * bv-u64-ref dst:8 src:8 idx:8
2796 * bv-s64-ref dst:8 src:8 idx:8
2797 * bv-f32-ref dst:8 src:8 idx:8
2798 * bv-f64-ref dst:8 src:8 idx:8
2800 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2801 * it in DST. All accesses use native endianness.
2803 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2805 scm_t_signed_bits i; \
2806 const scm_t_ ## type *int_ptr; \
2809 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2810 i = SCM_I_INUM (idx); \
2811 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2813 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2815 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2816 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2817 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2821 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2825 #define BV_INT_REF(stem, type, size) \
2827 scm_t_signed_bits i; \
2828 const scm_t_ ## type *int_ptr; \
2831 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2832 i = SCM_I_INUM (idx); \
2833 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2835 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2837 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2838 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2840 scm_t_ ## type x = *int_ptr; \
2841 if (SCM_FIXABLE (x)) \
2842 RETURN (SCM_I_MAKINUM (x)); \
2846 RETURN (scm_from_ ## type (x)); \
2852 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2856 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2858 scm_t_signed_bits i; \
2859 const type *float_ptr; \
2862 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2863 i = SCM_I_INUM (idx); \
2864 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2867 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2869 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2870 && (ALIGNED_P (float_ptr, type)))) \
2871 RETURN (scm_from_double (*float_ptr)); \
2873 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2876 VM_DEFINE_OP (107, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2877 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2879 VM_DEFINE_OP (108, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2880 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2882 VM_DEFINE_OP (109, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2883 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2885 VM_DEFINE_OP (110, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2886 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2888 VM_DEFINE_OP (111, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2889 #if SIZEOF_VOID_P > 4
2890 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2892 BV_INT_REF (u32
, uint32
, 4);
2895 VM_DEFINE_OP (112, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2896 #if SIZEOF_VOID_P > 4
2897 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2899 BV_INT_REF (s32
, int32
, 4);
2902 VM_DEFINE_OP (113, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2903 BV_INT_REF (u64
, uint64
, 8);
2905 VM_DEFINE_OP (114, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2906 BV_INT_REF (s64
, int64
, 8);
2908 VM_DEFINE_OP (115, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2909 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2911 VM_DEFINE_OP (116, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2912 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2914 /* bv-u8-set! dst:8 idx:8 src:8
2915 * bv-s8-set! dst:8 idx:8 src:8
2916 * bv-u16-set! dst:8 idx:8 src:8
2917 * bv-s16-set! dst:8 idx:8 src:8
2918 * bv-u32-set! dst:8 idx:8 src:8
2919 * bv-s32-set! dst:8 idx:8 src:8
2920 * bv-u64-set! dst:8 idx:8 src:8
2921 * bv-s64-set! dst:8 idx:8 src:8
2922 * bv-f32-set! dst:8 idx:8 src:8
2923 * bv-f64-set! dst:8 idx:8 src:8
2925 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2926 * values are written using native endianness.
2928 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2930 scm_t_uint8 dst, idx, src; \
2931 scm_t_signed_bits i, j = 0; \
2932 SCM bv, scm_idx, val; \
2933 scm_t_ ## type *int_ptr; \
2935 UNPACK_8_8_8 (op, dst, idx, src); \
2936 bv = LOCAL_REF (dst); \
2937 scm_idx = LOCAL_REF (idx); \
2938 val = LOCAL_REF (src); \
2939 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2940 i = SCM_I_INUM (scm_idx); \
2941 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2943 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2945 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2946 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2947 && (SCM_I_INUMP (val)) \
2948 && ((j = SCM_I_INUM (val)) >= min) \
2950 *int_ptr = (scm_t_ ## type) j; \
2954 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
2959 #define BV_INT_SET(stem, type, size) \
2961 scm_t_uint8 dst, idx, src; \
2962 scm_t_signed_bits i; \
2963 SCM bv, scm_idx, val; \
2964 scm_t_ ## type *int_ptr; \
2966 UNPACK_8_8_8 (op, dst, idx, src); \
2967 bv = LOCAL_REF (dst); \
2968 scm_idx = LOCAL_REF (idx); \
2969 val = LOCAL_REF (src); \
2970 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2971 i = SCM_I_INUM (scm_idx); \
2972 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2974 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2976 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2977 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2978 *int_ptr = scm_to_ ## type (val); \
2982 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
2987 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
2989 scm_t_uint8 dst, idx, src; \
2990 scm_t_signed_bits i; \
2991 SCM bv, scm_idx, val; \
2994 UNPACK_8_8_8 (op, dst, idx, src); \
2995 bv = LOCAL_REF (dst); \
2996 scm_idx = LOCAL_REF (idx); \
2997 val = LOCAL_REF (src); \
2998 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2999 i = SCM_I_INUM (scm_idx); \
3000 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3002 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3004 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3005 && (ALIGNED_P (float_ptr, type)))) \
3006 *float_ptr = scm_to_double (val); \
3010 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3015 VM_DEFINE_OP (117, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3016 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3018 VM_DEFINE_OP (118, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3019 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3021 VM_DEFINE_OP (119, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3022 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3024 VM_DEFINE_OP (120, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3025 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3027 VM_DEFINE_OP (121, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3028 #if SIZEOF_VOID_P > 4
3029 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3031 BV_INT_SET (u32
, uint32
, 4);
3034 VM_DEFINE_OP (122, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3035 #if SIZEOF_VOID_P > 4
3036 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3038 BV_INT_SET (s32
, int32
, 4);
3041 VM_DEFINE_OP (123, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3042 BV_INT_SET (u64
, uint64
, 8);
3044 VM_DEFINE_OP (124, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3045 BV_INT_SET (s64
, int64
, 8);
3047 VM_DEFINE_OP (125, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3048 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3050 VM_DEFINE_OP (126, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3051 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3053 VM_DEFINE_OP (127, unused_127
, NULL
, NOP
)
3054 VM_DEFINE_OP (128, unused_128
, NULL
, NOP
)
3055 VM_DEFINE_OP (129, unused_129
, NULL
, NOP
)
3056 VM_DEFINE_OP (130, unused_130
, NULL
, NOP
)
3057 VM_DEFINE_OP (131, unused_131
, NULL
, NOP
)
3058 VM_DEFINE_OP (132, unused_132
, NULL
, NOP
)
3059 VM_DEFINE_OP (133, unused_133
, NULL
, NOP
)
3060 VM_DEFINE_OP (134, unused_134
, NULL
, NOP
)
3061 VM_DEFINE_OP (135, unused_135
, NULL
, NOP
)
3062 VM_DEFINE_OP (136, unused_136
, NULL
, NOP
)
3063 VM_DEFINE_OP (137, unused_137
, NULL
, NOP
)
3064 VM_DEFINE_OP (138, unused_138
, NULL
, NOP
)
3065 VM_DEFINE_OP (139, unused_139
, NULL
, NOP
)
3066 VM_DEFINE_OP (140, unused_140
, NULL
, NOP
)
3067 VM_DEFINE_OP (141, unused_141
, NULL
, NOP
)
3068 VM_DEFINE_OP (142, unused_142
, NULL
, NOP
)
3069 VM_DEFINE_OP (143, unused_143
, NULL
, NOP
)
3070 VM_DEFINE_OP (144, unused_144
, NULL
, NOP
)
3071 VM_DEFINE_OP (145, unused_145
, NULL
, NOP
)
3072 VM_DEFINE_OP (146, unused_146
, NULL
, NOP
)
3073 VM_DEFINE_OP (147, unused_147
, NULL
, NOP
)
3074 VM_DEFINE_OP (148, unused_148
, NULL
, NOP
)
3075 VM_DEFINE_OP (149, unused_149
, NULL
, NOP
)
3076 VM_DEFINE_OP (150, unused_150
, NULL
, NOP
)
3077 VM_DEFINE_OP (151, unused_151
, NULL
, NOP
)
3078 VM_DEFINE_OP (152, unused_152
, NULL
, NOP
)
3079 VM_DEFINE_OP (153, unused_153
, NULL
, NOP
)
3080 VM_DEFINE_OP (154, unused_154
, NULL
, NOP
)
3081 VM_DEFINE_OP (155, unused_155
, NULL
, NOP
)
3082 VM_DEFINE_OP (156, unused_156
, NULL
, NOP
)
3083 VM_DEFINE_OP (157, unused_157
, NULL
, NOP
)
3084 VM_DEFINE_OP (158, unused_158
, NULL
, NOP
)
3085 VM_DEFINE_OP (159, unused_159
, NULL
, NOP
)
3086 VM_DEFINE_OP (160, unused_160
, NULL
, NOP
)
3087 VM_DEFINE_OP (161, unused_161
, NULL
, NOP
)
3088 VM_DEFINE_OP (162, unused_162
, NULL
, NOP
)
3089 VM_DEFINE_OP (163, unused_163
, NULL
, NOP
)
3090 VM_DEFINE_OP (164, unused_164
, NULL
, NOP
)
3091 VM_DEFINE_OP (165, unused_165
, NULL
, NOP
)
3092 VM_DEFINE_OP (166, unused_166
, NULL
, NOP
)
3093 VM_DEFINE_OP (167, unused_167
, NULL
, NOP
)
3094 VM_DEFINE_OP (168, unused_168
, NULL
, NOP
)
3095 VM_DEFINE_OP (169, unused_169
, NULL
, NOP
)
3096 VM_DEFINE_OP (170, unused_170
, NULL
, NOP
)
3097 VM_DEFINE_OP (171, unused_171
, NULL
, NOP
)
3098 VM_DEFINE_OP (172, unused_172
, NULL
, NOP
)
3099 VM_DEFINE_OP (173, unused_173
, NULL
, NOP
)
3100 VM_DEFINE_OP (174, unused_174
, NULL
, NOP
)
3101 VM_DEFINE_OP (175, unused_175
, NULL
, NOP
)
3102 VM_DEFINE_OP (176, unused_176
, NULL
, NOP
)
3103 VM_DEFINE_OP (177, unused_177
, NULL
, NOP
)
3104 VM_DEFINE_OP (178, unused_178
, NULL
, NOP
)
3105 VM_DEFINE_OP (179, unused_179
, NULL
, NOP
)
3106 VM_DEFINE_OP (180, unused_180
, NULL
, NOP
)
3107 VM_DEFINE_OP (181, unused_181
, NULL
, NOP
)
3108 VM_DEFINE_OP (182, unused_182
, NULL
, NOP
)
3109 VM_DEFINE_OP (183, unused_183
, NULL
, NOP
)
3110 VM_DEFINE_OP (184, unused_184
, NULL
, NOP
)
3111 VM_DEFINE_OP (185, unused_185
, NULL
, NOP
)
3112 VM_DEFINE_OP (186, unused_186
, NULL
, NOP
)
3113 VM_DEFINE_OP (187, unused_187
, NULL
, NOP
)
3114 VM_DEFINE_OP (188, unused_188
, NULL
, NOP
)
3115 VM_DEFINE_OP (189, unused_189
, NULL
, NOP
)
3116 VM_DEFINE_OP (190, unused_190
, NULL
, NOP
)
3117 VM_DEFINE_OP (191, unused_191
, NULL
, NOP
)
3118 VM_DEFINE_OP (192, unused_192
, NULL
, NOP
)
3119 VM_DEFINE_OP (193, unused_193
, NULL
, NOP
)
3120 VM_DEFINE_OP (194, unused_194
, NULL
, NOP
)
3121 VM_DEFINE_OP (195, unused_195
, NULL
, NOP
)
3122 VM_DEFINE_OP (196, unused_196
, NULL
, NOP
)
3123 VM_DEFINE_OP (197, unused_197
, NULL
, NOP
)
3124 VM_DEFINE_OP (198, unused_198
, NULL
, NOP
)
3125 VM_DEFINE_OP (199, unused_199
, NULL
, NOP
)
3126 VM_DEFINE_OP (200, unused_200
, NULL
, NOP
)
3127 VM_DEFINE_OP (201, unused_201
, NULL
, NOP
)
3128 VM_DEFINE_OP (202, unused_202
, NULL
, NOP
)
3129 VM_DEFINE_OP (203, unused_203
, NULL
, NOP
)
3130 VM_DEFINE_OP (204, unused_204
, NULL
, NOP
)
3131 VM_DEFINE_OP (205, unused_205
, NULL
, NOP
)
3132 VM_DEFINE_OP (206, unused_206
, NULL
, NOP
)
3133 VM_DEFINE_OP (207, unused_207
, NULL
, NOP
)
3134 VM_DEFINE_OP (208, unused_208
, NULL
, NOP
)
3135 VM_DEFINE_OP (209, unused_209
, NULL
, NOP
)
3136 VM_DEFINE_OP (210, unused_210
, NULL
, NOP
)
3137 VM_DEFINE_OP (211, unused_211
, NULL
, NOP
)
3138 VM_DEFINE_OP (212, unused_212
, NULL
, NOP
)
3139 VM_DEFINE_OP (213, unused_213
, NULL
, NOP
)
3140 VM_DEFINE_OP (214, unused_214
, NULL
, NOP
)
3141 VM_DEFINE_OP (215, unused_215
, NULL
, NOP
)
3142 VM_DEFINE_OP (216, unused_216
, NULL
, NOP
)
3143 VM_DEFINE_OP (217, unused_217
, NULL
, NOP
)
3144 VM_DEFINE_OP (218, unused_218
, NULL
, NOP
)
3145 VM_DEFINE_OP (219, unused_219
, NULL
, NOP
)
3146 VM_DEFINE_OP (220, unused_220
, NULL
, NOP
)
3147 VM_DEFINE_OP (221, unused_221
, NULL
, NOP
)
3148 VM_DEFINE_OP (222, unused_222
, NULL
, NOP
)
3149 VM_DEFINE_OP (223, unused_223
, NULL
, NOP
)
3150 VM_DEFINE_OP (224, unused_224
, NULL
, NOP
)
3151 VM_DEFINE_OP (225, unused_225
, NULL
, NOP
)
3152 VM_DEFINE_OP (226, unused_226
, NULL
, NOP
)
3153 VM_DEFINE_OP (227, unused_227
, NULL
, NOP
)
3154 VM_DEFINE_OP (228, unused_228
, NULL
, NOP
)
3155 VM_DEFINE_OP (229, unused_229
, NULL
, NOP
)
3156 VM_DEFINE_OP (230, unused_230
, NULL
, NOP
)
3157 VM_DEFINE_OP (231, unused_231
, NULL
, NOP
)
3158 VM_DEFINE_OP (232, unused_232
, NULL
, NOP
)
3159 VM_DEFINE_OP (233, unused_233
, NULL
, NOP
)
3160 VM_DEFINE_OP (234, unused_234
, NULL
, NOP
)
3161 VM_DEFINE_OP (235, unused_235
, NULL
, NOP
)
3162 VM_DEFINE_OP (236, unused_236
, NULL
, NOP
)
3163 VM_DEFINE_OP (237, unused_237
, NULL
, NOP
)
3164 VM_DEFINE_OP (238, unused_238
, NULL
, NOP
)
3165 VM_DEFINE_OP (239, unused_239
, NULL
, NOP
)
3166 VM_DEFINE_OP (240, unused_240
, NULL
, NOP
)
3167 VM_DEFINE_OP (241, unused_241
, NULL
, NOP
)
3168 VM_DEFINE_OP (242, unused_242
, NULL
, NOP
)
3169 VM_DEFINE_OP (243, unused_243
, NULL
, NOP
)
3170 VM_DEFINE_OP (244, unused_244
, NULL
, NOP
)
3171 VM_DEFINE_OP (245, unused_245
, NULL
, NOP
)
3172 VM_DEFINE_OP (246, unused_246
, NULL
, NOP
)
3173 VM_DEFINE_OP (247, unused_247
, NULL
, NOP
)
3174 VM_DEFINE_OP (248, unused_248
, NULL
, NOP
)
3175 VM_DEFINE_OP (249, unused_249
, NULL
, NOP
)
3176 VM_DEFINE_OP (250, unused_250
, NULL
, NOP
)
3177 VM_DEFINE_OP (251, unused_251
, NULL
, NOP
)
3178 VM_DEFINE_OP (252, unused_252
, NULL
, NOP
)
3179 VM_DEFINE_OP (253, unused_253
, NULL
, NOP
)
3180 VM_DEFINE_OP (254, unused_254
, NULL
, NOP
)
3181 VM_DEFINE_OP (255, unused_255
, NULL
, NOP
)
3183 vm_error_bad_instruction (op
);
3184 abort (); /* never reached */
3187 END_DISPATCH_SWITCH
;
3191 #undef ABORT_CONTINUATION_HOOK
3196 #undef BEGIN_DISPATCH_SWITCH
3197 #undef BINARY_INTEGER_OP
3198 #undef BR_ARITHMETIC
3202 #undef BV_FIXABLE_INT_REF
3203 #undef BV_FIXABLE_INT_SET
3208 #undef CACHE_REGISTER
3209 #undef CHECK_OVERFLOW
3210 #undef END_DISPATCH_SWITCH
3211 #undef FREE_VARIABLE_REF
3220 #undef POP_CONTINUATION_HOOK
3221 #undef PUSH_CONTINUATION_HOOK
3222 #undef RESTORE_CONTINUATION_HOOK
3224 #undef RETURN_ONE_VALUE
3225 #undef RETURN_VALUE_LIST
3235 #undef VARIABLE_BOUNDP
3238 #undef VM_CHECK_FREE_VARIABLE
3239 #undef VM_CHECK_OBJECT
3240 #undef VM_CHECK_UNDERFLOW
3242 #undef VM_INSTRUCTION_TO_LABEL
3244 #undef VM_VALIDATE_BYTEVECTOR
3245 #undef VM_VALIDATE_PAIR
3246 #undef VM_VALIDATE_STRUCT
3249 (defun renumber-ops ()
3250 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3253 (let ((counter -1)) (goto-char (point-min))
3254 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3256 (number-to-string (setq counter (1+ counter)))