1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
19 /* This file is included in vm.c multiple times. */
22 #define UNPACK_8_8_8(op,a,b,c) \
25 a = (op >> 8) & 0xff; \
26 b = (op >> 16) & 0xff; \
31 #define UNPACK_8_16(op,a,b) \
34 a = (op >> 8) & 0xff; \
39 #define UNPACK_16_8(op,a,b) \
42 a = (op >> 8) & 0xffff; \
47 #define UNPACK_12_12(op,a,b) \
50 a = (op >> 8) & 0xfff; \
55 #define UNPACK_24(op,a) \
63 /* Assign some registers by hand. There used to be a bigger list here,
64 but it was never tested, and in the case of x86-32, was a source of
65 compilation failures. It can be revived if it's useful, but my naive
66 hope is that simply annotating the locals with "register" will be a
67 sufficient hint to the compiler. */
69 # if defined __x86_64__
70 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
71 well. Tell it to keep the jump table in a r12, which is
73 # define JT_REG asm ("r12")
87 #define VM_ASSERT(condition, handler) \
89 if (SCM_UNLIKELY (!(condition))) \
96 #ifdef VM_ENABLE_ASSERTIONS
97 # define ASSERT(condition) VM_ASSERT (condition, abort())
99 # define ASSERT(condition)
103 #define RUN_HOOK(exp) \
105 if (SCM_UNLIKELY (vp->trace_level > 0)) \
113 #define RUN_HOOK(exp)
115 #define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
116 #define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
118 #define APPLY_HOOK() \
120 #define PUSH_CONTINUATION_HOOK() \
121 RUN_HOOK0 (push_continuation)
122 #define POP_CONTINUATION_HOOK(old_fp) \
123 RUN_HOOK1 (pop_continuation, old_fp)
124 #define NEXT_HOOK() \
126 #define ABORT_CONTINUATION_HOOK() \
129 #define VM_HANDLE_INTERRUPTS \
130 SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ())
135 This is Guile's new virtual machine. When I say "new", I mean
136 relative to the current virtual machine. At some point it will
137 become "the" virtual machine, and we'll delete this paragraph. As
138 such, the rest of the comments speak as if there's only one VM.
139 In difference from the old VM, local 0 is the procedure, and the
140 first argument is local 1. At some point in the future we should
141 change the fp to point to the procedure and not to local 1.
147 /* The VM has three state bits: the instruction pointer (IP), the frame
148 pointer (FP), and the top-of-stack pointer (SP). We cache the first
149 two of these in machine registers, local to the VM, because they are
150 used extensively by the VM. As the SP is used more by code outside
151 the VM than by the VM itself, we don't bother caching it locally.
153 Since the FP changes infrequently, relative to the IP, we keep vp->fp
154 in sync with the local FP. This would be a big lose for the IP,
155 though, so instead of updating vp->ip all the time, we call SYNC_IP
156 whenever we would need to know the IP of the top frame. In practice,
157 we need to SYNC_IP whenever we call out of the VM to a function that
158 would like to walk the stack, perhaps as the result of an
161 One more thing. We allow the stack to move, when it expands.
162 Therefore if you call out to a C procedure that could call Scheme
163 code, or otherwise push anything on the stack, you will need to
164 CACHE_FP afterwards to restore the possibly-changed FP. */
166 #define SYNC_IP() vp->ip = (ip)
168 #define CACHE_FP() fp = (vp->fp)
169 #define CACHE_REGISTER() \
177 /* After advancing vp->sp, but before writing any stack slots, check
178 that it is actually in bounds. If it is not in bounds, currently we
179 signal an error. In the future we may expand the stack instead,
180 possibly by moving it elsewhere, therefore no pointer into the stack
181 besides FP is valid across a CHECK_OVERFLOW call. Be careful! */
182 #define CHECK_OVERFLOW() \
184 if (SCM_UNLIKELY (vp->sp >= vp->stack_limit)) \
187 vm_expand_stack (vp); \
192 /* Reserve stack space for a frame. Will check that there is sufficient
193 stack space for N locals, including the procedure. Invoke after
194 preparing the new frame and setting the fp and ip. */
195 #define ALLOC_FRAME(n) \
197 vp->sp = LOCAL_ADDRESS (n - 1); \
198 if (vp->sp > vp->sp_max_since_gc) \
200 vp->sp_max_since_gc = vp->sp; \
205 /* Reset the current frame to hold N locals. Used when we know that no
206 stack expansion is needed. */
207 #define RESET_FRAME(n) \
209 vp->sp = LOCAL_ADDRESS (n - 1); \
210 if (vp->sp > vp->sp_max_since_gc) \
211 vp->sp_max_since_gc = vp->sp; \
214 /* Compute the number of locals in the frame. At a call, this is equal
215 to the number of actual arguments when a function is first called,
216 plus one for the function. */
217 #define FRAME_LOCALS_COUNT_FROM(slot) \
218 (vp->sp + 1 - LOCAL_ADDRESS (slot))
219 #define FRAME_LOCALS_COUNT() \
220 FRAME_LOCALS_COUNT_FROM (0)
222 /* Restore registers after returning from a frame. */
223 #define RESTORE_FRAME() \
228 #ifdef HAVE_LABELS_AS_VALUES
229 # define BEGIN_DISPATCH_SWITCH /* */
230 # define END_DISPATCH_SWITCH /* */
237 goto *jump_table[op & 0xff]; \
240 # define VM_DEFINE_OP(opcode, tag, name, meta) \
243 # define BEGIN_DISPATCH_SWITCH \
249 # define END_DISPATCH_SWITCH \
258 # define VM_DEFINE_OP(opcode, tag, name, meta) \
263 #define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
264 #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
265 #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
267 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
268 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
269 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
271 #define RETURN_ONE_VALUE(ret) \
275 VM_HANDLE_INTERRUPTS; \
277 ip = SCM_FRAME_RETURN_ADDRESS (fp); \
278 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
280 old_fp[-1] = SCM_BOOL_F; \
281 old_fp[-2] = SCM_BOOL_F; \
283 SCM_FRAME_LOCAL (old_fp, 1) = val; \
284 vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
285 POP_CONTINUATION_HOOK (old_fp); \
289 /* While we could generate the list-unrolling code here, it's fine for
290 now to just tail-call (apply values vals). */
291 #define RETURN_VALUE_LIST(vals_) \
294 VM_HANDLE_INTERRUPTS; \
295 fp[0] = vm_builtin_apply; \
296 fp[1] = vm_builtin_values; \
299 ip = (scm_t_uint32 *) vm_builtin_apply_code; \
300 goto op_tail_apply; \
303 #define BR_NARGS(rel) \
304 scm_t_uint32 expected; \
305 UNPACK_24 (op, expected); \
306 if (FRAME_LOCALS_COUNT() rel expected) \
308 scm_t_int32 offset = ip[1]; \
309 offset >>= 8; /* Sign-extending shift. */ \
314 #define BR_UNARY(x, exp) \
317 UNPACK_24 (op, test); \
318 x = LOCAL_REF (test); \
319 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
321 scm_t_int32 offset = ip[1]; \
322 offset >>= 8; /* Sign-extending shift. */ \
324 VM_HANDLE_INTERRUPTS; \
329 #define BR_BINARY(x, y, exp) \
332 UNPACK_12_12 (op, a, b); \
335 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
337 scm_t_int32 offset = ip[1]; \
338 offset >>= 8; /* Sign-extending shift. */ \
340 VM_HANDLE_INTERRUPTS; \
345 #define BR_ARITHMETIC(crel,srel) \
349 UNPACK_12_12 (op, a, b); \
352 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
354 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
355 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
356 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
358 scm_t_int32 offset = ip[1]; \
359 offset >>= 8; /* Sign-extending shift. */ \
361 VM_HANDLE_INTERRUPTS; \
372 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
374 scm_t_int32 offset = ip[1]; \
375 offset >>= 8; /* Sign-extending shift. */ \
377 VM_HANDLE_INTERRUPTS; \
385 scm_t_uint16 dst, src; \
387 UNPACK_12_12 (op, dst, src); \
389 #define ARGS2(a1, a2) \
390 scm_t_uint8 dst, src1, src2; \
392 UNPACK_8_8_8 (op, dst, src1, src2); \
393 a1 = LOCAL_REF (src1); \
394 a2 = LOCAL_REF (src2)
396 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
397 #define RETURN_EXP(exp) \
398 do { SCM __x; SYNC_IP (); __x = exp; CACHE_FP (); RETURN (__x); } while (0)
400 /* The maximum/minimum tagged integers. */
402 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
404 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
406 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
407 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
409 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
412 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
414 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
415 if (SCM_FIXABLE (n)) \
416 RETURN (SCM_I_MAKINUM (n)); \
418 RETURN_EXP (SFUNC (x, y)); \
421 #define VM_VALIDATE_PAIR(x, proc) \
422 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
424 #define VM_VALIDATE_STRUCT(obj, proc) \
425 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
427 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
428 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
430 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
431 #define ALIGNED_P(ptr, type) \
432 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
435 VM_NAME (scm_i_thread
*thread
, struct scm_vm
*vp
,
436 scm_i_jmp_buf
*registers
, int resume
)
438 /* Instruction pointer: A pointer to the opcode that is currently
440 register scm_t_uint32
*ip IP_REG
;
442 /* Frame pointer: A pointer into the stack, off of which we index
443 arguments and local variables. Pushed at function calls, popped on
445 register SCM
*fp FP_REG
;
447 /* Current opcode: A cache of *ip. */
448 register scm_t_uint32 op
;
450 #ifdef HAVE_LABELS_AS_VALUES
451 static const void *jump_table_
[256] = {
452 #define LABEL_ADDR(opcode, tag, name, meta) &&op_##tag,
453 FOR_EACH_VM_OPERATION(LABEL_ADDR
)
456 register const void **jump_table JT_REG
;
457 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
458 load instruction at each instruction dispatch. */
459 jump_table
= jump_table_
;
462 /* Load VM registers. */
465 VM_HANDLE_INTERRUPTS
;
467 /* Usually a call to the VM happens on application, with the boot
468 continuation on the next frame. Sometimes it happens after a
469 non-local exit however; in that case the VM state is all set up,
470 and we have but to jump to the next opcode. */
471 if (SCM_UNLIKELY (resume
))
475 while (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
477 SCM proc
= SCM_FRAME_PROGRAM (fp
);
479 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
481 LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc
));
484 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
486 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
488 /* Shuffle args up. */
491 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
493 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
498 vm_error_wrong_type_apply (proc
);
502 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
505 BEGIN_DISPATCH_SWITCH
;
516 * Bring the VM to a halt, returning all the values from the stack.
518 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
520 /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
522 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT_FROM (4);
531 for (n
= nvals
; n
> 0; n
--)
532 ret
= scm_inline_cons (thread
, LOCAL_REF (4 + n
- 1), ret
);
533 ret
= scm_values (ret
);
536 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
537 vp
->sp
= SCM_FRAME_PREVIOUS_SP (fp
);
538 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
543 /* call proc:24 _:8 nlocals:24
545 * Call a procedure. PROC is the local corresponding to a procedure.
546 * The two values below PROC will be overwritten by the saved call
547 * frame data. The new frame will have space for NLOCALS locals: one
548 * for the procedure, and the rest for the arguments which should
549 * already have been pushed on.
551 * When the call returns, execution proceeds with the next
552 * instruction. There may be any number of values on the return
553 * stack; the precise number can be had by subtracting the address of
554 * PROC from the post-call SP.
556 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
558 scm_t_uint32 proc
, nlocals
;
561 UNPACK_24 (op
, proc
);
562 UNPACK_24 (ip
[1], nlocals
);
564 VM_HANDLE_INTERRUPTS
;
567 fp
= vp
->fp
= old_fp
+ proc
;
568 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
569 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 2);
571 RESET_FRAME (nlocals
);
573 PUSH_CONTINUATION_HOOK ();
576 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
579 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
583 /* call-label proc:24 _:8 nlocals:24 label:32
585 * Call a procedure in the same compilation unit.
587 * This instruction is just like "call", except that instead of
588 * dereferencing PROC to find the call target, the call target is
589 * known to be at LABEL, a signed 32-bit offset in 32-bit units from
590 * the current IP. Since PROC is not dereferenced, it may be some
591 * other representation of the closure.
593 VM_DEFINE_OP (2, call_label
, "call-label", OP3 (U8_U24
, X8_U24
, L32
))
595 scm_t_uint32 proc
, nlocals
;
599 UNPACK_24 (op
, proc
);
600 UNPACK_24 (ip
[1], nlocals
);
603 VM_HANDLE_INTERRUPTS
;
606 fp
= vp
->fp
= old_fp
+ proc
;
607 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
608 SCM_FRAME_SET_RETURN_ADDRESS (fp
, ip
+ 3);
610 RESET_FRAME (nlocals
);
612 PUSH_CONTINUATION_HOOK ();
618 /* tail-call nlocals:24
620 * Tail-call a procedure. Requires that the procedure and all of the
621 * arguments have already been shuffled into position. Will reset the
624 VM_DEFINE_OP (3, tail_call
, "tail-call", OP1 (U8_U24
))
626 scm_t_uint32 nlocals
;
628 UNPACK_24 (op
, nlocals
);
630 VM_HANDLE_INTERRUPTS
;
632 RESET_FRAME (nlocals
);
636 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
639 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
643 /* tail-call-label nlocals:24 label:32
645 * Tail-call a known procedure. As call is to call-label, tail-call
646 * is to tail-call-label.
648 VM_DEFINE_OP (4, tail_call_label
, "tail-call-label", OP2 (U8_U24
, L32
))
650 scm_t_uint32 nlocals
;
653 UNPACK_24 (op
, nlocals
);
656 VM_HANDLE_INTERRUPTS
;
658 RESET_FRAME (nlocals
);
665 /* tail-call/shuffle from:24
667 * Tail-call a procedure. The procedure should already be set to slot
668 * 0. The rest of the args are taken from the frame, starting at
669 * FROM, shuffled down to start at slot 0. This is part of the
670 * implementation of the call-with-values builtin.
672 VM_DEFINE_OP (5, tail_call_shuffle
, "tail-call/shuffle", OP1 (U8_U24
))
674 scm_t_uint32 n
, from
, nlocals
;
676 UNPACK_24 (op
, from
);
678 VM_HANDLE_INTERRUPTS
;
680 VM_ASSERT (from
> 0, abort ());
681 nlocals
= FRAME_LOCALS_COUNT ();
683 for (n
= 0; from
+ n
< nlocals
; n
++)
684 LOCAL_SET (n
+ 1, LOCAL_REF (from
+ n
));
690 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
693 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
697 /* receive dst:12 proc:12 _:8 nlocals:24
699 * Receive a single return value from a call whose procedure was in
700 * PROC, asserting that the call actually returned at least one
701 * value. Afterwards, resets the frame to NLOCALS locals.
703 VM_DEFINE_OP (6, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
705 scm_t_uint16 dst
, proc
;
706 scm_t_uint32 nlocals
;
707 UNPACK_12_12 (op
, dst
, proc
);
708 UNPACK_24 (ip
[1], nlocals
);
709 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
710 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
711 RESET_FRAME (nlocals
);
715 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
717 * Receive a return of multiple values from a call whose procedure was
718 * in PROC. If fewer than NVALUES values were returned, signal an
719 * error. Unless ALLOW-EXTRA? is true, require that the number of
720 * return values equals NVALUES exactly. After receive-values has
721 * run, the values can be copied down via `mov'.
723 VM_DEFINE_OP (7, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
725 scm_t_uint32 proc
, nvalues
;
726 UNPACK_24 (op
, proc
);
727 UNPACK_24 (ip
[1], nvalues
);
729 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
730 vm_error_not_enough_values ());
732 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ 1 + nvalues
,
733 vm_error_wrong_number_of_values (nvalues
));
741 VM_DEFINE_OP (8, return, "return", OP1 (U8_U24
))
745 RETURN_ONE_VALUE (LOCAL_REF (src
));
748 /* return-values _:24
750 * Return a number of values from a call frame. This opcode
751 * corresponds to an application of `values' in tail position. As
752 * with tail calls, we expect that the values have already been
753 * shuffled down to a contiguous array starting at slot 1.
754 * We also expect the frame has already been reset.
756 VM_DEFINE_OP (9, return_values
, "return-values", OP1 (U8_X24
))
760 VM_HANDLE_INTERRUPTS
;
763 ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
764 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
766 /* Clear stack frame. */
767 old_fp
[-1] = SCM_BOOL_F
;
768 old_fp
[-2] = SCM_BOOL_F
;
770 POP_CONTINUATION_HOOK (old_fp
);
779 * Specialized call stubs
782 /* subr-call ptr-idx:24
784 * Call a subr, passing all locals in this frame as arguments. Fetch
785 * the foreign pointer from PTR-IDX, a free variable. Return from the
786 * calling frame. This instruction is part of the trampolines
787 * created in gsubr.c, and is not generated by the compiler.
789 VM_DEFINE_OP (10, subr_call
, "subr-call", OP1 (U8_U24
))
791 scm_t_uint32 ptr_idx
;
795 UNPACK_24 (op
, ptr_idx
);
797 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
798 subr
= SCM_POINTER_VALUE (pointer
);
802 switch (FRAME_LOCALS_COUNT_FROM (1))
811 ret
= subr (fp
[1], fp
[2]);
814 ret
= subr (fp
[1], fp
[2], fp
[3]);
817 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4]);
820 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
823 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
826 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
829 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
832 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
835 ret
= subr (fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9], fp
[10]);
843 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
844 /* multiple values returned to continuation */
845 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
847 RETURN_ONE_VALUE (ret
);
850 /* foreign-call cif-idx:12 ptr-idx:12
852 * Call a foreign function. Fetch the CIF and foreign pointer from
853 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
854 * frame. Arguments are taken from the stack. This instruction is
855 * part of the trampolines created by the FFI, and is not generated by
858 VM_DEFINE_OP (11, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
860 scm_t_uint16 cif_idx
, ptr_idx
;
861 SCM closure
, cif
, pointer
, ret
;
863 UNPACK_12_12 (op
, cif_idx
, ptr_idx
);
865 closure
= LOCAL_REF (0);
866 cif
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
867 pointer
= SCM_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
871 // FIXME: separate args
872 ret
= scm_i_foreign_call (scm_inline_cons (thread
, cif
, pointer
),
877 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
878 /* multiple values returned to continuation */
879 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
881 RETURN_ONE_VALUE (ret
);
884 /* continuation-call contregs:24
886 * Return to a continuation, nonlocally. The arguments to the
887 * continuation are taken from the stack. CONTREGS is a free variable
888 * containing the reified continuation. This instruction is part of
889 * the implementation of undelimited continuations, and is not
890 * generated by the compiler.
892 VM_DEFINE_OP (12, continuation_call
, "continuation-call", OP1 (U8_U24
))
895 scm_t_uint32 contregs_idx
;
897 UNPACK_24 (op
, contregs_idx
);
900 SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
903 scm_i_check_continuation (contregs
);
904 vm_return_to_continuation (scm_i_contregs_vp (contregs
),
905 scm_i_contregs_vm_cont (contregs
),
906 FRAME_LOCALS_COUNT_FROM (1),
908 scm_i_reinstate_continuation (contregs
);
914 /* compose-continuation cont:24
916 * Compose a partial continution with the current continuation. The
917 * arguments to the continuation are taken from the stack. CONT is a
918 * free variable containing the reified continuation. This
919 * instruction is part of the implementation of partial continuations,
920 * and is not generated by the compiler.
922 VM_DEFINE_OP (13, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
925 scm_t_uint32 cont_idx
;
927 UNPACK_24 (op
, cont_idx
);
928 vmcont
= SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx
);
931 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
932 vm_error_continuation_not_rewindable (vmcont
));
933 vm_reinstate_partial_continuation (vp
, vmcont
, FRAME_LOCALS_COUNT_FROM (1),
943 * Tail-apply the procedure in local slot 0 to the rest of the
944 * arguments. This instruction is part of the implementation of
945 * `apply', and is not generated by the compiler.
947 VM_DEFINE_OP (14, tail_apply
, "tail-apply", OP1 (U8_X24
))
949 int i
, list_idx
, list_len
, nlocals
;
952 VM_HANDLE_INTERRUPTS
;
954 nlocals
= FRAME_LOCALS_COUNT ();
955 // At a minimum, there should be apply, f, and the list.
956 VM_ASSERT (nlocals
>= 3, abort ());
957 list_idx
= nlocals
- 1;
958 list
= LOCAL_REF (list_idx
);
959 list_len
= scm_ilength (list
);
961 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
963 nlocals
= nlocals
- 2 + list_len
;
964 ALLOC_FRAME (nlocals
);
966 for (i
= 1; i
< list_idx
; i
++)
967 LOCAL_SET (i
- 1, LOCAL_REF (i
));
969 /* Null out these slots, just in case there are less than 2 elements
971 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
972 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
974 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
975 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
979 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
982 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
988 * Capture the current continuation, and tail-apply the procedure in
989 * local slot 1 to it. This instruction is part of the implementation
990 * of `call/cc', and is not generated by the compiler.
992 VM_DEFINE_OP (15, call_cc
, "call/cc", OP1 (U8_X24
))
995 scm_t_dynstack
*dynstack
;
998 VM_HANDLE_INTERRUPTS
;
1001 dynstack
= scm_dynstack_capture_all (&thread
->dynstack
);
1002 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1003 SCM_FRAME_DYNAMIC_LINK (fp
),
1004 SCM_FRAME_PREVIOUS_SP (fp
),
1005 SCM_FRAME_RETURN_ADDRESS (fp
),
1008 /* FIXME: Seems silly to capture the registers here, when they are
1009 already captured in the registers local, which here we are
1010 copying out to the heap; and likewise, the setjmp(®isters)
1011 code already has the non-local return handler. But oh
1013 cont
= scm_i_make_continuation (&first
, vp
, vm_cont
);
1017 LOCAL_SET (0, LOCAL_REF (1));
1018 LOCAL_SET (1, cont
);
1023 if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1026 ip
= SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1032 ABORT_CONTINUATION_HOOK ();
1039 * Abort to a prompt handler. The tag is expected in r1, and the rest
1040 * of the values in the frame are returned to the prompt handler.
1041 * This corresponds to a tail application of abort-to-prompt.
1043 VM_DEFINE_OP (16, abort
, "abort", OP1 (U8_X24
))
1045 scm_t_uint32 nlocals
= FRAME_LOCALS_COUNT ();
1047 ASSERT (nlocals
>= 2);
1048 /* FIXME: Really we should capture the caller's registers. Until
1049 then, manually advance the IP so that when the prompt resumes,
1050 it continues with the next instruction. */
1053 vm_abort (vp
, LOCAL_REF (1), nlocals
- 2, LOCAL_ADDRESS (2),
1054 SCM_EOL
, LOCAL_ADDRESS (0), registers
);
1056 /* vm_abort should not return */
1060 /* builtin-ref dst:12 idx:12
1062 * Load a builtin stub by index into DST.
1064 VM_DEFINE_OP (17, builtin_ref
, "builtin-ref", OP1 (U8_U12_U12
) | OP_DST
)
1066 scm_t_uint16 dst
, idx
;
1068 UNPACK_12_12 (op
, dst
, idx
);
1069 LOCAL_SET (dst
, scm_vm_builtin_ref (idx
));
1078 * Function prologues
1081 /* br-if-nargs-ne expected:24 _:8 offset:24
1082 * br-if-nargs-lt expected:24 _:8 offset:24
1083 * br-if-nargs-gt expected:24 _:8 offset:24
1085 * If the number of actual arguments is not equal, less than, or greater
1086 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1087 * the current instruction pointer.
1089 VM_DEFINE_OP (18, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1093 VM_DEFINE_OP (19, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1097 VM_DEFINE_OP (20, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1102 /* assert-nargs-ee expected:24
1103 * assert-nargs-ge expected:24
1104 * assert-nargs-le expected:24
1106 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1107 * respectively, signal an error.
1109 VM_DEFINE_OP (21, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1111 scm_t_uint32 expected
;
1112 UNPACK_24 (op
, expected
);
1113 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1114 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1117 VM_DEFINE_OP (22, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1119 scm_t_uint32 expected
;
1120 UNPACK_24 (op
, expected
);
1121 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1122 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1125 VM_DEFINE_OP (23, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1127 scm_t_uint32 expected
;
1128 UNPACK_24 (op
, expected
);
1129 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1130 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1134 /* alloc-frame nlocals:24
1136 * Ensure that there is space on the stack for NLOCALS local variables,
1137 * setting them all to SCM_UNDEFINED, except those nargs values that
1138 * were passed as arguments and procedure.
1140 VM_DEFINE_OP (24, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1142 scm_t_uint32 nlocals
, nargs
;
1143 UNPACK_24 (op
, nlocals
);
1145 nargs
= FRAME_LOCALS_COUNT ();
1146 ALLOC_FRAME (nlocals
);
1147 while (nlocals
-- > nargs
)
1148 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1153 /* reset-frame nlocals:24
1155 * Like alloc-frame, but doesn't check that the stack is big enough.
1156 * Used to reset the frame size to something less than the size that
1157 * was previously set via alloc-frame.
1159 VM_DEFINE_OP (25, reset_frame
, "reset-frame", OP1 (U8_U24
))
1161 scm_t_uint32 nlocals
;
1162 UNPACK_24 (op
, nlocals
);
1163 RESET_FRAME (nlocals
);
1167 /* assert-nargs-ee/locals expected:12 nlocals:12
1169 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1170 * number of locals reserved is EXPECTED + NLOCALS.
1172 VM_DEFINE_OP (26, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1174 scm_t_uint16 expected
, nlocals
;
1175 UNPACK_12_12 (op
, expected
, nlocals
);
1176 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1177 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1178 ALLOC_FRAME (expected
+ nlocals
);
1180 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1185 /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
1187 * Find the first positional argument after NREQ. If it is greater
1188 * than NPOS, jump to OFFSET.
1190 * This instruction is only emitted for functions with multiple
1191 * clauses, and an earlier clause has keywords and no rest arguments.
1192 * See "Case-lambda" in the manual, for more on how case-lambda
1193 * chooses the clause to apply.
1195 VM_DEFINE_OP (27, br_if_npos_gt
, "br-if-npos-gt", OP3 (U8_U24
, X8_U24
, X8_L24
))
1197 scm_t_uint32 nreq
, npos
;
1199 UNPACK_24 (op
, nreq
);
1200 UNPACK_24 (ip
[1], npos
);
1202 /* We can only have too many positionals if there are more
1203 arguments than NPOS. */
1204 if (FRAME_LOCALS_COUNT() > npos
)
1207 for (n
= nreq
; n
< npos
; n
++)
1208 if (scm_is_keyword (LOCAL_REF (n
)))
1210 if (n
== npos
&& !scm_is_keyword (LOCAL_REF (n
)))
1212 scm_t_int32 offset
= ip
[2];
1213 offset
>>= 8; /* Sign-extending shift. */
1220 /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
1222 * flags := allow-other-keys:1 has-rest:1 _:6
1224 * Find the last positional argument, and shuffle all the rest above
1225 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1226 * load the constant at KW-OFFSET words from the current IP, and use it
1227 * to bind keyword arguments. If HAS-REST, collect all shuffled
1228 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1229 * the arguments that we shuffled up.
1231 * A macro-mega-instruction.
1233 VM_DEFINE_OP (28, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1235 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1236 scm_t_int32 kw_offset
;
1239 char allow_other_keys
, has_rest
;
1241 UNPACK_24 (op
, nreq
);
1242 allow_other_keys
= ip
[1] & 0x1;
1243 has_rest
= ip
[1] & 0x2;
1244 UNPACK_24 (ip
[1], nreq_and_opt
);
1245 UNPACK_24 (ip
[2], ntotal
);
1247 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1248 VM_ASSERT (!(kw_bits
& 0x7), abort());
1249 kw
= SCM_PACK (kw_bits
);
1251 nargs
= FRAME_LOCALS_COUNT ();
1253 /* look in optionals for first keyword or last positional */
1254 /* starting after the last required positional arg */
1256 while (/* while we have args */
1258 /* and we still have positionals to fill */
1259 && npositional
< nreq_and_opt
1260 /* and we haven't reached a keyword yet */
1261 && !scm_is_keyword (LOCAL_REF (npositional
)))
1262 /* bind this optional arg (by leaving it in place) */
1264 nkw
= nargs
- npositional
;
1265 /* shuffle non-positional arguments above ntotal */
1266 ALLOC_FRAME (ntotal
+ nkw
);
1269 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1270 /* and fill optionals & keyword args with SCM_UNDEFINED */
1273 LOCAL_SET (n
++, SCM_UNDEFINED
);
1275 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1276 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1278 /* Now bind keywords, in the order given. */
1279 for (n
= 0; n
< nkw
; n
++)
1280 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1283 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1284 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1286 SCM si
= SCM_CDAR (walk
);
1287 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1288 LOCAL_REF (ntotal
+ n
+ 1));
1291 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1292 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1293 LOCAL_REF (ntotal
+ n
)));
1297 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1298 LOCAL_REF (ntotal
+ n
)));
1305 rest
= scm_inline_cons (thread
, LOCAL_REF (ntotal
+ n
), rest
);
1306 LOCAL_SET (nreq_and_opt
, rest
);
1309 RESET_FRAME (ntotal
);
1316 * Collect any arguments at or above DST into a list, and store that
1319 VM_DEFINE_OP (29, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1321 scm_t_uint32 dst
, nargs
;
1324 UNPACK_24 (op
, dst
);
1325 nargs
= FRAME_LOCALS_COUNT ();
1329 ALLOC_FRAME (dst
+ 1);
1331 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1335 while (nargs
-- > dst
)
1337 rest
= scm_inline_cons (thread
, LOCAL_REF (nargs
), rest
);
1338 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1341 RESET_FRAME (dst
+ 1);
1344 LOCAL_SET (dst
, rest
);
1353 * Branching instructions
1358 * Add OFFSET, a signed 24-bit number, to the current instruction
1361 VM_DEFINE_OP (30, br
, "br", OP1 (U8_L24
))
1363 scm_t_int32 offset
= op
;
1364 offset
>>= 8; /* Sign-extending shift. */
1368 /* br-if-true test:24 invert:1 _:7 offset:24
1370 * If the value in TEST is true for the purposes of Scheme, add
1371 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1373 VM_DEFINE_OP (31, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1375 BR_UNARY (x
, scm_is_true (x
));
1378 /* br-if-null test:24 invert:1 _:7 offset:24
1380 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1381 * signed 24-bit number, to the current instruction pointer.
1383 VM_DEFINE_OP (32, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1385 BR_UNARY (x
, scm_is_null (x
));
1388 /* br-if-nil test:24 invert:1 _:7 offset:24
1390 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1391 * number, to the current instruction pointer.
1393 VM_DEFINE_OP (33, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1395 BR_UNARY (x
, scm_is_lisp_false (x
));
1398 /* br-if-pair test:24 invert:1 _:7 offset:24
1400 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1401 * to the current instruction pointer.
1403 VM_DEFINE_OP (34, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1405 BR_UNARY (x
, scm_is_pair (x
));
1408 /* br-if-struct test:24 invert:1 _:7 offset:24
1410 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1411 * number, to the current instruction pointer.
1413 VM_DEFINE_OP (35, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1415 BR_UNARY (x
, SCM_STRUCTP (x
));
1418 /* br-if-char test:24 invert:1 _:7 offset:24
1420 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1421 * to the current instruction pointer.
1423 VM_DEFINE_OP (36, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1425 BR_UNARY (x
, SCM_CHARP (x
));
1428 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1430 * If the value in TEST has the TC7 given in the second word, add
1431 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1433 VM_DEFINE_OP (37, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1435 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1438 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1440 * If the value in A is eq? to the value in B, add OFFSET, a signed
1441 * 24-bit number, to the current instruction pointer.
1443 VM_DEFINE_OP (38, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1445 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1448 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1450 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1451 * 24-bit number, to the current instruction pointer.
1453 VM_DEFINE_OP (39, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1457 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1458 && scm_is_true (scm_eqv_p (x
, y
))));
1461 // FIXME: remove, have compiler inline eqv test instead
1462 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1464 * If the value in A is equal? to the value in B, add OFFSET, a signed
1465 * 24-bit number, to the current instruction pointer.
1467 // FIXME: Should sync_ip before calling out and cache_fp before coming
1468 // back! Another reason to remove this opcode!
1469 VM_DEFINE_OP (40, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1473 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1474 && scm_is_true (scm_equal_p (x
, y
))));
1477 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1479 * If the value in A is = to the value in B, add OFFSET, a signed
1480 * 24-bit number, to the current instruction pointer.
1482 VM_DEFINE_OP (41, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1484 BR_ARITHMETIC (==, scm_num_eq_p
);
1487 /* br-if-< a:12 b:12 invert:1 _:7 offset:24
1489 * If the value in A is < to the value in B, add OFFSET, a signed
1490 * 24-bit number, to the current instruction pointer.
1492 VM_DEFINE_OP (42, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1494 BR_ARITHMETIC (<, scm_less_p
);
1497 /* br-if-<= a:12 b:12 invert:1 _:7 offset:24
1499 * If the value in A is <= to the value in B, add OFFSET, a signed
1500 * 24-bit number, to the current instruction pointer.
1502 VM_DEFINE_OP (43, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1504 BR_ARITHMETIC (<=, scm_leq_p
);
1511 * Lexical binding instructions
1514 /* mov dst:12 src:12
1516 * Copy a value from one local slot to another.
1518 VM_DEFINE_OP (44, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1523 UNPACK_12_12 (op
, dst
, src
);
1524 LOCAL_SET (dst
, LOCAL_REF (src
));
1529 /* long-mov dst:24 _:8 src:24
1531 * Copy a value from one local slot to another.
1533 VM_DEFINE_OP (45, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1538 UNPACK_24 (op
, dst
);
1539 UNPACK_24 (ip
[1], src
);
1540 LOCAL_SET (dst
, LOCAL_REF (src
));
1545 /* box dst:12 src:12
1547 * Create a new variable holding SRC, and place it in DST.
1549 VM_DEFINE_OP (46, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1551 scm_t_uint16 dst
, src
;
1552 UNPACK_12_12 (op
, dst
, src
);
1553 LOCAL_SET (dst
, scm_inline_cell (thread
, scm_tc7_variable
,
1554 SCM_UNPACK (LOCAL_REF (src
))));
1558 /* box-ref dst:12 src:12
1560 * Unpack the variable at SRC into DST, asserting that the variable is
1563 VM_DEFINE_OP (47, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1565 scm_t_uint16 dst
, src
;
1567 UNPACK_12_12 (op
, dst
, src
);
1568 var
= LOCAL_REF (src
);
1569 VM_ASSERT (SCM_VARIABLEP (var
),
1570 vm_error_not_a_variable ("variable-ref", var
));
1571 VM_ASSERT (VARIABLE_BOUNDP (var
),
1572 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1573 LOCAL_SET (dst
, VARIABLE_REF (var
));
1577 /* box-set! dst:12 src:12
1579 * Set the contents of the variable at DST to SET.
1581 VM_DEFINE_OP (48, box_set
, "box-set!", OP1 (U8_U12_U12
))
1583 scm_t_uint16 dst
, src
;
1585 UNPACK_12_12 (op
, dst
, src
);
1586 var
= LOCAL_REF (dst
);
1587 VM_ASSERT (SCM_VARIABLEP (var
),
1588 vm_error_not_a_variable ("variable-set!", var
));
1589 VARIABLE_SET (var
, LOCAL_REF (src
));
1593 /* make-closure dst:24 offset:32 _:8 nfree:24
1595 * Make a new closure, and write it to DST. The code for the closure
1596 * will be found at OFFSET words from the current IP. OFFSET is a
1597 * signed 32-bit integer. Space for NFREE free variables will be
1600 VM_DEFINE_OP (49, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1602 scm_t_uint32 dst
, nfree
, n
;
1606 UNPACK_24 (op
, dst
);
1608 UNPACK_24 (ip
[2], nfree
);
1610 // FIXME: Assert range of nfree?
1611 closure
= scm_inline_words (thread
, scm_tc7_program
| (nfree
<< 16),
1613 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1614 // FIXME: Elide these initializations?
1615 for (n
= 0; n
< nfree
; n
++)
1616 SCM_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1617 LOCAL_SET (dst
, closure
);
1621 /* free-ref dst:12 src:12 _:8 idx:24
1623 * Load free variable IDX from the closure SRC into local slot DST.
1625 VM_DEFINE_OP (50, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1627 scm_t_uint16 dst
, src
;
1629 UNPACK_12_12 (op
, dst
, src
);
1630 UNPACK_24 (ip
[1], idx
);
1631 /* CHECK_FREE_VARIABLE (src); */
1632 LOCAL_SET (dst
, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1636 /* free-set! dst:12 src:12 _:8 idx:24
1638 * Set free variable IDX from the closure DST to SRC.
1640 VM_DEFINE_OP (51, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1642 scm_t_uint16 dst
, src
;
1644 UNPACK_12_12 (op
, dst
, src
);
1645 UNPACK_24 (ip
[1], idx
);
1646 /* CHECK_FREE_VARIABLE (src); */
1647 SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1655 * Immediates and statically allocated non-immediates
1658 /* make-short-immediate dst:8 low-bits:16
1660 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1663 VM_DEFINE_OP (52, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1668 UNPACK_8_16 (op
, dst
, val
);
1669 LOCAL_SET (dst
, SCM_PACK (val
));
1673 /* make-long-immediate dst:24 low-bits:32
1675 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1678 VM_DEFINE_OP (53, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1683 UNPACK_24 (op
, dst
);
1685 LOCAL_SET (dst
, SCM_PACK (val
));
1689 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1691 * Make an immediate with HIGH-BITS and LOW-BITS.
1693 VM_DEFINE_OP (54, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1698 UNPACK_24 (op
, dst
);
1699 #if SIZEOF_SCM_T_BITS > 4
1704 ASSERT (ip
[1] == 0);
1707 LOCAL_SET (dst
, SCM_PACK (val
));
1711 /* make-non-immediate dst:24 offset:32
1713 * Load a pointer to statically allocated memory into DST. The
1714 * object's memory is will be found OFFSET 32-bit words away from the
1715 * current instruction pointer. OFFSET is a signed value. The
1716 * intention here is that the compiler would produce an object file
1717 * containing the words of a non-immediate object, and this
1718 * instruction creates a pointer to that memory, effectively
1719 * resurrecting that object.
1721 * Whether the object is mutable or immutable depends on where it was
1722 * allocated by the compiler, and loaded by the loader.
1724 VM_DEFINE_OP (55, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1729 scm_t_bits unpacked
;
1731 UNPACK_24 (op
, dst
);
1734 unpacked
= (scm_t_bits
) loc
;
1736 VM_ASSERT (!(unpacked
& 0x7), abort());
1738 LOCAL_SET (dst
, SCM_PACK (unpacked
));
1743 /* static-ref dst:24 offset:32
1745 * Load a SCM value into DST. The SCM value will be fetched from
1746 * memory, OFFSET 32-bit words away from the current instruction
1747 * pointer. OFFSET is a signed value.
1749 * The intention is for this instruction to be used to load constants
1750 * that the compiler is unable to statically allocate, like symbols.
1751 * These values would be initialized when the object file loads.
1753 VM_DEFINE_OP (56, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
1758 scm_t_uintptr loc_bits
;
1760 UNPACK_24 (op
, dst
);
1763 loc_bits
= (scm_t_uintptr
) loc
;
1764 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1766 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
1771 /* static-set! src:24 offset:32
1773 * Store a SCM value into memory, OFFSET 32-bit words away from the
1774 * current instruction pointer. OFFSET is a signed value.
1776 VM_DEFINE_OP (57, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
1782 UNPACK_24 (op
, src
);
1785 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
1787 *((SCM
*) loc
) = LOCAL_REF (src
);
1792 /* static-patch! _:24 dst-offset:32 src-offset:32
1794 * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
1795 * are signed 32-bit values, indicating a memory address as a number
1796 * of 32-bit words away from the current instruction pointer.
1798 VM_DEFINE_OP (58, static_patch
, "static-patch!", OP3 (U8_X24
, LO32
, L32
))
1800 scm_t_int32 dst_offset
, src_offset
;
1807 dst_loc
= (void **) (ip
+ dst_offset
);
1808 src
= ip
+ src_offset
;
1809 VM_ASSERT (ALIGNED_P (dst_loc
, void*), abort());
1819 * Mutable top-level bindings
1822 /* There are three slightly different ways to resolve toplevel
1825 1. A toplevel reference outside of a function. These need to be
1826 looked up when the expression is evaluated -- no later, and no
1827 before. They are looked up relative to the module that is
1828 current when the expression is evaluated. For example:
1832 The "resolve" instruction resolves the variable (box), and then
1833 access is via box-ref or box-set!.
1835 2. A toplevel reference inside a function. These are looked up
1836 relative to the module that was current when the function was
1837 defined. Unlike code at the toplevel, which is usually run only
1838 once, these bindings benefit from memoized lookup, in which the
1839 variable resulting from the lookup is cached in the function.
1841 (lambda () (if (foo) a b))
1843 The toplevel-box instruction is equivalent to "resolve", but
1844 caches the resulting variable in statically allocated memory.
1846 3. A reference to an identifier with respect to a particular
1847 module. This can happen for primitive references, and
1848 references residualized by macro expansions. These can always
1849 be cached. Use module-box for these.
1852 /* current-module dst:24
1854 * Store the current module in DST.
1856 VM_DEFINE_OP (59, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
1860 UNPACK_24 (op
, dst
);
1863 LOCAL_SET (dst
, scm_current_module ());
1868 /* resolve dst:24 bound?:1 _:7 sym:24
1870 * Resolve SYM in the current module, and place the resulting variable
1873 VM_DEFINE_OP (60, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
1879 UNPACK_24 (op
, dst
);
1880 UNPACK_24 (ip
[1], sym
);
1883 var
= scm_lookup (LOCAL_REF (sym
));
1886 VM_ASSERT (VARIABLE_BOUNDP (var
),
1887 vm_error_unbound (fp
[0], LOCAL_REF (sym
)));
1888 LOCAL_SET (dst
, var
);
1893 /* define! sym:12 val:12
1895 * Look up a binding for SYM in the current module, creating it if
1896 * necessary. Set its value to VAL.
1898 VM_DEFINE_OP (61, define
, "define!", OP1 (U8_U12_U12
))
1900 scm_t_uint16 sym
, val
;
1901 UNPACK_12_12 (op
, sym
, val
);
1903 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
1908 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1910 * Load a SCM value. The SCM value will be fetched from memory,
1911 * VAR-OFFSET 32-bit words away from the current instruction pointer.
1912 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
1915 * Then, if the loaded value is a variable, it is placed in DST, and control
1918 * Otherwise, we have to resolve the variable. In that case we load
1919 * the module from MOD-OFFSET, just as we loaded the variable.
1920 * Usually the module gets set when the closure is created. The name
1921 * is an offset to a symbol.
1923 * We use the module and the symbol to resolve the variable, placing it in
1924 * DST, and caching the resolved variable so that we will hit the cache next
1927 VM_DEFINE_OP (62, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
1930 scm_t_int32 var_offset
;
1931 scm_t_uint32
* var_loc_u32
;
1935 UNPACK_24 (op
, dst
);
1937 var_loc_u32
= ip
+ var_offset
;
1938 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1939 var_loc
= (SCM
*) var_loc_u32
;
1942 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1945 scm_t_int32 mod_offset
= ip
[2]; /* signed */
1946 scm_t_int32 sym_offset
= ip
[3]; /* signed */
1947 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
1948 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
1952 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
1953 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
1955 mod
= *((SCM
*) mod_loc
);
1956 sym
= *((SCM
*) sym_loc
);
1958 /* If the toplevel scope was captured before modules were
1959 booted, use the root module. */
1960 if (scm_is_false (mod
))
1961 mod
= scm_the_root_module ();
1963 var
= scm_module_lookup (mod
, sym
);
1966 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
1971 LOCAL_SET (dst
, var
);
1975 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
1977 * Like toplevel-box, except MOD-OFFSET points at the name of a module
1978 * instead of the module itself.
1980 VM_DEFINE_OP (63, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
1983 scm_t_int32 var_offset
;
1984 scm_t_uint32
* var_loc_u32
;
1988 UNPACK_24 (op
, dst
);
1990 var_loc_u32
= ip
+ var_offset
;
1991 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
1992 var_loc
= (SCM
*) var_loc_u32
;
1995 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
1998 scm_t_int32 modname_offset
= ip
[2]; /* signed */
1999 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2000 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2001 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2005 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2006 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2008 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2009 sym
= *((SCM
*) sym_loc
);
2011 if (!scm_module_system_booted_p
)
2013 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
2016 scm_equal_p (modname
,
2017 scm_list_2 (SCM_BOOL_T
,
2018 scm_from_utf8_symbol ("guile"))));
2020 var
= scm_lookup (sym
);
2022 else if (scm_is_true (SCM_CAR (modname
)))
2023 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2025 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2030 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[0], sym
));
2035 LOCAL_SET (dst
, var
);
2042 * The dynamic environment
2045 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2047 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2048 * handler at HANDLER-OFFSET words from the current IP. The handler
2049 * will expect a multiple-value return as if from a call with the
2050 * procedure at PROC-SLOT.
2052 VM_DEFINE_OP (64, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2054 scm_t_uint32 tag
, proc_slot
;
2056 scm_t_uint8 escape_only_p
;
2057 scm_t_dynstack_prompt_flags flags
;
2059 UNPACK_24 (op
, tag
);
2060 escape_only_p
= ip
[1] & 0x1;
2061 UNPACK_24 (ip
[1], proc_slot
);
2063 offset
>>= 8; /* Sign extension */
2065 /* Push the prompt onto the dynamic stack. */
2066 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2067 scm_dynstack_push_prompt (&thread
->dynstack
, flags
,
2069 fp
- vp
->stack_base
,
2070 LOCAL_ADDRESS (proc_slot
) - vp
->stack_base
,
2076 /* wind winder:12 unwinder:12
2078 * Push wind and unwind procedures onto the dynamic stack. Note that
2079 * neither are actually called; the compiler should emit calls to wind
2080 * and unwind for the normal dynamic-wind control flow. Also note that
2081 * the compiler should have inserted checks that they wind and unwind
2082 * procs are thunks, if it could not prove that to be the case.
2084 VM_DEFINE_OP (65, wind
, "wind", OP1 (U8_U12_U12
))
2086 scm_t_uint16 winder
, unwinder
;
2087 UNPACK_12_12 (op
, winder
, unwinder
);
2088 scm_dynstack_push_dynwind (&thread
->dynstack
,
2089 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2095 * A normal exit from the dynamic extent of an expression. Pop the top
2096 * entry off of the dynamic stack.
2098 VM_DEFINE_OP (66, unwind
, "unwind", OP1 (U8_X24
))
2100 scm_dynstack_pop (&thread
->dynstack
);
2104 /* push-fluid fluid:12 value:12
2106 * Dynamically bind VALUE to FLUID.
2108 VM_DEFINE_OP (67, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2110 scm_t_uint32 fluid
, value
;
2112 UNPACK_12_12 (op
, fluid
, value
);
2114 scm_dynstack_push_fluid (&thread
->dynstack
,
2115 LOCAL_REF (fluid
), LOCAL_REF (value
),
2116 thread
->dynamic_state
);
2122 * Leave the dynamic extent of a with-fluid* expression, restoring the
2123 * fluid to its previous value.
2125 VM_DEFINE_OP (68, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2127 /* This function must not allocate. */
2128 scm_dynstack_unwind_fluid (&thread
->dynstack
,
2129 thread
->dynamic_state
);
2133 /* fluid-ref dst:12 src:12
2135 * Reference the fluid in SRC, and place the value in DST.
2137 VM_DEFINE_OP (69, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2139 scm_t_uint16 dst
, src
;
2143 UNPACK_12_12 (op
, dst
, src
);
2144 fluid
= LOCAL_REF (src
);
2145 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2146 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2147 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2149 /* Punt dynstate expansion and error handling to the C proc. */
2151 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2155 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2156 if (scm_is_eq (val
, SCM_UNDEFINED
))
2157 val
= SCM_I_FLUID_DEFAULT (fluid
);
2158 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2159 vm_error_unbound_fluid (SCM_FRAME_PROGRAM (fp
), fluid
));
2160 LOCAL_SET (dst
, val
);
2166 /* fluid-set fluid:12 val:12
2168 * Set the value of the fluid in DST to the value in SRC.
2170 VM_DEFINE_OP (70, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2176 UNPACK_12_12 (op
, a
, b
);
2177 fluid
= LOCAL_REF (a
);
2178 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (thread
->dynamic_state
);
2179 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2180 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2182 /* Punt dynstate expansion and error handling to the C proc. */
2184 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2187 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2196 * Strings, symbols, and keywords
2199 /* string-length dst:12 src:12
2201 * Store the length of the string in SRC in DST.
2203 VM_DEFINE_OP (71, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2206 if (SCM_LIKELY (scm_is_string (str
)))
2207 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2211 RETURN (scm_string_length (str
));
2215 /* string-ref dst:8 src:8 idx:8
2217 * Fetch the character at position IDX in the string in SRC, and store
2220 VM_DEFINE_OP (72, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2222 scm_t_signed_bits i
= 0;
2224 if (SCM_LIKELY (scm_is_string (str
)
2225 && SCM_I_INUMP (idx
)
2226 && ((i
= SCM_I_INUM (idx
)) >= 0)
2227 && i
< scm_i_string_length (str
)))
2228 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2232 RETURN (scm_string_ref (str
, idx
));
2236 /* No string-set! instruction, as there is no good fast path there. */
2238 /* string->number dst:12 src:12
2240 * Parse a string in SRC to a number, and store in DST.
2242 VM_DEFINE_OP (73, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2244 scm_t_uint16 dst
, src
;
2246 UNPACK_12_12 (op
, dst
, src
);
2249 scm_string_to_number (LOCAL_REF (src
),
2250 SCM_UNDEFINED
/* radix = 10 */));
2254 /* string->symbol dst:12 src:12
2256 * Parse a string in SRC to a symbol, and store in DST.
2258 VM_DEFINE_OP (74, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2260 scm_t_uint16 dst
, src
;
2262 UNPACK_12_12 (op
, dst
, src
);
2264 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2268 /* symbol->keyword dst:12 src:12
2270 * Make a keyword from the symbol in SRC, and store it in DST.
2272 VM_DEFINE_OP (75, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2274 scm_t_uint16 dst
, src
;
2275 UNPACK_12_12 (op
, dst
, src
);
2277 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2287 /* cons dst:8 car:8 cdr:8
2289 * Cons CAR and CDR, and store the result in DST.
2291 VM_DEFINE_OP (76, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2294 RETURN (scm_inline_cons (thread
, x
, y
));
2297 /* car dst:12 src:12
2299 * Place the car of SRC in DST.
2301 VM_DEFINE_OP (77, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2304 VM_VALIDATE_PAIR (x
, "car");
2305 RETURN (SCM_CAR (x
));
2308 /* cdr dst:12 src:12
2310 * Place the cdr of SRC in DST.
2312 VM_DEFINE_OP (78, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2315 VM_VALIDATE_PAIR (x
, "cdr");
2316 RETURN (SCM_CDR (x
));
2319 /* set-car! pair:12 car:12
2321 * Set the car of DST to SRC.
2323 VM_DEFINE_OP (79, set_car
, "set-car!", OP1 (U8_U12_U12
))
2327 UNPACK_12_12 (op
, a
, b
);
2330 VM_VALIDATE_PAIR (x
, "set-car!");
2335 /* set-cdr! pair:12 cdr:12
2337 * Set the cdr of DST to SRC.
2339 VM_DEFINE_OP (80, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2343 UNPACK_12_12 (op
, a
, b
);
2346 VM_VALIDATE_PAIR (x
, "set-car!");
2355 * Numeric operations
2358 /* add dst:8 a:8 b:8
2360 * Add A to B, and place the result in DST.
2362 VM_DEFINE_OP (81, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2364 BINARY_INTEGER_OP (+, scm_sum
);
2367 /* add1 dst:12 src:12
2369 * Add 1 to the value in SRC, and place the result in DST.
2371 VM_DEFINE_OP (82, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2375 /* Check for overflow. We must avoid overflow in the signed
2376 addition below, even if X is not an inum. */
2377 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2381 /* Add 1 to the integer without untagging. */
2382 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2384 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2388 RETURN_EXP (scm_sum (x
, SCM_I_MAKINUM (1)));
2391 /* sub dst:8 a:8 b:8
2393 * Subtract B from A, and place the result in DST.
2395 VM_DEFINE_OP (83, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2397 BINARY_INTEGER_OP (-, scm_difference
);
2400 /* sub1 dst:12 src:12
2402 * Subtract 1 from SRC, and place the result in DST.
2404 VM_DEFINE_OP (84, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2408 /* Check for overflow. We must avoid overflow in the signed
2409 subtraction below, even if X is not an inum. */
2410 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2414 /* Substract 1 from the integer without untagging. */
2415 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2417 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2421 RETURN_EXP (scm_difference (x
, SCM_I_MAKINUM (1)));
2424 /* mul dst:8 a:8 b:8
2426 * Multiply A and B, and place the result in DST.
2428 VM_DEFINE_OP (85, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2431 RETURN_EXP (scm_product (x
, y
));
2434 /* div dst:8 a:8 b:8
2436 * Divide A by B, and place the result in DST.
2438 VM_DEFINE_OP (86, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2441 RETURN_EXP (scm_divide (x
, y
));
2444 /* quo dst:8 a:8 b:8
2446 * Divide A by B, and place the quotient in DST.
2448 VM_DEFINE_OP (87, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2451 RETURN_EXP (scm_quotient (x
, y
));
2454 /* rem dst:8 a:8 b:8
2456 * Divide A by B, and place the remainder in DST.
2458 VM_DEFINE_OP (88, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2461 RETURN_EXP (scm_remainder (x
, y
));
2464 /* mod dst:8 a:8 b:8
2466 * Place the modulo of A by B in DST.
2468 VM_DEFINE_OP (89, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2471 RETURN_EXP (scm_modulo (x
, y
));
2474 /* ash dst:8 a:8 b:8
2476 * Shift A arithmetically by B bits, and place the result in DST.
2478 VM_DEFINE_OP (90, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2481 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2483 if (SCM_I_INUM (y
) < 0)
2484 /* Right shift, will be a fixnum. */
2485 RETURN (SCM_I_MAKINUM
2486 (SCM_SRS (SCM_I_INUM (x
),
2487 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2488 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2490 /* Left shift. See comments in scm_ash. */
2492 scm_t_signed_bits nn
, bits_to_shift
;
2494 nn
= SCM_I_INUM (x
);
2495 bits_to_shift
= SCM_I_INUM (y
);
2497 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2499 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2501 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2506 RETURN_EXP (scm_ash (x
, y
));
2509 /* logand dst:8 a:8 b:8
2511 * Place the bitwise AND of A and B into DST.
2513 VM_DEFINE_OP (91, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2516 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2517 /* Compute bitwise AND without untagging */
2518 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2519 RETURN_EXP (scm_logand (x
, y
));
2522 /* logior dst:8 a:8 b:8
2524 * Place the bitwise inclusive OR of A with B in DST.
2526 VM_DEFINE_OP (92, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2529 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2530 /* Compute bitwise OR without untagging */
2531 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2532 RETURN_EXP (scm_logior (x
, y
));
2535 /* logxor dst:8 a:8 b:8
2537 * Place the bitwise exclusive OR of A with B in DST.
2539 VM_DEFINE_OP (93, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2542 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2543 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2544 RETURN_EXP (scm_logxor (x
, y
));
2547 /* make-vector/immediate dst:8 length:8 init:8
2549 * Make a short vector of known size and write it to DST. The vector
2550 * will have space for LENGTH slots, an immediate value. They will be
2551 * filled with the value in slot INIT.
2553 VM_DEFINE_OP (94, make_vector_immediate
, "make-vector/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2555 scm_t_uint8 dst
, init
;
2556 scm_t_int32 length
, n
;
2559 UNPACK_8_8_8 (op
, dst
, length
, init
);
2561 val
= LOCAL_REF (init
);
2562 vector
= scm_inline_words (thread
, scm_tc7_vector
| (length
<< 8),
2564 for (n
= 0; n
< length
; n
++)
2565 SCM_SIMPLE_VECTOR_SET (vector
, n
, val
);
2566 LOCAL_SET (dst
, vector
);
2570 /* vector-length dst:12 src:12
2572 * Store the length of the vector in SRC in DST.
2574 VM_DEFINE_OP (95, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2577 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2578 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2582 RETURN (scm_vector_length (vect
));
2586 /* vector-ref dst:8 src:8 idx:8
2588 * Fetch the item at position IDX in the vector in SRC, and store it
2591 VM_DEFINE_OP (96, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2593 scm_t_signed_bits i
= 0;
2595 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2596 && SCM_I_INUMP (idx
)
2597 && ((i
= SCM_I_INUM (idx
)) >= 0)
2598 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2599 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2603 RETURN (scm_vector_ref (vect
, idx
));
2607 /* vector-ref/immediate dst:8 src:8 idx:8
2609 * Fill DST with the item IDX elements into the vector at SRC. Useful
2610 * for building data types using vectors.
2612 VM_DEFINE_OP (97, vector_ref_immediate
, "vector-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2614 scm_t_uint8 dst
, src
, idx
;
2617 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2618 v
= LOCAL_REF (src
);
2619 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2620 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2621 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2623 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2627 /* vector-set! dst:8 idx:8 src:8
2629 * Store SRC into the vector DST at index IDX.
2631 VM_DEFINE_OP (98, vector_set
, "vector-set!", OP1 (U8_U8_U8_U8
))
2633 scm_t_uint8 dst
, idx_var
, src
;
2635 scm_t_signed_bits i
= 0;
2637 UNPACK_8_8_8 (op
, dst
, idx_var
, src
);
2638 vect
= LOCAL_REF (dst
);
2639 idx
= LOCAL_REF (idx_var
);
2640 val
= LOCAL_REF (src
);
2642 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2643 && SCM_I_INUMP (idx
)
2644 && ((i
= SCM_I_INUM (idx
)) >= 0)
2645 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2646 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2650 scm_vector_set_x (vect
, idx
, val
);
2655 /* vector-set!/immediate dst:8 idx:8 src:8
2657 * Store SRC into the vector DST at index IDX. Here IDX is an
2660 VM_DEFINE_OP (99, vector_set_immediate
, "vector-set!/immediate", OP1 (U8_U8_U8_U8
))
2662 scm_t_uint8 dst
, idx
, src
;
2665 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2666 vect
= LOCAL_REF (dst
);
2667 val
= LOCAL_REF (src
);
2669 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2670 && idx
< SCM_I_VECTOR_LENGTH (vect
)))
2671 SCM_I_VECTOR_WELTS (vect
)[idx
] = val
;
2675 scm_vector_set_x (vect
, scm_from_uint8 (idx
), val
);
2687 /* struct-vtable dst:12 src:12
2689 * Store the vtable of SRC into DST.
2691 VM_DEFINE_OP (100, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2694 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2695 RETURN (SCM_STRUCT_VTABLE (obj
));
2698 /* allocate-struct/immediate dst:8 vtable:8 nfields:8
2700 * Allocate a new struct with VTABLE, and place it in DST. The struct
2701 * will be constructed with space for NFIELDS fields, which should
2702 * correspond to the field count of the VTABLE.
2704 VM_DEFINE_OP (101, allocate_struct_immediate
, "allocate-struct/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2706 scm_t_uint8 dst
, vtable
, nfields
;
2709 UNPACK_8_8_8 (op
, dst
, vtable
, nfields
);
2712 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2713 LOCAL_SET (dst
, ret
);
2718 /* struct-ref/immediate dst:8 src:8 idx:8
2720 * Fetch the item at slot IDX in the struct in SRC, and store it
2721 * in DST. IDX is an immediate unsigned 8-bit value.
2723 VM_DEFINE_OP (102, struct_ref_immediate
, "struct-ref/immediate", OP1 (U8_U8_U8_U8
) | OP_DST
)
2725 scm_t_uint8 dst
, src
, idx
;
2728 UNPACK_8_8_8 (op
, dst
, src
, idx
);
2730 obj
= LOCAL_REF (src
);
2732 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2733 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2734 SCM_VTABLE_FLAG_SIMPLE
)
2735 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2736 scm_vtable_index_size
)))
2737 RETURN (SCM_STRUCT_SLOT_REF (obj
, idx
));
2740 RETURN (scm_struct_ref (obj
, SCM_I_MAKINUM (idx
)));
2743 /* struct-set!/immediate dst:8 idx:8 src:8
2745 * Store SRC into the struct DST at slot IDX. IDX is an immediate
2746 * unsigned 8-bit value.
2748 VM_DEFINE_OP (103, struct_set_immediate
, "struct-set!/immediate", OP1 (U8_U8_U8_U8
))
2750 scm_t_uint8 dst
, idx
, src
;
2753 UNPACK_8_8_8 (op
, dst
, idx
, src
);
2755 obj
= LOCAL_REF (dst
);
2756 val
= LOCAL_REF (src
);
2758 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2759 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2760 SCM_VTABLE_FLAG_SIMPLE
)
2761 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2762 SCM_VTABLE_FLAG_SIMPLE_RW
)
2763 && idx
< SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj
),
2764 scm_vtable_index_size
)))
2766 SCM_STRUCT_SLOT_SET (obj
, idx
, val
);
2771 scm_struct_set_x (obj
, SCM_I_MAKINUM (idx
), val
);
2775 /* class-of dst:12 type:12
2777 * Store the vtable of SRC into DST.
2779 VM_DEFINE_OP (104, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
2782 if (SCM_INSTANCEP (obj
))
2783 RETURN (SCM_CLASS_OF (obj
));
2785 RETURN (scm_class_of (obj
));
2791 * Arrays, packed uniform arrays, and bytevectors.
2794 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
2796 * Load the contiguous typed array located at OFFSET 32-bit words away
2797 * from the instruction pointer, and store into DST. LEN is a byte
2798 * length. OFFSET is signed.
2800 VM_DEFINE_OP (105, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
2802 scm_t_uint8 dst
, type
, shape
;
2806 UNPACK_8_8_8 (op
, dst
, type
, shape
);
2810 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
2816 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
2818 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
2820 VM_DEFINE_OP (106, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
2822 scm_t_uint16 dst
, type
, fill
, bounds
;
2823 UNPACK_12_12 (op
, dst
, type
);
2824 UNPACK_12_12 (ip
[1], fill
, bounds
);
2826 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
2827 LOCAL_REF (bounds
)));
2831 /* bv-u8-ref dst:8 src:8 idx:8
2832 * bv-s8-ref dst:8 src:8 idx:8
2833 * bv-u16-ref dst:8 src:8 idx:8
2834 * bv-s16-ref dst:8 src:8 idx:8
2835 * bv-u32-ref dst:8 src:8 idx:8
2836 * bv-s32-ref dst:8 src:8 idx:8
2837 * bv-u64-ref dst:8 src:8 idx:8
2838 * bv-s64-ref dst:8 src:8 idx:8
2839 * bv-f32-ref dst:8 src:8 idx:8
2840 * bv-f64-ref dst:8 src:8 idx:8
2842 * Fetch the item at byte offset IDX in the bytevector SRC, and store
2843 * it in DST. All accesses use native endianness.
2845 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
2847 scm_t_signed_bits i; \
2848 const scm_t_ ## type *int_ptr; \
2851 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2852 i = SCM_I_INUM (idx); \
2853 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2855 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2857 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2858 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2859 RETURN (SCM_I_MAKINUM (*int_ptr)); \
2863 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
2867 #define BV_INT_REF(stem, type, size) \
2869 scm_t_signed_bits i; \
2870 const scm_t_ ## type *int_ptr; \
2873 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2874 i = SCM_I_INUM (idx); \
2875 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2877 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2879 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2880 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
2882 scm_t_ ## type x = *int_ptr; \
2883 if (SCM_FIXABLE (x)) \
2884 RETURN (SCM_I_MAKINUM (x)); \
2888 RETURN (scm_from_ ## type (x)); \
2894 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
2898 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
2900 scm_t_signed_bits i; \
2901 const type *float_ptr; \
2904 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
2905 i = SCM_I_INUM (idx); \
2906 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2909 if (SCM_LIKELY (SCM_I_INUMP (idx) \
2911 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2912 && (ALIGNED_P (float_ptr, type)))) \
2913 RETURN (scm_from_double (*float_ptr)); \
2915 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
2918 VM_DEFINE_OP (107, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2919 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
2921 VM_DEFINE_OP (108, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2922 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
2924 VM_DEFINE_OP (109, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2925 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
2927 VM_DEFINE_OP (110, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2928 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
2930 VM_DEFINE_OP (111, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2931 #if SIZEOF_VOID_P > 4
2932 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
2934 BV_INT_REF (u32
, uint32
, 4);
2937 VM_DEFINE_OP (112, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2938 #if SIZEOF_VOID_P > 4
2939 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
2941 BV_INT_REF (s32
, int32
, 4);
2944 VM_DEFINE_OP (113, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2945 BV_INT_REF (u64
, uint64
, 8);
2947 VM_DEFINE_OP (114, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2948 BV_INT_REF (s64
, int64
, 8);
2950 VM_DEFINE_OP (115, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2951 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
2953 VM_DEFINE_OP (116, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2954 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
2956 /* bv-u8-set! dst:8 idx:8 src:8
2957 * bv-s8-set! dst:8 idx:8 src:8
2958 * bv-u16-set! dst:8 idx:8 src:8
2959 * bv-s16-set! dst:8 idx:8 src:8
2960 * bv-u32-set! dst:8 idx:8 src:8
2961 * bv-s32-set! dst:8 idx:8 src:8
2962 * bv-u64-set! dst:8 idx:8 src:8
2963 * bv-s64-set! dst:8 idx:8 src:8
2964 * bv-f32-set! dst:8 idx:8 src:8
2965 * bv-f64-set! dst:8 idx:8 src:8
2967 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
2968 * values are written using native endianness.
2970 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
2972 scm_t_uint8 dst, idx, src; \
2973 scm_t_signed_bits i, j = 0; \
2974 SCM bv, scm_idx, val; \
2975 scm_t_ ## type *int_ptr; \
2977 UNPACK_8_8_8 (op, dst, idx, src); \
2978 bv = LOCAL_REF (dst); \
2979 scm_idx = LOCAL_REF (idx); \
2980 val = LOCAL_REF (src); \
2981 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
2982 i = SCM_I_INUM (scm_idx); \
2983 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
2985 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
2987 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
2988 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
2989 && (SCM_I_INUMP (val)) \
2990 && ((j = SCM_I_INUM (val)) >= min) \
2992 *int_ptr = (scm_t_ ## type) j; \
2996 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3001 #define BV_INT_SET(stem, type, size) \
3003 scm_t_uint8 dst, idx, src; \
3004 scm_t_signed_bits i; \
3005 SCM bv, scm_idx, val; \
3006 scm_t_ ## type *int_ptr; \
3008 UNPACK_8_8_8 (op, dst, idx, src); \
3009 bv = LOCAL_REF (dst); \
3010 scm_idx = LOCAL_REF (idx); \
3011 val = LOCAL_REF (src); \
3012 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3013 i = SCM_I_INUM (scm_idx); \
3014 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3016 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3018 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3019 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3020 *int_ptr = scm_to_ ## type (val); \
3024 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3029 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3031 scm_t_uint8 dst, idx, src; \
3032 scm_t_signed_bits i; \
3033 SCM bv, scm_idx, val; \
3036 UNPACK_8_8_8 (op, dst, idx, src); \
3037 bv = LOCAL_REF (dst); \
3038 scm_idx = LOCAL_REF (idx); \
3039 val = LOCAL_REF (src); \
3040 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
3041 i = SCM_I_INUM (scm_idx); \
3042 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3044 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3046 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3047 && (ALIGNED_P (float_ptr, type)))) \
3048 *float_ptr = scm_to_double (val); \
3052 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3057 VM_DEFINE_OP (117, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3058 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3060 VM_DEFINE_OP (118, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3061 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3063 VM_DEFINE_OP (119, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3064 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3066 VM_DEFINE_OP (120, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3067 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3069 VM_DEFINE_OP (121, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3070 #if SIZEOF_VOID_P > 4
3071 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3073 BV_INT_SET (u32
, uint32
, 4);
3076 VM_DEFINE_OP (122, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3077 #if SIZEOF_VOID_P > 4
3078 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3080 BV_INT_SET (s32
, int32
, 4);
3083 VM_DEFINE_OP (123, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3084 BV_INT_SET (u64
, uint64
, 8);
3086 VM_DEFINE_OP (124, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3087 BV_INT_SET (s64
, int64
, 8);
3089 VM_DEFINE_OP (125, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3090 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3092 VM_DEFINE_OP (126, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3093 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3095 VM_DEFINE_OP (127, unused_127
, NULL
, NOP
)
3096 VM_DEFINE_OP (128, unused_128
, NULL
, NOP
)
3097 VM_DEFINE_OP (129, unused_129
, NULL
, NOP
)
3098 VM_DEFINE_OP (130, unused_130
, NULL
, NOP
)
3099 VM_DEFINE_OP (131, unused_131
, NULL
, NOP
)
3100 VM_DEFINE_OP (132, unused_132
, NULL
, NOP
)
3101 VM_DEFINE_OP (133, unused_133
, NULL
, NOP
)
3102 VM_DEFINE_OP (134, unused_134
, NULL
, NOP
)
3103 VM_DEFINE_OP (135, unused_135
, NULL
, NOP
)
3104 VM_DEFINE_OP (136, unused_136
, NULL
, NOP
)
3105 VM_DEFINE_OP (137, unused_137
, NULL
, NOP
)
3106 VM_DEFINE_OP (138, unused_138
, NULL
, NOP
)
3107 VM_DEFINE_OP (139, unused_139
, NULL
, NOP
)
3108 VM_DEFINE_OP (140, unused_140
, NULL
, NOP
)
3109 VM_DEFINE_OP (141, unused_141
, NULL
, NOP
)
3110 VM_DEFINE_OP (142, unused_142
, NULL
, NOP
)
3111 VM_DEFINE_OP (143, unused_143
, NULL
, NOP
)
3112 VM_DEFINE_OP (144, unused_144
, NULL
, NOP
)
3113 VM_DEFINE_OP (145, unused_145
, NULL
, NOP
)
3114 VM_DEFINE_OP (146, unused_146
, NULL
, NOP
)
3115 VM_DEFINE_OP (147, unused_147
, NULL
, NOP
)
3116 VM_DEFINE_OP (148, unused_148
, NULL
, NOP
)
3117 VM_DEFINE_OP (149, unused_149
, NULL
, NOP
)
3118 VM_DEFINE_OP (150, unused_150
, NULL
, NOP
)
3119 VM_DEFINE_OP (151, unused_151
, NULL
, NOP
)
3120 VM_DEFINE_OP (152, unused_152
, NULL
, NOP
)
3121 VM_DEFINE_OP (153, unused_153
, NULL
, NOP
)
3122 VM_DEFINE_OP (154, unused_154
, NULL
, NOP
)
3123 VM_DEFINE_OP (155, unused_155
, NULL
, NOP
)
3124 VM_DEFINE_OP (156, unused_156
, NULL
, NOP
)
3125 VM_DEFINE_OP (157, unused_157
, NULL
, NOP
)
3126 VM_DEFINE_OP (158, unused_158
, NULL
, NOP
)
3127 VM_DEFINE_OP (159, unused_159
, NULL
, NOP
)
3128 VM_DEFINE_OP (160, unused_160
, NULL
, NOP
)
3129 VM_DEFINE_OP (161, unused_161
, NULL
, NOP
)
3130 VM_DEFINE_OP (162, unused_162
, NULL
, NOP
)
3131 VM_DEFINE_OP (163, unused_163
, NULL
, NOP
)
3132 VM_DEFINE_OP (164, unused_164
, NULL
, NOP
)
3133 VM_DEFINE_OP (165, unused_165
, NULL
, NOP
)
3134 VM_DEFINE_OP (166, unused_166
, NULL
, NOP
)
3135 VM_DEFINE_OP (167, unused_167
, NULL
, NOP
)
3136 VM_DEFINE_OP (168, unused_168
, NULL
, NOP
)
3137 VM_DEFINE_OP (169, unused_169
, NULL
, NOP
)
3138 VM_DEFINE_OP (170, unused_170
, NULL
, NOP
)
3139 VM_DEFINE_OP (171, unused_171
, NULL
, NOP
)
3140 VM_DEFINE_OP (172, unused_172
, NULL
, NOP
)
3141 VM_DEFINE_OP (173, unused_173
, NULL
, NOP
)
3142 VM_DEFINE_OP (174, unused_174
, NULL
, NOP
)
3143 VM_DEFINE_OP (175, unused_175
, NULL
, NOP
)
3144 VM_DEFINE_OP (176, unused_176
, NULL
, NOP
)
3145 VM_DEFINE_OP (177, unused_177
, NULL
, NOP
)
3146 VM_DEFINE_OP (178, unused_178
, NULL
, NOP
)
3147 VM_DEFINE_OP (179, unused_179
, NULL
, NOP
)
3148 VM_DEFINE_OP (180, unused_180
, NULL
, NOP
)
3149 VM_DEFINE_OP (181, unused_181
, NULL
, NOP
)
3150 VM_DEFINE_OP (182, unused_182
, NULL
, NOP
)
3151 VM_DEFINE_OP (183, unused_183
, NULL
, NOP
)
3152 VM_DEFINE_OP (184, unused_184
, NULL
, NOP
)
3153 VM_DEFINE_OP (185, unused_185
, NULL
, NOP
)
3154 VM_DEFINE_OP (186, unused_186
, NULL
, NOP
)
3155 VM_DEFINE_OP (187, unused_187
, NULL
, NOP
)
3156 VM_DEFINE_OP (188, unused_188
, NULL
, NOP
)
3157 VM_DEFINE_OP (189, unused_189
, NULL
, NOP
)
3158 VM_DEFINE_OP (190, unused_190
, NULL
, NOP
)
3159 VM_DEFINE_OP (191, unused_191
, NULL
, NOP
)
3160 VM_DEFINE_OP (192, unused_192
, NULL
, NOP
)
3161 VM_DEFINE_OP (193, unused_193
, NULL
, NOP
)
3162 VM_DEFINE_OP (194, unused_194
, NULL
, NOP
)
3163 VM_DEFINE_OP (195, unused_195
, NULL
, NOP
)
3164 VM_DEFINE_OP (196, unused_196
, NULL
, NOP
)
3165 VM_DEFINE_OP (197, unused_197
, NULL
, NOP
)
3166 VM_DEFINE_OP (198, unused_198
, NULL
, NOP
)
3167 VM_DEFINE_OP (199, unused_199
, NULL
, NOP
)
3168 VM_DEFINE_OP (200, unused_200
, NULL
, NOP
)
3169 VM_DEFINE_OP (201, unused_201
, NULL
, NOP
)
3170 VM_DEFINE_OP (202, unused_202
, NULL
, NOP
)
3171 VM_DEFINE_OP (203, unused_203
, NULL
, NOP
)
3172 VM_DEFINE_OP (204, unused_204
, NULL
, NOP
)
3173 VM_DEFINE_OP (205, unused_205
, NULL
, NOP
)
3174 VM_DEFINE_OP (206, unused_206
, NULL
, NOP
)
3175 VM_DEFINE_OP (207, unused_207
, NULL
, NOP
)
3176 VM_DEFINE_OP (208, unused_208
, NULL
, NOP
)
3177 VM_DEFINE_OP (209, unused_209
, NULL
, NOP
)
3178 VM_DEFINE_OP (210, unused_210
, NULL
, NOP
)
3179 VM_DEFINE_OP (211, unused_211
, NULL
, NOP
)
3180 VM_DEFINE_OP (212, unused_212
, NULL
, NOP
)
3181 VM_DEFINE_OP (213, unused_213
, NULL
, NOP
)
3182 VM_DEFINE_OP (214, unused_214
, NULL
, NOP
)
3183 VM_DEFINE_OP (215, unused_215
, NULL
, NOP
)
3184 VM_DEFINE_OP (216, unused_216
, NULL
, NOP
)
3185 VM_DEFINE_OP (217, unused_217
, NULL
, NOP
)
3186 VM_DEFINE_OP (218, unused_218
, NULL
, NOP
)
3187 VM_DEFINE_OP (219, unused_219
, NULL
, NOP
)
3188 VM_DEFINE_OP (220, unused_220
, NULL
, NOP
)
3189 VM_DEFINE_OP (221, unused_221
, NULL
, NOP
)
3190 VM_DEFINE_OP (222, unused_222
, NULL
, NOP
)
3191 VM_DEFINE_OP (223, unused_223
, NULL
, NOP
)
3192 VM_DEFINE_OP (224, unused_224
, NULL
, NOP
)
3193 VM_DEFINE_OP (225, unused_225
, NULL
, NOP
)
3194 VM_DEFINE_OP (226, unused_226
, NULL
, NOP
)
3195 VM_DEFINE_OP (227, unused_227
, NULL
, NOP
)
3196 VM_DEFINE_OP (228, unused_228
, NULL
, NOP
)
3197 VM_DEFINE_OP (229, unused_229
, NULL
, NOP
)
3198 VM_DEFINE_OP (230, unused_230
, NULL
, NOP
)
3199 VM_DEFINE_OP (231, unused_231
, NULL
, NOP
)
3200 VM_DEFINE_OP (232, unused_232
, NULL
, NOP
)
3201 VM_DEFINE_OP (233, unused_233
, NULL
, NOP
)
3202 VM_DEFINE_OP (234, unused_234
, NULL
, NOP
)
3203 VM_DEFINE_OP (235, unused_235
, NULL
, NOP
)
3204 VM_DEFINE_OP (236, unused_236
, NULL
, NOP
)
3205 VM_DEFINE_OP (237, unused_237
, NULL
, NOP
)
3206 VM_DEFINE_OP (238, unused_238
, NULL
, NOP
)
3207 VM_DEFINE_OP (239, unused_239
, NULL
, NOP
)
3208 VM_DEFINE_OP (240, unused_240
, NULL
, NOP
)
3209 VM_DEFINE_OP (241, unused_241
, NULL
, NOP
)
3210 VM_DEFINE_OP (242, unused_242
, NULL
, NOP
)
3211 VM_DEFINE_OP (243, unused_243
, NULL
, NOP
)
3212 VM_DEFINE_OP (244, unused_244
, NULL
, NOP
)
3213 VM_DEFINE_OP (245, unused_245
, NULL
, NOP
)
3214 VM_DEFINE_OP (246, unused_246
, NULL
, NOP
)
3215 VM_DEFINE_OP (247, unused_247
, NULL
, NOP
)
3216 VM_DEFINE_OP (248, unused_248
, NULL
, NOP
)
3217 VM_DEFINE_OP (249, unused_249
, NULL
, NOP
)
3218 VM_DEFINE_OP (250, unused_250
, NULL
, NOP
)
3219 VM_DEFINE_OP (251, unused_251
, NULL
, NOP
)
3220 VM_DEFINE_OP (252, unused_252
, NULL
, NOP
)
3221 VM_DEFINE_OP (253, unused_253
, NULL
, NOP
)
3222 VM_DEFINE_OP (254, unused_254
, NULL
, NOP
)
3223 VM_DEFINE_OP (255, unused_255
, NULL
, NOP
)
3225 vm_error_bad_instruction (op
);
3226 abort (); /* never reached */
3229 END_DISPATCH_SWITCH
;
3233 #undef ABORT_CONTINUATION_HOOK
3238 #undef BEGIN_DISPATCH_SWITCH
3239 #undef BINARY_INTEGER_OP
3240 #undef BR_ARITHMETIC
3244 #undef BV_FIXABLE_INT_REF
3245 #undef BV_FIXABLE_INT_SET
3250 #undef CACHE_REGISTER
3251 #undef CHECK_OVERFLOW
3252 #undef END_DISPATCH_SWITCH
3253 #undef FREE_VARIABLE_REF
3262 #undef POP_CONTINUATION_HOOK
3263 #undef PUSH_CONTINUATION_HOOK
3265 #undef RETURN_ONE_VALUE
3266 #undef RETURN_VALUE_LIST
3276 #undef VARIABLE_BOUNDP
3279 #undef VM_CHECK_FREE_VARIABLE
3280 #undef VM_CHECK_OBJECT
3281 #undef VM_CHECK_UNDERFLOW
3283 #undef VM_INSTRUCTION_TO_LABEL
3285 #undef VM_VALIDATE_BYTEVECTOR
3286 #undef VM_VALIDATE_PAIR
3287 #undef VM_VALIDATE_STRUCT
3290 (defun renumber-ops ()
3291 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3294 (let ((counter -1)) (goto-char (point-min))
3295 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3297 (number-to-string (setq counter (1+ counter)))