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. */
24 This file contains two virtual machines. First, the old one -- the
25 one that is currently used, and corresponds to Guile 2.0. It's a
26 stack machine, meaning that most instructions pop their operands from
27 the top of the stack, and push results there too.
29 Following it is the new virtual machine. It's a register machine,
30 meaning that intructions address their operands by index, and store
31 results in indexed slots as well. Those slots are on the stack.
32 It's somewhat confusing to call it a register machine, given that the
33 values are on the stack. Perhaps it needs a new name.
35 Anyway, things are in a transitional state. We're going to try to
36 avoid munging the old VM very much while we flesh out the new one.
37 We're also going to try to make them interoperable, as much as
38 possible -- to have the old VM be able to call procedures for the new
39 VM, and vice versa. This should ease the bootstrapping process. */
43 static SCM
VM_NAME (SCM
, SCM
, SCM
*, int);
45 static SCM
RTL_VM_NAME (SCM
, SCM
, SCM
*, size_t);
48 #if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
49 # define VM_USE_HOOKS 0 /* Various hooks */
50 #elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
51 # define VM_USE_HOOKS 1
53 # error unknown debug engine VM_ENGINE
56 /* Assign some registers by hand. There used to be a bigger list here,
57 but it was never tested, and in the case of x86-32, was a source of
58 compilation failures. It can be revived if it's useful, but my naive
59 hope is that simply annotating the locals with "register" will be a
60 sufficient hint to the compiler. */
62 # if defined __x86_64__
63 /* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
64 well. Tell it to keep the jump table in a r12, which is
66 # define JT_REG asm ("r12")
83 #define VM_ASSERT(condition, handler) \
85 if (SCM_UNLIKELY (!(condition))) \
92 #ifdef VM_ENABLE_ASSERTIONS
93 # define ASSERT(condition) VM_ASSERT (condition, abort())
95 # define ASSERT(condition)
99 #define RUN_HOOK(h, args, n) \
101 if (SCM_UNLIKELY (vp->trace_level > 0)) \
104 vm_dispatch_hook (vm, h, args, n); \
108 #define RUN_HOOK(h, args, n)
110 #define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
112 #define APPLY_HOOK() \
113 RUN_HOOK0 (SCM_VM_APPLY_HOOK)
114 #define PUSH_CONTINUATION_HOOK() \
115 RUN_HOOK0 (SCM_VM_PUSH_CONTINUATION_HOOK)
116 #define POP_CONTINUATION_HOOK(vals, n) \
117 RUN_HOOK (SCM_VM_POP_CONTINUATION_HOOK, vals, n)
118 #define NEXT_HOOK() \
119 RUN_HOOK0 (SCM_VM_NEXT_HOOK)
120 #define ABORT_CONTINUATION_HOOK(vals, n) \
121 RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK, vals, n)
122 #define RESTORE_CONTINUATION_HOOK() \
123 RUN_HOOK0 (SCM_VM_RESTORE_CONTINUATION_HOOK)
125 #define VM_HANDLE_INTERRUPTS \
126 SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
131 /* Cache the VM's instruction, stack, and frame pointer in local variables. */
132 #define CACHE_REGISTER() \
139 /* Update the registers in VP, a pointer to the current VM. This must be done
140 at least before any GC invocation so that `vp->sp' is up-to-date and the
141 whole stack gets marked. */
142 #define SYNC_REGISTER() \
150 #define ASSERT_VARIABLE(x) \
151 VM_ASSERT (SCM_VARIABLEP (x), abort())
152 #define ASSERT_BOUND_VARIABLE(x) \
153 VM_ASSERT (SCM_VARIABLEP (x) \
154 && !scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED), \
157 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
159 do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
160 #define ASSERT_ALIGNED_PROCEDURE() \
161 do { if ((scm_t_bits)bp % 8) abort (); } while (0)
162 #define ASSERT_BOUND(x) \
163 VM_ASSERT (!scm_is_eq ((x), SCM_UNDEFINED), abort())
166 #define ASSERT_ALIGNED_PROCEDURE()
167 #define ASSERT_BOUND(x)
170 /* Cache the object table and free variables. */
171 #define CACHE_PROGRAM() \
173 if (bp != SCM_PROGRAM_DATA (program)) { \
174 bp = SCM_PROGRAM_DATA (program); \
175 ASSERT_ALIGNED_PROCEDURE (); \
176 if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
177 objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
184 #define SYNC_BEFORE_GC() \
199 /* Accesses to a program's object table. */
200 #define CHECK_OBJECT(_num)
201 #define CHECK_FREE_VARIABLE(_num)
208 #ifdef VM_ENABLE_STACK_NULLING
209 # define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
210 # define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
211 # define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
212 /* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
213 inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
214 that continuation doesn't have a chance to run. It's not important on a
215 semantic level, but it does mess up our stack nulling -- so this macro is to
217 # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
219 # define CHECK_STACK_LEAKN(_n)
220 # define CHECK_STACK_LEAK()
221 # define NULLSTACK(_n)
222 # define NULLSTACK_FOR_NONLOCAL_EXIT()
225 /* For this check, we don't use VM_ASSERT, because that leads to a
226 per-site SYNC_ALL, which is too much code growth. The real problem
227 of course is having to check for overflow all the time... */
228 #define CHECK_OVERFLOW() \
229 do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
231 #ifdef VM_CHECK_UNDERFLOW
232 #define PRE_CHECK_UNDERFLOW(N) \
233 VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
234 #define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
236 #define PRE_CHECK_UNDERFLOW(N) /* nop */
237 #define CHECK_UNDERFLOW() /* nop */
241 #define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
242 #define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
243 #define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
244 #define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
245 #define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
246 #define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
248 /* Pop the N objects on top of the stack and push a list that contains
250 #define POP_LIST(n) \
254 SCM l = SCM_EOL, x; \
256 for (i = n; i; i--) \
259 l = scm_cons (x, l); \
264 /* The opposite: push all of the elements in L onto the list. */
265 #define PUSH_LIST(l, NILP) \
268 for (; scm_is_pair (l); l = SCM_CDR (l)) \
269 PUSH (SCM_CAR (l)); \
270 VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
275 * Instruction operation
278 #define FETCH() (*ip++)
279 #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
282 #ifdef HAVE_LABELS_AS_VALUES
283 # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
285 # define NEXT_JUMP() goto vm_start
291 CHECK_STACK_LEAK (); \
296 /* See frames.h for the layout of stack frames */
297 /* When this is called, bp points to the new program data,
298 and the arguments are already on the stack */
299 #define DROP_FRAME() \
303 CHECK_UNDERFLOW (); \
308 VM_NAME (SCM vm
, SCM program
, SCM
*argv
, int nargs
)
311 register scm_t_uint8
*ip IP_REG
; /* instruction pointer */
312 register SCM
*sp SP_REG
; /* stack pointer */
313 register SCM
*fp FP_REG
; /* frame pointer */
314 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
316 /* Cache variables */
317 struct scm_objcode
*bp
= NULL
; /* program base pointer */
318 SCM
*objects
= NULL
; /* constant objects */
319 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
321 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
323 /* Internal variables */
325 scm_i_jmp_buf registers
; /* used for prompts */
327 #ifdef HAVE_LABELS_AS_VALUES
328 static const void **jump_table_pointer
= NULL
;
331 #ifdef HAVE_LABELS_AS_VALUES
332 register const void **jump_table JT_REG
;
334 if (SCM_UNLIKELY (!jump_table_pointer
))
337 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
338 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
339 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
340 #define VM_INSTRUCTION_TO_LABEL 1
341 #define jump_table jump_table_pointer
342 #include <libguile/vm-expand.h>
343 #include <libguile/vm-i-system.i>
344 #include <libguile/vm-i-scheme.i>
345 #include <libguile/vm-i-loader.i>
347 #undef VM_INSTRUCTION_TO_LABEL
350 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
351 load instruction at each instruction dispatch. */
352 jump_table
= jump_table_pointer
;
355 if (SCM_I_SETJMP (registers
))
357 /* Non-local return. Cache the VM registers back from the vp, and
360 Note, at this point, we must assume that any variable local to
361 vm_engine that can be assigned *has* been assigned. So we need to pull
362 all our state back from the ip/fp/sp.
365 program
= SCM_FRAME_PROGRAM (fp
);
367 /* The stack contains the values returned to this continuation,
368 along with a number-of-values marker -- like an MV return. */
369 ABORT_CONTINUATION_HOOK (sp
- SCM_I_INUM (*sp
), SCM_I_INUM (*sp
));
375 /* Since it's possible to receive the arguments on the stack itself,
376 and indeed the RTL VM invokes us that way, shuffle up the
378 VM_ASSERT (sp
+ 8 + nargs
< stack_limit
, vm_error_too_many_args (nargs
));
381 for (i
= nargs
- 1; i
>= 0; i
--)
386 PUSH (SCM_PACK (fp
)); /* dynamic link */
387 PUSH (SCM_PACK (0)); /* mvra */
388 PUSH (SCM_PACK (ip
)); /* ra */
389 PUSH (boot_continuation
);
391 ip
= SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation
));
393 /* MV-call frame, function & arguments */
394 PUSH (SCM_PACK (fp
)); /* dynamic link */
395 PUSH (SCM_PACK (ip
+ 1)); /* mvra */
396 PUSH (SCM_PACK (ip
)); /* ra */
401 PUSH_CONTINUATION_HOOK ();
405 if (!SCM_PROGRAM_P (program
))
407 if (SCM_STRUCTP (program
) && SCM_STRUCT_APPLICABLE_P (program
))
408 fp
[-1] = SCM_STRUCT_PROCEDURE (program
);
409 else if (SCM_HAS_TYP7 (program
, scm_tc7_rtl_program
))
414 ret
= RTL_VM_NAME (vm
, program
, fp
, sp
- fp
+ 1);
416 NULLSTACK_FOR_NONLOCAL_EXIT ();
418 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
420 /* multiple values returned to continuation */
421 ret
= scm_struct_ref (ret
, SCM_INUM0
);
422 nvalues
= scm_ilength (ret
);
423 PUSH_LIST (ret
, scm_is_null
);
424 goto vm_return_values
;
432 else if (SCM_HAS_TYP7 (program
, scm_tc7_smob
)
433 && SCM_SMOB_APPLICABLE_P (program
))
435 /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
438 for (i
= sp
- fp
; i
>= 0; i
--)
440 fp
[-1] = SCM_SMOB_DESCRIPTOR (program
).apply_trampoline
;
445 vm_error_wrong_type_apply (program
);
451 ip
= SCM_C_OBJCODE_BASE (bp
);
458 #ifndef HAVE_LABELS_AS_VALUES
460 switch ((*ip
++) & SCM_VM_INSTRUCTION_MASK
) {
463 #include "vm-expand.h"
464 #include "vm-i-system.c"
465 #include "vm-i-scheme.c"
466 #include "vm-i-loader.c"
468 #ifndef HAVE_LABELS_AS_VALUES
470 goto vm_error_bad_instruction
;
474 abort (); /* never reached */
476 vm_error_bad_instruction
:
477 vm_error_bad_instruction (ip
[-1]);
478 abort (); /* never reached */
482 vm_error_stack_overflow (vp
);
483 abort (); /* never reached */
487 #undef CACHE_REGISTER
488 #undef CHECK_OVERFLOW
501 #undef RETURN_ONE_VALUE
502 #undef RETURN_VALUE_LIST
504 #undef SYNC_BEFORE_GC
507 #undef VARIABLE_BOUNDP
511 #undef VM_INSTRUCTION_TO_LABEL
518 This is Guile's new virtual machine. When I say "new", I mean
519 relative to the current virtual machine. At some point it will
520 become "the" virtual machine, and we'll delete this paragraph. As
521 such, the rest of the comments speak as if there's only one VM.
522 In difference from the old VM, local 0 is the procedure, and the
523 first argument is local 1. At some point in the future we should
524 change the fp to point to the procedure and not to local 1.
530 /* The VM has three state bits: the instruction pointer (IP), the frame
531 pointer (FP), and the top-of-stack pointer (SP). We cache the first
532 two of these in machine registers, local to the VM, because they are
533 used extensively by the VM. As the SP is used more by code outside
534 the VM than by the VM itself, we don't bother caching it locally.
536 Since the FP changes infrequently, relative to the IP, we keep vp->fp
537 in sync with the local FP. This would be a big lose for the IP,
538 though, so instead of updating vp->ip all the time, we call SYNC_IP
539 whenever we would need to know the IP of the top frame. In practice,
540 we need to SYNC_IP whenever we call out of the VM to a function that
541 would like to walk the stack, perhaps as the result of an
545 vp->ip = (scm_t_uint8 *) (ip)
547 #define SYNC_REGISTER() \
549 #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
550 #define SYNC_ALL() /* FP already saved */ \
553 #define CHECK_OVERFLOW(sp) \
555 if (SCM_UNLIKELY ((sp) >= stack_limit)) \
556 vm_error_stack_overflow (vp); \
559 /* Reserve stack space for a frame. Will check that there is sufficient
560 stack space for N locals, including the procedure, in addition to
561 3 words to set up the next frame. Invoke after preparing the new
562 frame and setting the fp and ip. */
563 #define ALLOC_FRAME(n) \
565 SCM *new_sp = vp->sp = fp - 1 + n - 1; \
566 CHECK_OVERFLOW (new_sp + 4); \
569 /* Reset the current frame to hold N locals. Used when we know that no
570 stack expansion is needed. */
571 #define RESET_FRAME(n) \
573 vp->sp = fp - 2 + n; \
576 /* Compute the number of locals in the frame. This is equal to the
577 number of actual arguments when a function is first called, plus
578 one for the function. */
579 #define FRAME_LOCALS_COUNT() \
580 (vp->sp + 1 - (fp - 1))
582 /* Restore registers after returning from a frame. */
583 #define RESTORE_FRAME() \
588 #define CACHE_REGISTER() \
590 ip = (scm_t_uint32 *) vp->ip; \
594 #ifdef HAVE_LABELS_AS_VALUES
595 # define BEGIN_DISPATCH_SWITCH /* */
596 # define END_DISPATCH_SWITCH /* */
603 goto *jump_table[op & 0xff]; \
606 # define VM_DEFINE_OP(opcode, tag, name, meta) \
609 # define BEGIN_DISPATCH_SWITCH \
615 # define END_DISPATCH_SWITCH \
617 goto vm_error_bad_instruction; \
626 # define VM_DEFINE_OP(opcode, tag, name, meta) \
631 #define LOCAL_REF(i) SCM_FRAME_VARIABLE ((fp - 1), i)
632 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE ((fp - 1), i) = o
634 #define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
635 #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
636 #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
638 #define RETURN_ONE_VALUE(ret) \
641 SCM *sp = SCM_FRAME_LOWER_ADDRESS (fp); \
642 VM_HANDLE_INTERRUPTS; \
643 ip = SCM_FRAME_RTL_RETURN_ADDRESS (fp); \
644 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
646 sp[0] = SCM_BOOL_F; \
647 sp[1] = SCM_BOOL_F; \
648 sp[2] = SCM_BOOL_F; \
652 POP_CONTINUATION_HOOK (sp, 1); \
656 /* While we could generate the list-unrolling code here, it's fine for
657 now to just tail-call (apply values vals). */
658 #define RETURN_VALUE_LIST(vals_) \
661 VM_HANDLE_INTERRUPTS; \
662 fp[-1] = rtl_apply; \
663 fp[0] = rtl_values; \
666 ip = (scm_t_uint32 *) rtl_apply_code; \
667 goto op_tail_apply; \
670 #define BR_NARGS(rel) \
671 scm_t_uint16 expected; \
672 SCM_UNPACK_RTL_24 (op, expected); \
673 if (FRAME_LOCALS_COUNT() rel expected) \
675 scm_t_int32 offset = ip[1]; \
676 offset >>= 8; /* Sign-extending shift. */ \
681 #define BR_UNARY(x, exp) \
684 SCM_UNPACK_RTL_24 (op, test); \
685 x = LOCAL_REF (test); \
686 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
688 scm_t_int32 offset = ip[1]; \
689 offset >>= 8; /* Sign-extending shift. */ \
691 VM_HANDLE_INTERRUPTS; \
696 #define BR_BINARY(x, y, exp) \
699 SCM_UNPACK_RTL_12_12 (op, a, b); \
702 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
704 scm_t_int32 offset = ip[1]; \
705 offset >>= 8; /* Sign-extending shift. */ \
707 VM_HANDLE_INTERRUPTS; \
712 #define BR_ARITHMETIC(crel,srel) \
716 SCM_UNPACK_RTL_12_12 (op, a, b); \
719 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
721 scm_t_signed_bits x_bits = SCM_UNPACK (x); \
722 scm_t_signed_bits y_bits = SCM_UNPACK (y); \
723 if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
725 scm_t_int32 offset = ip[1]; \
726 offset >>= 8; /* Sign-extending shift. */ \
728 VM_HANDLE_INTERRUPTS; \
738 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
740 scm_t_int32 offset = ip[1]; \
741 offset >>= 8; /* Sign-extending shift. */ \
743 VM_HANDLE_INTERRUPTS; \
751 scm_t_uint16 dst, src; \
753 SCM_UNPACK_RTL_12_12 (op, dst, src); \
755 #define ARGS2(a1, a2) \
756 scm_t_uint8 dst, src1, src2; \
758 SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
759 a1 = LOCAL_REF (src1); \
760 a2 = LOCAL_REF (src2)
762 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
764 /* The maximum/minimum tagged integers. */
766 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
768 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
770 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
771 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
773 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
776 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
778 scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
779 if (SCM_FIXABLE (n)) \
780 RETURN (SCM_I_MAKINUM (n)); \
783 RETURN (SFUNC (x, y)); \
786 #define VM_VALIDATE_PAIR(x, proc) \
787 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
789 #define VM_VALIDATE_STRUCT(obj, proc) \
790 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
792 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
793 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
795 /* Return true (non-zero) if PTR has suitable alignment for TYPE. */
796 #define ALIGNED_P(ptr, type) \
797 ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
800 RTL_VM_NAME (SCM vm
, SCM program
, SCM
*argv
, size_t nargs_
)
802 /* Instruction pointer: A pointer to the opcode that is currently
804 register scm_t_uint32
*ip IP_REG
;
806 /* Frame pointer: A pointer into the stack, off of which we index
807 arguments and local variables. Pushed at function calls, popped on
809 register SCM
*fp FP_REG
;
811 /* Current opcode: A cache of *ip. */
812 register scm_t_uint32 op
;
814 /* Cached variables. */
815 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
816 SCM
*stack_limit
= vp
->stack_limit
; /* stack limit address */
817 scm_i_thread
*current_thread
= SCM_I_CURRENT_THREAD
;
818 scm_i_jmp_buf registers
; /* used for prompts */
820 #ifdef HAVE_LABELS_AS_VALUES
821 static const void **jump_table_pointer
= NULL
;
822 register const void **jump_table JT_REG
;
824 if (SCM_UNLIKELY (!jump_table_pointer
))
827 jump_table_pointer
= malloc (SCM_VM_NUM_INSTRUCTIONS
* sizeof (void*));
828 for (i
= 0; i
< SCM_VM_NUM_INSTRUCTIONS
; i
++)
829 jump_table_pointer
[i
] = &&vm_error_bad_instruction
;
830 #define INIT(opcode, tag, name, meta) jump_table_pointer[opcode] = &&op_##tag;
831 FOR_EACH_VM_OPERATION(INIT
);
835 /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
836 load instruction at each instruction dispatch. */
837 jump_table
= jump_table_pointer
;
840 if (SCM_I_SETJMP (registers
))
842 /* Non-local return. The values are on the stack, on a new frame
843 set up to call `values' to return the values to the handler.
844 Cache the VM registers back from the vp, and dispatch to the
847 Note, at this point, we must assume that any variable local to
848 vm_engine that can be assigned *has* been assigned. So we need
849 to pull all our state back from the ip/fp/sp.
852 ABORT_CONTINUATION_HOOK (fp
, FRAME_LOCALS_COUNT () - 1);
856 /* Load previous VM registers. */
859 VM_HANDLE_INTERRUPTS
;
865 /* Check that we have enough space: 4 words for the boot
866 continuation, 4 + nargs for the procedure application, and 4 for
867 setting up a new frame. */
869 CHECK_OVERFLOW (vp
->sp
+ 4 + 4 + nargs_
+ 4);
871 /* Since it's possible to receive the arguments on the stack itself,
872 and indeed the regular VM invokes us that way, shuffle up the
876 for (i
= nargs_
- 1; i
>= 0; i
--)
877 base
[8 + i
] = argv
[i
];
880 /* Initial frame, saving previous fp and ip, with the boot
882 base
[0] = SCM_PACK (fp
); /* dynamic link */
883 base
[1] = SCM_PACK (0); /* the boot continuation does not return to scheme */
884 base
[2] = SCM_PACK (ip
); /* ra */
885 base
[3] = rtl_boot_continuation
;
887 ip
= (scm_t_uint32
*) rtl_boot_continuation_code
;
889 /* MV-call frame, function & arguments */
890 base
[4] = SCM_PACK (fp
); /* dynamic link */
891 base
[5] = SCM_PACK (ip
); /* in RTL programs, MVRA same as RA */
892 base
[6] = SCM_PACK (ip
); /* ra */
894 fp
= vp
->fp
= &base
[8];
895 RESET_FRAME (nargs_
+ 1);
899 while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
)))
901 SCM proc
= SCM_FRAME_PROGRAM (fp
);
903 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
905 fp
[-1] = SCM_STRUCT_PROCEDURE (proc
);
908 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
910 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
912 /* Shuffle args up. */
915 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
917 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
);
923 vm_error_wrong_type_apply (proc
);
929 ret
= VM_NAME (vm
, fp
[-1], fp
, FRAME_LOCALS_COUNT () - 1);
931 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
932 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
934 RETURN_ONE_VALUE (ret
);
940 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
943 BEGIN_DISPATCH_SWITCH
;
954 * Bring the VM to a halt, returning all the values from the stack.
956 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
958 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT() - 5;
961 /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
970 for (n
= nvals
; n
> 0; n
--)
971 ret
= scm_cons (LOCAL_REF (5 + n
- 1), ret
);
972 ret
= scm_values (ret
);
975 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
976 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
977 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
982 /* call proc:24 _:8 nlocals:24
984 * Call a procedure. PROC is the local corresponding to a procedure.
985 * The three values below PROC will be overwritten by the saved call
986 * frame data. The new frame will have space for NLOCALS locals: one
987 * for the procedure, and the rest for the arguments which should
988 * already have been pushed on.
990 * When the call returns, execution proceeds with the next
991 * instruction. There may be any number of values on the return
992 * stack; the precise number can be had by subtracting the address of
993 * PROC from the post-call SP.
995 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
997 scm_t_uint32 proc
, nlocals
;
1000 SCM_UNPACK_RTL_24 (op
, proc
);
1001 SCM_UNPACK_RTL_24 (ip
[1], nlocals
);
1003 VM_HANDLE_INTERRUPTS
;
1005 fp
= vp
->fp
= old_fp
+ proc
;
1006 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1007 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 2);
1008 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 2);
1010 RESET_FRAME (nlocals
);
1012 PUSH_CONTINUATION_HOOK ();
1015 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1018 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1022 /* tail-call nlocals:24
1024 * Tail-call a procedure. Requires that the procedure and all of the
1025 * arguments have already been shuffled into position.
1027 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
1029 scm_t_uint32 nlocals
;
1031 SCM_UNPACK_RTL_24 (op
, nlocals
);
1033 VM_HANDLE_INTERRUPTS
;
1035 RESET_FRAME (nlocals
);
1038 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1041 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1045 /* receive dst:12 proc:12 _:8 nlocals:24
1047 * Receive a single return value from a call whose procedure was in
1048 * PROC, asserting that the call actually returned at least one
1049 * value. Afterwards, resets the frame to NLOCALS locals.
1051 VM_DEFINE_OP (3, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1053 scm_t_uint16 dst
, proc
;
1054 scm_t_uint32 nlocals
;
1055 SCM_UNPACK_RTL_12_12 (op
, dst
, proc
);
1056 SCM_UNPACK_RTL_24 (ip
[1], nlocals
);
1057 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
1058 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
1059 RESET_FRAME (nlocals
);
1063 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
1065 * Receive a return of multiple values from a call whose procedure was
1066 * in PROC. If fewer than NVALUES values were returned, signal an
1067 * error. Unless ALLOW-EXTRA? is true, require that the number of
1068 * return values equals NVALUES exactly. After receive-values has
1069 * run, the values can be copied down via `mov'.
1071 VM_DEFINE_OP (4, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
1073 scm_t_uint32 proc
, nvalues
;
1074 SCM_UNPACK_RTL_24 (op
, proc
);
1075 SCM_UNPACK_RTL_24 (ip
[1], nvalues
);
1077 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
1078 vm_error_not_enough_values ());
1080 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ nvalues
,
1081 vm_error_wrong_number_of_values (nvalues
));
1089 VM_DEFINE_OP (5, return, "return", OP1 (U8_U24
))
1092 SCM_UNPACK_RTL_24 (op
, src
);
1093 RETURN_ONE_VALUE (LOCAL_REF (src
));
1096 /* return-values _:24
1098 * Return a number of values from a call frame. This opcode
1099 * corresponds to an application of `values' in tail position. As
1100 * with tail calls, we expect that the values have already been
1101 * shuffled down to a contiguous array starting at slot 1.
1102 * We also expect the frame has already been reset.
1104 VM_DEFINE_OP (6, return_values
, "return-values", OP1 (U8_X24
))
1106 scm_t_uint32 nvalues _GL_UNUSED
= FRAME_LOCALS_COUNT();
1109 VM_HANDLE_INTERRUPTS
;
1110 ip
= SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp
);
1111 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1113 /* Clear stack frame. */
1114 base
[-2] = SCM_BOOL_F
;
1115 base
[-3] = SCM_BOOL_F
;
1116 base
[-4] = SCM_BOOL_F
;
1118 POP_CONTINUATION_HOOK (base
, nvalues
);
1127 * Specialized call stubs
1130 /* subr-call ptr-idx:24
1132 * Call a subr, passing all locals in this frame as arguments. Fetch
1133 * the foreign pointer from PTR-IDX, a free variable. Return from the
1134 * calling frame. This instruction is part of the trampolines
1135 * created in gsubr.c, and is not generated by the compiler.
1137 VM_DEFINE_OP (7, subr_call
, "subr-call", OP1 (U8_U24
))
1139 scm_t_uint32 ptr_idx
;
1143 SCM_UNPACK_RTL_24 (op
, ptr_idx
);
1145 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
1146 subr
= SCM_POINTER_VALUE (pointer
);
1148 VM_HANDLE_INTERRUPTS
;
1151 switch (FRAME_LOCALS_COUNT () - 1)
1160 ret
= subr (fp
[0], fp
[1]);
1163 ret
= subr (fp
[0], fp
[1], fp
[2]);
1166 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3]);
1169 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4]);
1172 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
1175 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
1178 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
1181 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
1184 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
1190 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1192 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1193 /* multiple values returned to continuation */
1194 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1196 RETURN_ONE_VALUE (ret
);
1199 /* foreign-call cif-idx:12 ptr-idx:12
1201 * Call a foreign function. Fetch the CIF and foreign pointer from
1202 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1203 * frame. Arguments are taken from the stack. This instruction is
1204 * part of the trampolines created by the FFI, and is not generated by
1207 VM_DEFINE_OP (8, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
1209 scm_t_uint16 cif_idx
, ptr_idx
;
1210 SCM closure
, cif
, pointer
, ret
;
1212 SCM_UNPACK_RTL_12_12 (op
, cif_idx
, ptr_idx
);
1214 closure
= LOCAL_REF (0);
1215 cif
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
1216 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
1219 VM_HANDLE_INTERRUPTS
;
1221 // FIXME: separate args
1222 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), fp
);
1224 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1226 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1227 /* multiple values returned to continuation */
1228 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1230 RETURN_ONE_VALUE (ret
);
1233 /* continuation-call contregs:24
1235 * Return to a continuation, nonlocally. The arguments to the
1236 * continuation are taken from the stack. CONTREGS is a free variable
1237 * containing the reified continuation. This instruction is part of
1238 * the implementation of undelimited continuations, and is not
1239 * generated by the compiler.
1241 VM_DEFINE_OP (9, continuation_call
, "continuation-call", OP1 (U8_U24
))
1244 scm_t_uint32 contregs_idx
;
1246 SCM_UNPACK_RTL_24 (op
, contregs_idx
);
1249 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
1252 scm_i_check_continuation (contregs
);
1253 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
1254 scm_i_contregs_vm_cont (contregs
),
1255 FRAME_LOCALS_COUNT () - 1, fp
);
1256 scm_i_reinstate_continuation (contregs
);
1262 /* compose-continuation cont:24
1264 * Compose a partial continution with the current continuation. The
1265 * arguments to the continuation are taken from the stack. CONT is a
1266 * free variable containing the reified continuation. This
1267 * instruction is part of the implementation of partial continuations,
1268 * and is not generated by the compiler.
1270 VM_DEFINE_OP (10, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
1273 scm_t_uint32 cont_idx
;
1275 SCM_UNPACK_RTL_24 (op
, cont_idx
);
1276 vmcont
= LOCAL_REF (cont_idx
);
1279 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
1280 vm_error_continuation_not_rewindable (vmcont
));
1281 vm_reinstate_partial_continuation (vm
, vmcont
, FRAME_LOCALS_COUNT () - 1, fp
,
1282 ¤t_thread
->dynstack
,
1290 * Tail-apply the procedure in local slot 0 to the rest of the
1291 * arguments. This instruction is part of the implementation of
1292 * `apply', and is not generated by the compiler.
1294 VM_DEFINE_OP (11, tail_apply
, "tail-apply", OP1 (U8_X24
))
1296 int i
, list_idx
, list_len
, nlocals
;
1299 VM_HANDLE_INTERRUPTS
;
1301 nlocals
= FRAME_LOCALS_COUNT ();
1302 // At a minimum, there should be apply, f, and the list.
1303 VM_ASSERT (nlocals
>= 3, abort ());
1304 list_idx
= nlocals
- 1;
1305 list
= LOCAL_REF (list_idx
);
1306 list_len
= scm_ilength (list
);
1308 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
1310 nlocals
= nlocals
- 2 + list_len
;
1311 ALLOC_FRAME (nlocals
);
1313 for (i
= 1; i
< list_idx
; i
++)
1314 LOCAL_SET (i
- 1, LOCAL_REF (i
));
1316 /* Null out these slots, just in case there are less than 2 elements
1318 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
1319 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
1321 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
1322 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
1326 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1329 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1335 * Capture the current continuation, and tail-apply the procedure in
1336 * local slot 1 to it. This instruction is part of the implementation
1337 * of `call/cc', and is not generated by the compiler.
1339 VM_DEFINE_OP (12, call_cc
, "call/cc", OP1 (U8_X24
))
1342 scm_t_dynstack
*dynstack
;
1345 VM_HANDLE_INTERRUPTS
;
1348 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
1349 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1350 SCM_FRAME_DYNAMIC_LINK (fp
),
1351 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1352 SCM_FRAME_RETURN_ADDRESS (fp
),
1353 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1356 /* FIXME: Seems silly to capture the registers here, when they are
1357 already captured in the registers local, which here we are
1358 copying out to the heap; and likewise, the setjmp(®isters)
1359 code already has the non-local return handler. But oh
1361 cont
= scm_i_make_continuation (&first
, vm
, vm_cont
);
1365 LOCAL_SET (0, LOCAL_REF (1));
1366 LOCAL_SET (1, cont
);
1371 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1374 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1380 ABORT_CONTINUATION_HOOK (fp
, FRAME_LOCALS_COUNT () - 1);
1389 * Function prologues
1392 /* br-if-nargs-ne expected:24 _:8 offset:24
1393 * br-if-nargs-lt expected:24 _:8 offset:24
1394 * br-if-nargs-gt expected:24 _:8 offset:24
1396 * If the number of actual arguments is not equal, less than, or greater
1397 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1398 * the current instruction pointer.
1400 VM_DEFINE_OP (13, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1404 VM_DEFINE_OP (14, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1408 VM_DEFINE_OP (15, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1413 /* assert-nargs-ee expected:24
1414 * assert-nargs-ge expected:24
1415 * assert-nargs-le expected:24
1417 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1418 * respectively, signal an error.
1420 VM_DEFINE_OP (16, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1422 scm_t_uint32 expected
;
1423 SCM_UNPACK_RTL_24 (op
, expected
);
1424 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1425 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1428 VM_DEFINE_OP (17, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1430 scm_t_uint32 expected
;
1431 SCM_UNPACK_RTL_24 (op
, expected
);
1432 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1433 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1436 VM_DEFINE_OP (18, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1438 scm_t_uint32 expected
;
1439 SCM_UNPACK_RTL_24 (op
, expected
);
1440 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1441 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1445 /* alloc-frame nlocals:24
1447 * Ensure that there is space on the stack for NLOCALS local variables,
1448 * setting them all to SCM_UNDEFINED, except those nargs values that
1449 * were passed as arguments and procedure.
1451 VM_DEFINE_OP (19, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1453 scm_t_uint32 nlocals
, nargs
;
1454 SCM_UNPACK_RTL_24 (op
, nlocals
);
1456 nargs
= FRAME_LOCALS_COUNT ();
1457 ALLOC_FRAME (nlocals
);
1458 while (nlocals
-- > nargs
)
1459 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1464 /* reset-frame nlocals:24
1466 * Like alloc-frame, but doesn't check that the stack is big enough.
1467 * Used to reset the frame size to something less than the size that
1468 * was previously set via alloc-frame.
1470 VM_DEFINE_OP (20, reset_frame
, "reset-frame", OP1 (U8_U24
))
1472 scm_t_uint32 nlocals
;
1473 SCM_UNPACK_RTL_24 (op
, nlocals
);
1474 RESET_FRAME (nlocals
);
1478 /* assert-nargs-ee/locals expected:12 nlocals:12
1480 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1481 * number of locals reserved is EXPECTED + NLOCALS.
1483 VM_DEFINE_OP (21, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1485 scm_t_uint16 expected
, nlocals
;
1486 SCM_UNPACK_RTL_12_12 (op
, expected
, nlocals
);
1487 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1488 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1489 ALLOC_FRAME (expected
+ nlocals
);
1491 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1496 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1497 * _:8 ntotal:24 kw-offset:32
1499 * Find the last positional argument, and shuffle all the rest above
1500 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1501 * load the constant at KW-OFFSET words from the current IP, and use it
1502 * to bind keyword arguments. If HAS-REST, collect all shuffled
1503 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1504 * the arguments that we shuffled up.
1506 * A macro-mega-instruction.
1508 VM_DEFINE_OP (22, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1510 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1511 scm_t_int32 kw_offset
;
1514 char allow_other_keys
, has_rest
;
1516 SCM_UNPACK_RTL_24 (op
, nreq
);
1517 allow_other_keys
= ip
[1] & 0x1;
1518 has_rest
= ip
[1] & 0x2;
1519 SCM_UNPACK_RTL_24 (ip
[1], nreq_and_opt
);
1520 SCM_UNPACK_RTL_24 (ip
[2], ntotal
);
1522 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1523 VM_ASSERT (!(kw_bits
& 0x7), abort());
1524 kw
= SCM_PACK (kw_bits
);
1526 nargs
= FRAME_LOCALS_COUNT ();
1528 /* look in optionals for first keyword or last positional */
1529 /* starting after the last required positional arg */
1531 while (/* while we have args */
1533 /* and we still have positionals to fill */
1534 && npositional
< nreq_and_opt
1535 /* and we haven't reached a keyword yet */
1536 && !scm_is_keyword (LOCAL_REF (npositional
)))
1537 /* bind this optional arg (by leaving it in place) */
1539 nkw
= nargs
- npositional
;
1540 /* shuffle non-positional arguments above ntotal */
1541 ALLOC_FRAME (ntotal
+ nkw
);
1544 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1545 /* and fill optionals & keyword args with SCM_UNDEFINED */
1548 LOCAL_SET (n
++, SCM_UNDEFINED
);
1550 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1551 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1553 /* Now bind keywords, in the order given. */
1554 for (n
= 0; n
< nkw
; n
++)
1555 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1558 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1559 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1561 SCM si
= SCM_CDAR (walk
);
1562 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1563 LOCAL_REF (ntotal
+ n
+ 1));
1566 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1567 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1568 LOCAL_REF (ntotal
+ n
)));
1572 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1573 LOCAL_REF (ntotal
+ n
)));
1580 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1581 LOCAL_SET (nreq_and_opt
, rest
);
1584 RESET_FRAME (ntotal
);
1591 * Collect any arguments at or above DST into a list, and store that
1594 VM_DEFINE_OP (23, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1596 scm_t_uint32 dst
, nargs
;
1599 SCM_UNPACK_RTL_24 (op
, dst
);
1600 nargs
= FRAME_LOCALS_COUNT ();
1604 ALLOC_FRAME (dst
+ 1);
1606 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1610 while (nargs
-- > dst
)
1612 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1613 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1616 RESET_FRAME (dst
+ 1);
1619 LOCAL_SET (dst
, rest
);
1628 * Branching instructions
1633 * Add OFFSET, a signed 24-bit number, to the current instruction
1636 VM_DEFINE_OP (24, br
, "br", OP1 (U8_L24
))
1638 scm_t_int32 offset
= op
;
1639 offset
>>= 8; /* Sign-extending shift. */
1643 /* br-if-true test:24 invert:1 _:7 offset:24
1645 * If the value in TEST is true for the purposes of Scheme, add
1646 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1648 VM_DEFINE_OP (25, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1650 BR_UNARY (x
, scm_is_true (x
));
1653 /* br-if-null test:24 invert:1 _:7 offset:24
1655 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1656 * signed 24-bit number, to the current instruction pointer.
1658 VM_DEFINE_OP (26, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1660 BR_UNARY (x
, scm_is_null (x
));
1663 /* br-if-nil test:24 invert:1 _:7 offset:24
1665 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1666 * number, to the current instruction pointer.
1668 VM_DEFINE_OP (27, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1670 BR_UNARY (x
, scm_is_lisp_false (x
));
1673 /* br-if-pair test:24 invert:1 _:7 offset:24
1675 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1676 * to the current instruction pointer.
1678 VM_DEFINE_OP (28, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1680 BR_UNARY (x
, scm_is_pair (x
));
1683 /* br-if-struct test:24 invert:1 _:7 offset:24
1685 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1686 * number, to the current instruction pointer.
1688 VM_DEFINE_OP (29, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1690 BR_UNARY (x
, SCM_STRUCTP (x
));
1693 /* br-if-char test:24 invert:1 _:7 offset:24
1695 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1696 * to the current instruction pointer.
1698 VM_DEFINE_OP (30, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1700 BR_UNARY (x
, SCM_CHARP (x
));
1703 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1705 * If the value in TEST has the TC7 given in the second word, add
1706 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1708 VM_DEFINE_OP (31, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1710 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1713 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1715 * If the value in A is eq? to the value in B, add OFFSET, a signed
1716 * 24-bit number, to the current instruction pointer.
1718 VM_DEFINE_OP (32, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1720 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1723 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1725 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1726 * 24-bit number, to the current instruction pointer.
1728 VM_DEFINE_OP (33, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1732 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1733 && scm_is_true (scm_eqv_p (x
, y
))));
1736 // FIXME: remove, have compiler inline eqv test instead
1737 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1739 * If the value in A is equal? to the value in B, add OFFSET, a signed
1740 * 24-bit number, to the current instruction pointer.
1742 // FIXME: should sync_ip before calling out?
1743 VM_DEFINE_OP (34, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1747 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1748 && scm_is_true (scm_equal_p (x
, y
))));
1751 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1753 * If the value in A is = to the value in B, add OFFSET, a signed
1754 * 24-bit number, to the current instruction pointer.
1756 VM_DEFINE_OP (35, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1758 BR_ARITHMETIC (==, scm_num_eq_p
);
1761 /* br-if-< a:12 b:12 _:8 offset:24
1763 * If the value in A is < to the value in B, add OFFSET, a signed
1764 * 24-bit number, to the current instruction pointer.
1766 VM_DEFINE_OP (36, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1768 BR_ARITHMETIC (<, scm_less_p
);
1771 /* br-if-<= a:12 b:12 _:8 offset:24
1773 * If the value in A is <= to the value in B, add OFFSET, a signed
1774 * 24-bit number, to the current instruction pointer.
1776 VM_DEFINE_OP (37, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1778 BR_ARITHMETIC (<=, scm_leq_p
);
1785 * Lexical binding instructions
1788 /* mov dst:12 src:12
1790 * Copy a value from one local slot to another.
1792 VM_DEFINE_OP (38, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1797 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1798 LOCAL_SET (dst
, LOCAL_REF (src
));
1803 /* long-mov dst:24 _:8 src:24
1805 * Copy a value from one local slot to another.
1807 VM_DEFINE_OP (39, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1812 SCM_UNPACK_RTL_24 (op
, dst
);
1813 SCM_UNPACK_RTL_24 (ip
[1], src
);
1814 LOCAL_SET (dst
, LOCAL_REF (src
));
1819 /* box dst:12 src:12
1821 * Create a new variable holding SRC, and place it in DST.
1823 VM_DEFINE_OP (40, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1825 scm_t_uint16 dst
, src
;
1826 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1827 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1831 /* box-ref dst:12 src:12
1833 * Unpack the variable at SRC into DST, asserting that the variable is
1836 VM_DEFINE_OP (41, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1838 scm_t_uint16 dst
, src
;
1840 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1841 var
= LOCAL_REF (src
);
1842 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1843 VM_ASSERT (VARIABLE_BOUNDP (var
),
1844 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1845 LOCAL_SET (dst
, VARIABLE_REF (var
));
1849 /* box-set! dst:12 src:12
1851 * Set the contents of the variable at DST to SET.
1853 VM_DEFINE_OP (42, box_set
, "box-set!", OP1 (U8_U12_U12
))
1855 scm_t_uint16 dst
, src
;
1857 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1858 var
= LOCAL_REF (dst
);
1859 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1860 VARIABLE_SET (var
, LOCAL_REF (src
));
1864 /* make-closure dst:24 offset:32 _:8 nfree:24
1866 * Make a new closure, and write it to DST. The code for the closure
1867 * will be found at OFFSET words from the current IP. OFFSET is a
1868 * signed 32-bit integer. Space for NFREE free variables will be
1871 VM_DEFINE_OP (43, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1873 scm_t_uint32 dst
, nfree
, n
;
1877 SCM_UNPACK_RTL_24 (op
, dst
);
1879 SCM_UNPACK_RTL_24 (ip
[2], nfree
);
1881 // FIXME: Assert range of nfree?
1882 closure
= scm_words (scm_tc7_rtl_program
| (nfree
<< 16), nfree
+ 2);
1883 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1884 // FIXME: Elide these initializations?
1885 for (n
= 0; n
< nfree
; n
++)
1886 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1887 LOCAL_SET (dst
, closure
);
1891 /* free-ref dst:12 src:12 _:8 idx:24
1893 * Load free variable IDX from the closure SRC into local slot DST.
1895 VM_DEFINE_OP (44, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1897 scm_t_uint16 dst
, src
;
1899 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1900 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1901 /* CHECK_FREE_VARIABLE (src); */
1902 LOCAL_SET (dst
, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1906 /* free-set! dst:12 src:12 _8 idx:24
1908 * Set free variable IDX from the closure DST to SRC.
1910 VM_DEFINE_OP (45, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1912 scm_t_uint16 dst
, src
;
1914 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1915 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1916 /* CHECK_FREE_VARIABLE (src); */
1917 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1925 * Immediates and statically allocated non-immediates
1928 /* make-short-immediate dst:8 low-bits:16
1930 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1933 VM_DEFINE_OP (46, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1938 SCM_UNPACK_RTL_8_16 (op
, dst
, val
);
1939 LOCAL_SET (dst
, SCM_PACK (val
));
1943 /* make-long-immediate dst:24 low-bits:32
1945 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1948 VM_DEFINE_OP (47, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1953 SCM_UNPACK_RTL_24 (op
, dst
);
1955 LOCAL_SET (dst
, SCM_PACK (val
));
1959 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1961 * Make an immediate with HIGH-BITS and LOW-BITS.
1963 VM_DEFINE_OP (48, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1968 SCM_UNPACK_RTL_24 (op
, dst
);
1969 #if SIZEOF_SCM_T_BITS > 4
1974 ASSERT (ip
[1] == 0);
1977 LOCAL_SET (dst
, SCM_PACK (val
));
1981 /* make-non-immediate dst:24 offset:32
1983 * Load a pointer to statically allocated memory into DST. The
1984 * object's memory is will be found OFFSET 32-bit words away from the
1985 * current instruction pointer. OFFSET is a signed value. The
1986 * intention here is that the compiler would produce an object file
1987 * containing the words of a non-immediate object, and this
1988 * instruction creates a pointer to that memory, effectively
1989 * resurrecting that object.
1991 * Whether the object is mutable or immutable depends on where it was
1992 * allocated by the compiler, and loaded by the loader.
1994 VM_DEFINE_OP (49, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1999 scm_t_bits unpacked
;
2001 SCM_UNPACK_RTL_24 (op
, dst
);
2004 unpacked
= (scm_t_bits
) loc
;
2006 VM_ASSERT (!(unpacked
& 0x7), abort());
2008 LOCAL_SET (dst
, SCM_PACK (unpacked
));
2013 /* static-ref dst:24 offset:32
2015 * Load a SCM value into DST. The SCM value will be fetched from
2016 * memory, OFFSET 32-bit words away from the current instruction
2017 * pointer. OFFSET is a signed value.
2019 * The intention is for this instruction to be used to load constants
2020 * that the compiler is unable to statically allocate, like symbols.
2021 * These values would be initialized when the object file loads.
2023 VM_DEFINE_OP (50, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
2028 scm_t_uintptr loc_bits
;
2030 SCM_UNPACK_RTL_24 (op
, dst
);
2033 loc_bits
= (scm_t_uintptr
) loc
;
2034 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2036 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
2041 /* static-set! src:24 offset:32
2043 * Store a SCM value into memory, OFFSET 32-bit words away from the
2044 * current instruction pointer. OFFSET is a signed value.
2046 VM_DEFINE_OP (51, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
2052 SCM_UNPACK_RTL_24 (op
, src
);
2055 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2057 *((SCM
*) loc
) = LOCAL_REF (src
);
2062 /* link-procedure! src:24 offset:32
2064 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2065 * words away from the current instruction pointer. OFFSET is a
2068 VM_DEFINE_OP (52, link_procedure
, "link-procedure!", OP2 (U8_U24
, L32
))
2074 SCM_UNPACK_RTL_24 (op
, src
);
2078 SCM_SET_CELL_WORD_1 (LOCAL_REF (src
), (scm_t_bits
) loc
);
2086 * Mutable top-level bindings
2089 /* There are three slightly different ways to resolve toplevel
2092 1. A toplevel reference outside of a function. These need to be
2093 looked up when the expression is evaluated -- no later, and no
2094 before. They are looked up relative to the module that is
2095 current when the expression is evaluated. For example:
2099 The "resolve" instruction resolves the variable (box), and then
2100 access is via box-ref or box-set!.
2102 2. A toplevel reference inside a function. These are looked up
2103 relative to the module that was current when the function was
2104 defined. Unlike code at the toplevel, which is usually run only
2105 once, these bindings benefit from memoized lookup, in which the
2106 variable resulting from the lookup is cached in the function.
2108 (lambda () (if (foo) a b))
2110 The toplevel-box instruction is equivalent to "resolve", but
2111 caches the resulting variable in statically allocated memory.
2113 3. A reference to an identifier with respect to a particular
2114 module. This can happen for primitive references, and
2115 references residualized by macro expansions. These can always
2116 be cached. Use module-box for these.
2119 /* current-module dst:24
2121 * Store the current module in DST.
2123 VM_DEFINE_OP (53, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
2127 SCM_UNPACK_RTL_24 (op
, dst
);
2130 LOCAL_SET (dst
, scm_current_module ());
2135 /* resolve dst:24 bound?:1 _:7 sym:24
2137 * Resolve SYM in the current module, and place the resulting variable
2140 VM_DEFINE_OP (54, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
2146 SCM_UNPACK_RTL_24 (op
, dst
);
2147 SCM_UNPACK_RTL_24 (ip
[1], sym
);
2150 var
= scm_lookup (LOCAL_REF (sym
));
2152 VM_ASSERT (VARIABLE_BOUNDP (var
),
2153 vm_error_unbound (fp
[-1], LOCAL_REF (sym
)));
2154 LOCAL_SET (dst
, var
);
2159 /* define sym:12 val:12
2161 * Look up a binding for SYM in the current module, creating it if
2162 * necessary. Set its value to VAL.
2164 VM_DEFINE_OP (55, define
, "define", OP1 (U8_U12_U12
))
2166 scm_t_uint16 sym
, val
;
2167 SCM_UNPACK_RTL_12_12 (op
, sym
, val
);
2169 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
2173 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2175 * Load a SCM value. The SCM value will be fetched from memory,
2176 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2177 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
2180 * Then, if the loaded value is a variable, it is placed in DST, and control
2183 * Otherwise, we have to resolve the variable. In that case we load
2184 * the module from MOD-OFFSET, just as we loaded the variable.
2185 * Usually the module gets set when the closure is created. The name
2186 * is an offset to a symbol.
2188 * We use the module and the symbol to resolve the variable, placing it in
2189 * DST, and caching the resolved variable so that we will hit the cache next
2192 VM_DEFINE_OP (56, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
2195 scm_t_int32 var_offset
;
2196 scm_t_uint32
* var_loc_u32
;
2200 SCM_UNPACK_RTL_24 (op
, dst
);
2202 var_loc_u32
= ip
+ var_offset
;
2203 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2204 var_loc
= (SCM
*) var_loc_u32
;
2207 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2210 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2211 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2212 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2213 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2217 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2218 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2220 mod
= *((SCM
*) mod_loc
);
2221 sym
= *((SCM
*) sym_loc
);
2223 /* If the toplevel scope was captured before modules were
2224 booted, use the root module. */
2225 if (scm_is_false (mod
))
2226 mod
= scm_the_root_module ();
2228 var
= scm_module_lookup (mod
, sym
);
2230 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2235 LOCAL_SET (dst
, var
);
2239 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2241 * Like toplevel-box, except MOD-OFFSET points at the name of a module
2242 * instead of the module itself.
2244 VM_DEFINE_OP (57, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
2247 scm_t_int32 var_offset
;
2248 scm_t_uint32
* var_loc_u32
;
2252 SCM_UNPACK_RTL_24 (op
, dst
);
2254 var_loc_u32
= ip
+ var_offset
;
2255 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2256 var_loc
= (SCM
*) var_loc_u32
;
2259 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2262 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2263 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2264 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2265 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2269 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2270 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2272 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2273 sym
= *((SCM
*) sym_loc
);
2275 if (!scm_module_system_booted_p
)
2277 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
2280 scm_equal_p (modname
,
2281 scm_list_2 (SCM_BOOL_T
,
2282 scm_from_utf8_symbol ("guile"))));
2284 var
= scm_lookup (sym
);
2286 else if (scm_is_true (SCM_CAR (modname
)))
2287 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2289 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2292 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2297 LOCAL_SET (dst
, var
);
2304 * The dynamic environment
2307 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2309 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2310 * handler at HANDLER-OFFSET words from the current IP. The handler
2311 * will expect a multiple-value return as if from a call with the
2312 * procedure at PROC-SLOT.
2314 VM_DEFINE_OP (58, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2316 scm_t_uint32 tag
, proc_slot
;
2318 scm_t_uint8 escape_only_p
;
2319 scm_t_dynstack_prompt_flags flags
;
2321 SCM_UNPACK_RTL_24 (op
, tag
);
2322 escape_only_p
= ip
[1] & 0x1;
2323 SCM_UNPACK_RTL_24 (ip
[1], proc_slot
);
2325 offset
>>= 8; /* Sign extension */
2327 /* Push the prompt onto the dynamic stack. */
2328 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2329 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2332 &LOCAL_REF (proc_slot
),
2333 (scm_t_uint8
*)(ip
+ offset
),
2338 /* wind winder:12 unwinder:12
2340 * Push wind and unwind procedures onto the dynamic stack. Note that
2341 * neither are actually called; the compiler should emit calls to wind
2342 * and unwind for the normal dynamic-wind control flow. Also note that
2343 * the compiler should have inserted checks that they wind and unwind
2344 * procs are thunks, if it could not prove that to be the case.
2346 VM_DEFINE_OP (59, wind
, "wind", OP1 (U8_U12_U12
))
2348 scm_t_uint16 winder
, unwinder
;
2349 SCM_UNPACK_RTL_12_12 (op
, winder
, unwinder
);
2350 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2351 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2355 /* abort tag:24 _:8 proc:24
2357 * Return a number of values to a prompt handler. The values are
2358 * expected in a frame pushed on at PROC.
2360 VM_DEFINE_OP (60, abort
, "abort", OP2 (U8_U24
, X8_U24
))
2363 scm_t_uint32 tag
, from
, nvalues
;
2366 SCM_UNPACK_RTL_24 (op
, tag
);
2367 SCM_UNPACK_RTL_24 (ip
[1], from
);
2368 base
= (fp
- 1) + from
+ 3;
2369 nvalues
= FRAME_LOCALS_COUNT () - from
- 3;
2372 vm_abort (vm
, LOCAL_REF (tag
), base
, nvalues
, ®isters
);
2374 /* vm_abort should not return */
2383 * A normal exit from the dynamic extent of an expression. Pop the top
2384 * entry off of the dynamic stack.
2386 VM_DEFINE_OP (61, unwind
, "unwind", OP1 (U8_X24
))
2388 scm_dynstack_pop (¤t_thread
->dynstack
);
2392 /* push-fluid fluid:12 value:12
2394 * Dynamically bind N fluids to values. The fluids are expected to be
2395 * allocated in a continguous range on the stack, starting from
2396 * FLUID-BASE. The values do not have this restriction.
2398 VM_DEFINE_OP (62, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2400 scm_t_uint32 fluid
, value
;
2402 SCM_UNPACK_RTL_12_12 (op
, fluid
, value
);
2404 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2405 fp
[fluid
], fp
[value
],
2406 current_thread
->dynamic_state
);
2412 * Leave the dynamic extent of a with-fluids expression, restoring the
2413 * fluids to their previous values.
2415 VM_DEFINE_OP (63, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2417 /* This function must not allocate. */
2418 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2419 current_thread
->dynamic_state
);
2423 /* fluid-ref dst:12 src:12
2425 * Reference the fluid in SRC, and place the value in DST.
2427 VM_DEFINE_OP (64, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2429 scm_t_uint16 dst
, src
;
2433 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2434 fluid
= LOCAL_REF (src
);
2435 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2436 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2437 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2439 /* Punt dynstate expansion and error handling to the C proc. */
2441 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2445 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2446 if (scm_is_eq (val
, SCM_UNDEFINED
))
2447 val
= SCM_I_FLUID_DEFAULT (fluid
);
2448 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2449 vm_error_unbound_fluid (program
, fluid
));
2450 LOCAL_SET (dst
, val
);
2456 /* fluid-set fluid:12 val:12
2458 * Set the value of the fluid in DST to the value in SRC.
2460 VM_DEFINE_OP (65, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2466 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2467 fluid
= LOCAL_REF (a
);
2468 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2469 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2470 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2472 /* Punt dynstate expansion and error handling to the C proc. */
2474 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2477 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2486 * Strings, symbols, and keywords
2489 /* string-length dst:12 src:12
2491 * Store the length of the string in SRC in DST.
2493 VM_DEFINE_OP (66, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2496 if (SCM_LIKELY (scm_is_string (str
)))
2497 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2501 RETURN (scm_string_length (str
));
2505 /* string-ref dst:8 src:8 idx:8
2507 * Fetch the character at position IDX in the string in SRC, and store
2510 VM_DEFINE_OP (67, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2512 scm_t_signed_bits i
= 0;
2514 if (SCM_LIKELY (scm_is_string (str
)
2515 && SCM_I_INUMP (idx
)
2516 && ((i
= SCM_I_INUM (idx
)) >= 0)
2517 && i
< scm_i_string_length (str
)))
2518 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2522 RETURN (scm_string_ref (str
, idx
));
2526 /* No string-set! instruction, as there is no good fast path there. */
2528 /* string-to-number dst:12 src:12
2530 * Parse a string in SRC to a number, and store in DST.
2532 VM_DEFINE_OP (68, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2534 scm_t_uint16 dst
, src
;
2536 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2539 scm_string_to_number (LOCAL_REF (src
),
2540 SCM_UNDEFINED
/* radix = 10 */));
2544 /* string-to-symbol dst:12 src:12
2546 * Parse a string in SRC to a symbol, and store in DST.
2548 VM_DEFINE_OP (69, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2550 scm_t_uint16 dst
, src
;
2552 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2554 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2558 /* symbol->keyword dst:12 src:12
2560 * Make a keyword from the symbol in SRC, and store it in DST.
2562 VM_DEFINE_OP (70, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2564 scm_t_uint16 dst
, src
;
2565 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2567 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2577 /* cons dst:8 car:8 cdr:8
2579 * Cons CAR and CDR, and store the result in DST.
2581 VM_DEFINE_OP (71, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2584 RETURN (scm_cons (x
, y
));
2587 /* car dst:12 src:12
2589 * Place the car of SRC in DST.
2591 VM_DEFINE_OP (72, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2594 VM_VALIDATE_PAIR (x
, "car");
2595 RETURN (SCM_CAR (x
));
2598 /* cdr dst:12 src:12
2600 * Place the cdr of SRC in DST.
2602 VM_DEFINE_OP (73, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2605 VM_VALIDATE_PAIR (x
, "cdr");
2606 RETURN (SCM_CDR (x
));
2609 /* set-car! pair:12 car:12
2611 * Set the car of DST to SRC.
2613 VM_DEFINE_OP (74, set_car
, "set-car!", OP1 (U8_U12_U12
))
2617 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2620 VM_VALIDATE_PAIR (x
, "set-car!");
2625 /* set-cdr! pair:12 cdr:12
2627 * Set the cdr of DST to SRC.
2629 VM_DEFINE_OP (75, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2633 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2636 VM_VALIDATE_PAIR (x
, "set-car!");
2645 * Numeric operations
2648 /* add dst:8 a:8 b:8
2650 * Add A to B, and place the result in DST.
2652 VM_DEFINE_OP (76, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2654 BINARY_INTEGER_OP (+, scm_sum
);
2657 /* add1 dst:12 src:12
2659 * Add 1 to the value in SRC, and place the result in DST.
2661 VM_DEFINE_OP (77, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2665 /* Check for overflow. We must avoid overflow in the signed
2666 addition below, even if X is not an inum. */
2667 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2671 /* Add 1 to the integer without untagging. */
2672 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2674 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2679 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2682 /* sub dst:8 a:8 b:8
2684 * Subtract B from A, and place the result in DST.
2686 VM_DEFINE_OP (78, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2688 BINARY_INTEGER_OP (-, scm_difference
);
2691 /* sub1 dst:12 src:12
2693 * Subtract 1 from SRC, and place the result in DST.
2695 VM_DEFINE_OP (79, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2699 /* Check for overflow. We must avoid overflow in the signed
2700 subtraction below, even if X is not an inum. */
2701 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2705 /* Substract 1 from the integer without untagging. */
2706 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2708 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2713 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2716 /* mul dst:8 a:8 b:8
2718 * Multiply A and B, and place the result in DST.
2720 VM_DEFINE_OP (80, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2724 RETURN (scm_product (x
, y
));
2727 /* div dst:8 a:8 b:8
2729 * Divide A by B, and place the result in DST.
2731 VM_DEFINE_OP (81, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2735 RETURN (scm_divide (x
, y
));
2738 /* quo dst:8 a:8 b:8
2740 * Divide A by B, and place the quotient in DST.
2742 VM_DEFINE_OP (82, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2746 RETURN (scm_quotient (x
, y
));
2749 /* rem dst:8 a:8 b:8
2751 * Divide A by B, and place the remainder in DST.
2753 VM_DEFINE_OP (83, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2757 RETURN (scm_remainder (x
, y
));
2760 /* mod dst:8 a:8 b:8
2762 * Place the modulo of A by B in DST.
2764 VM_DEFINE_OP (84, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2768 RETURN (scm_modulo (x
, y
));
2771 /* ash dst:8 a:8 b:8
2773 * Shift A arithmetically by B bits, and place the result in DST.
2775 VM_DEFINE_OP (85, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2778 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2780 if (SCM_I_INUM (y
) < 0)
2781 /* Right shift, will be a fixnum. */
2782 RETURN (SCM_I_MAKINUM
2783 (SCM_SRS (SCM_I_INUM (x
),
2784 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2785 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2787 /* Left shift. See comments in scm_ash. */
2789 scm_t_signed_bits nn
, bits_to_shift
;
2791 nn
= SCM_I_INUM (x
);
2792 bits_to_shift
= SCM_I_INUM (y
);
2794 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2796 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2798 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2804 RETURN (scm_ash (x
, y
));
2807 /* logand dst:8 a:8 b:8
2809 * Place the bitwise AND of A and B into DST.
2811 VM_DEFINE_OP (86, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2814 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2815 /* Compute bitwise AND without untagging */
2816 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2818 RETURN (scm_logand (x
, y
));
2821 /* logior dst:8 a:8 b:8
2823 * Place the bitwise inclusive OR of A with B in DST.
2825 VM_DEFINE_OP (87, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2828 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2829 /* Compute bitwise OR without untagging */
2830 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2832 RETURN (scm_logior (x
, y
));
2835 /* logxor dst:8 a:8 b:8
2837 * Place the bitwise exclusive OR of A with B in DST.
2839 VM_DEFINE_OP (88, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2842 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2843 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2845 RETURN (scm_logxor (x
, y
));
2848 /* vector-length dst:12 src:12
2850 * Store the length of the vector in SRC in DST.
2852 VM_DEFINE_OP (89, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2855 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2856 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2860 RETURN (scm_vector_length (vect
));
2864 /* vector-ref dst:8 src:8 idx:8
2866 * Fetch the item at position IDX in the vector in SRC, and store it
2869 VM_DEFINE_OP (90, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2871 scm_t_signed_bits i
= 0;
2873 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2874 && SCM_I_INUMP (idx
)
2875 && ((i
= SCM_I_INUM (idx
)) >= 0)
2876 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2877 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2881 RETURN (scm_vector_ref (vect
, idx
));
2885 /* constant-vector-ref dst:8 src:8 idx:8
2887 * Fill DST with the item IDX elements into the vector at SRC. Useful
2888 * for building data types using vectors.
2890 VM_DEFINE_OP (91, constant_vector_ref
, "constant-vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2892 scm_t_uint8 dst
, src
, idx
;
2895 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
2896 v
= LOCAL_REF (src
);
2897 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2898 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2899 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2901 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2905 /* vector-set! dst:8 idx:8 src:8
2907 * Store SRC into the vector DST at index IDX.
2909 VM_DEFINE_OP (92, vector_set
, "vector-set", OP1 (U8_U8_U8_U8
))
2911 scm_t_uint8 dst
, idx_var
, src
;
2913 scm_t_signed_bits i
= 0;
2915 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx_var
, src
);
2916 vect
= LOCAL_REF (dst
);
2917 idx
= LOCAL_REF (idx_var
);
2918 val
= LOCAL_REF (src
);
2920 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2921 && SCM_I_INUMP (idx
)
2922 && ((i
= SCM_I_INUM (idx
)) >= 0)
2923 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2924 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2928 scm_vector_set_x (vect
, idx
, val
);
2940 /* struct-vtable dst:12 src:12
2942 * Store the vtable of SRC into DST.
2944 VM_DEFINE_OP (93, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2947 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2948 RETURN (SCM_STRUCT_VTABLE (obj
));
2951 /* allocate-struct dst:8 vtable:8 nfields:8
2953 * Allocate a new struct with VTABLE, and place it in DST. The struct
2954 * will be constructed with space for NFIELDS fields, which should
2955 * correspond to the field count of the VTABLE.
2957 VM_DEFINE_OP (94, allocate_struct
, "allocate-struct", OP1 (U8_U8_U8_U8
) | OP_DST
)
2959 scm_t_uint8 dst
, vtable
, nfields
;
2962 SCM_UNPACK_RTL_8_8_8 (op
, dst
, vtable
, nfields
);
2965 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2966 LOCAL_SET (dst
, ret
);
2971 /* struct-ref dst:8 src:8 idx:8
2973 * Fetch the item at slot IDX in the struct in SRC, and store it
2976 VM_DEFINE_OP (95, struct_ref
, "struct-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2980 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2981 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2982 SCM_VTABLE_FLAG_SIMPLE
)
2983 && SCM_I_INUMP (pos
)))
2986 scm_t_bits index
, len
;
2988 /* True, an inum is a signed value, but cast to unsigned it will
2989 certainly be more than the length, so we will fall through if
2990 index is negative. */
2991 index
= SCM_I_INUM (pos
);
2992 vtable
= SCM_STRUCT_VTABLE (obj
);
2993 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
2995 if (SCM_LIKELY (index
< len
))
2997 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
2998 RETURN (SCM_PACK (data
[index
]));
3003 RETURN (scm_struct_ref (obj
, pos
));
3006 /* struct-set! dst:8 idx:8 src:8
3008 * Store SRC into the struct DST at slot IDX.
3010 VM_DEFINE_OP (96, struct_set
, "struct-set!", OP1 (U8_U8_U8_U8
))
3012 scm_t_uint8 dst
, idx
, src
;
3015 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3016 obj
= LOCAL_REF (dst
);
3017 pos
= LOCAL_REF (idx
);
3018 val
= LOCAL_REF (src
);
3020 if (SCM_LIKELY (SCM_STRUCTP (obj
)
3021 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3022 SCM_VTABLE_FLAG_SIMPLE
)
3023 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
3024 SCM_VTABLE_FLAG_SIMPLE_RW
)
3025 && SCM_I_INUMP (pos
)))
3028 scm_t_bits index
, len
;
3030 /* See above regarding index being >= 0. */
3031 index
= SCM_I_INUM (pos
);
3032 vtable
= SCM_STRUCT_VTABLE (obj
);
3033 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3034 if (SCM_LIKELY (index
< len
))
3036 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3037 data
[index
] = SCM_UNPACK (val
);
3043 scm_struct_set_x (obj
, pos
, val
);
3047 /* class-of dst:12 type:12
3049 * Store the vtable of SRC into DST.
3051 VM_DEFINE_OP (97, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
3054 if (SCM_INSTANCEP (obj
))
3055 RETURN (SCM_CLASS_OF (obj
));
3057 RETURN (scm_class_of (obj
));
3060 /* slot-ref dst:8 src:8 idx:8
3062 * Fetch the item at slot IDX in the struct in SRC, and store it in
3063 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3064 * index into the stack.
3066 VM_DEFINE_OP (98, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3068 scm_t_uint8 dst
, src
, idx
;
3069 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3071 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
3075 /* slot-set! dst:8 idx:8 src:8
3077 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3078 * IDX is an 8-bit immediate value, not an index into the stack.
3080 VM_DEFINE_OP (99, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
3082 scm_t_uint8 dst
, idx
, src
;
3083 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3084 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
3092 * Arrays, packed uniform arrays, and bytevectors.
3095 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3097 * Load the contiguous typed array located at OFFSET 32-bit words away
3098 * from the instruction pointer, and store into DST. LEN is a byte
3099 * length. OFFSET is signed.
3101 VM_DEFINE_OP (100, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
3103 scm_t_uint8 dst
, type
, shape
;
3107 SCM_UNPACK_RTL_8_8_8 (op
, dst
, type
, shape
);
3111 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
3117 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3119 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3121 VM_DEFINE_OP (101, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
3123 scm_t_uint16 dst
, type
, fill
, bounds
;
3124 SCM_UNPACK_RTL_12_12 (op
, dst
, type
);
3125 SCM_UNPACK_RTL_12_12 (ip
[1], fill
, bounds
);
3127 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
3128 LOCAL_REF (bounds
)));
3132 /* bv-u8-ref dst:8 src:8 idx:8
3133 * bv-s8-ref dst:8 src:8 idx:8
3134 * bv-u16-ref dst:8 src:8 idx:8
3135 * bv-s16-ref dst:8 src:8 idx:8
3136 * bv-u32-ref dst:8 src:8 idx:8
3137 * bv-s32-ref dst:8 src:8 idx:8
3138 * bv-u64-ref dst:8 src:8 idx:8
3139 * bv-s64-ref dst:8 src:8 idx:8
3140 * bv-f32-ref dst:8 src:8 idx:8
3141 * bv-f64-ref dst:8 src:8 idx:8
3143 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3144 * it in DST. All accesses use native endianness.
3146 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3148 scm_t_signed_bits i; \
3149 const scm_t_ ## type *int_ptr; \
3152 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3153 i = SCM_I_INUM (idx); \
3154 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3156 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3158 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3159 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3160 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3164 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3168 #define BV_INT_REF(stem, type, size) \
3170 scm_t_signed_bits i; \
3171 const scm_t_ ## type *int_ptr; \
3174 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3175 i = SCM_I_INUM (idx); \
3176 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3178 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3180 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3181 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3183 scm_t_ ## type x = *int_ptr; \
3184 if (SCM_FIXABLE (x)) \
3185 RETURN (SCM_I_MAKINUM (x)); \
3189 RETURN (scm_from_ ## type (x)); \
3195 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3199 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3201 scm_t_signed_bits i; \
3202 const type *float_ptr; \
3205 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3206 i = SCM_I_INUM (idx); \
3207 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3210 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3212 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3213 && (ALIGNED_P (float_ptr, type)))) \
3214 RETURN (scm_from_double (*float_ptr)); \
3216 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3219 VM_DEFINE_OP (102, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3220 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
3222 VM_DEFINE_OP (103, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3223 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
3225 VM_DEFINE_OP (104, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3226 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
3228 VM_DEFINE_OP (105, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3229 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
3231 VM_DEFINE_OP (106, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3232 #if SIZEOF_VOID_P > 4
3233 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
3235 BV_INT_REF (u32
, uint32
, 4);
3238 VM_DEFINE_OP (107, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3239 #if SIZEOF_VOID_P > 4
3240 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
3242 BV_INT_REF (s32
, int32
, 4);
3245 VM_DEFINE_OP (108, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3246 BV_INT_REF (u64
, uint64
, 8);
3248 VM_DEFINE_OP (109, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3249 BV_INT_REF (s64
, int64
, 8);
3251 VM_DEFINE_OP (110, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3252 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
3254 VM_DEFINE_OP (111, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3255 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
3257 /* bv-u8-set! dst:8 idx:8 src:8
3258 * bv-s8-set! dst:8 idx:8 src:8
3259 * bv-u16-set! dst:8 idx:8 src:8
3260 * bv-s16-set! dst:8 idx:8 src:8
3261 * bv-u32-set! dst:8 idx:8 src:8
3262 * bv-s32-set! dst:8 idx:8 src:8
3263 * bv-u64-set! dst:8 idx:8 src:8
3264 * bv-s64-set! dst:8 idx:8 src:8
3265 * bv-f32-set! dst:8 idx:8 src:8
3266 * bv-f64-set! dst:8 idx:8 src:8
3268 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3269 * values are written using native endianness.
3271 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3273 scm_t_uint8 dst, idx, src; \
3274 scm_t_signed_bits i, j = 0; \
3275 SCM bv, scm_idx, val; \
3276 scm_t_ ## type *int_ptr; \
3278 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3279 bv = LOCAL_REF (dst); \
3280 scm_idx = LOCAL_REF (idx); \
3281 val = LOCAL_REF (src); \
3282 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3283 i = SCM_I_INUM (scm_idx); \
3284 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3286 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3288 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3289 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3290 && (SCM_I_INUMP (val)) \
3291 && ((j = SCM_I_INUM (val)) >= min) \
3293 *int_ptr = (scm_t_ ## type) j; \
3297 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3302 #define BV_INT_SET(stem, type, size) \
3304 scm_t_uint8 dst, idx, src; \
3305 scm_t_signed_bits i; \
3306 SCM bv, scm_idx, val; \
3307 scm_t_ ## type *int_ptr; \
3309 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3310 bv = LOCAL_REF (dst); \
3311 scm_idx = LOCAL_REF (idx); \
3312 val = LOCAL_REF (src); \
3313 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3314 i = SCM_I_INUM (scm_idx); \
3315 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3317 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3319 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3320 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3321 *int_ptr = scm_to_ ## type (val); \
3325 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3330 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3332 scm_t_uint8 dst, idx, src; \
3333 scm_t_signed_bits i; \
3334 SCM bv, scm_idx, val; \
3337 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3338 bv = LOCAL_REF (dst); \
3339 scm_idx = LOCAL_REF (idx); \
3340 val = LOCAL_REF (src); \
3341 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3342 i = SCM_I_INUM (scm_idx); \
3343 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3345 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3347 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3348 && (ALIGNED_P (float_ptr, type)))) \
3349 *float_ptr = scm_to_double (val); \
3353 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3358 VM_DEFINE_OP (112, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3359 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3361 VM_DEFINE_OP (113, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3362 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3364 VM_DEFINE_OP (114, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3365 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3367 VM_DEFINE_OP (115, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3368 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3370 VM_DEFINE_OP (116, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3371 #if SIZEOF_VOID_P > 4
3372 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3374 BV_INT_SET (u32
, uint32
, 4);
3377 VM_DEFINE_OP (117, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3378 #if SIZEOF_VOID_P > 4
3379 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3381 BV_INT_SET (s32
, int32
, 4);
3384 VM_DEFINE_OP (118, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3385 BV_INT_SET (u64
, uint64
, 8);
3387 VM_DEFINE_OP (119, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3388 BV_INT_SET (s64
, int64
, 8);
3390 VM_DEFINE_OP (120, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3391 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3393 VM_DEFINE_OP (121, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3394 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3396 END_DISPATCH_SWITCH
;
3398 vm_error_bad_instruction
:
3399 vm_error_bad_instruction (op
);
3401 abort (); /* never reached */
3405 #undef ABORT_CONTINUATION_HOOK
3410 #undef BEGIN_DISPATCH_SWITCH
3411 #undef BINARY_INTEGER_OP
3412 #undef BR_ARITHMETIC
3416 #undef BV_FIXABLE_INT_REF
3417 #undef BV_FIXABLE_INT_SET
3422 #undef CACHE_REGISTER
3423 #undef CHECK_OVERFLOW
3424 #undef END_DISPATCH_SWITCH
3425 #undef FREE_VARIABLE_REF
3434 #undef POP_CONTINUATION_HOOK
3435 #undef PUSH_CONTINUATION_HOOK
3436 #undef RESTORE_CONTINUATION_HOOK
3438 #undef RETURN_ONE_VALUE
3439 #undef RETURN_VALUE_LIST
3443 #undef SYNC_BEFORE_GC
3445 #undef SYNC_REGISTER
3446 #undef VARIABLE_BOUNDP
3449 #undef VM_CHECK_FREE_VARIABLE
3450 #undef VM_CHECK_OBJECT
3451 #undef VM_CHECK_UNDERFLOW
3453 #undef VM_INSTRUCTION_TO_LABEL
3455 #undef VM_VALIDATE_BYTEVECTOR
3456 #undef VM_VALIDATE_PAIR
3457 #undef VM_VALIDATE_STRUCT
3460 (defun renumber-ops ()
3461 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3464 (let ((counter -1)) (goto-char (point-min))
3465 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3467 (number-to-string (setq counter (1+ counter)))