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, (i) - 1)
632 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = 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());
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
)))
902 SCM proc
= SCM_FRAME_PROGRAM (fp
);
904 if (SCM_STRUCTP (proc
) && SCM_STRUCT_APPLICABLE_P (proc
))
906 fp
[-1] = SCM_STRUCT_PROCEDURE (proc
);
909 if (SCM_HAS_TYP7 (proc
, scm_tc7_smob
) && SCM_SMOB_APPLICABLE_P (proc
))
911 scm_t_uint32 n
= FRAME_LOCALS_COUNT();
913 /* Shuffle args up, place smob in local 0. */
914 CHECK_OVERFLOW (vp
->sp
+ 1);
917 LOCAL_SET (n
+ 1, LOCAL_REF (n
));
919 fp
[-1] = SCM_SMOB_DESCRIPTOR (proc
).apply_trampoline
;
924 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
);
939 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
942 BEGIN_DISPATCH_SWITCH
;
953 * Bring the VM to a halt, returning all the values from the stack.
955 VM_DEFINE_OP (0, halt
, "halt", OP1 (U8_X24
))
957 scm_t_uint32 nvals
= FRAME_LOCALS_COUNT() - 5;
960 /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
969 for (n
= nvals
; n
> 0; n
--)
970 ret
= scm_cons (LOCAL_REF (5 + n
- 1), ret
);
971 ret
= scm_values (ret
);
974 vp
->ip
= SCM_FRAME_RETURN_ADDRESS (fp
);
975 vp
->sp
= SCM_FRAME_LOWER_ADDRESS (fp
) - 1;
976 vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
981 /* call proc:24 _:8 nlocals:24
983 * Call a procedure. PROC is the local corresponding to a procedure.
984 * The three values below PROC will be overwritten by the saved call
985 * frame data. The new frame will have space for NLOCALS locals: one
986 * for the procedure, and the rest for the arguments which should
987 * already have been pushed on.
989 * When the call returns, execution proceeds with the next
990 * instruction. There may be any number of values on the return
991 * stack; the precise number can be had by subtracting the address of
992 * PROC from the post-call SP.
994 VM_DEFINE_OP (1, call
, "call", OP2 (U8_U24
, X8_U24
))
996 scm_t_uint32 proc
, nlocals
;
999 SCM_UNPACK_RTL_24 (op
, proc
);
1000 SCM_UNPACK_RTL_24 (ip
[1], nlocals
);
1002 VM_HANDLE_INTERRUPTS
;
1004 fp
= vp
->fp
= old_fp
+ proc
;
1005 SCM_FRAME_SET_DYNAMIC_LINK (fp
, old_fp
);
1006 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp
, ip
+ 2);
1007 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp
, ip
+ 2);
1009 RESET_FRAME (nlocals
);
1011 PUSH_CONTINUATION_HOOK ();
1014 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1017 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1021 /* tail-call nlocals:24
1023 * Tail-call a procedure. Requires that the procedure and all of the
1024 * arguments have already been shuffled into position.
1026 VM_DEFINE_OP (2, tail_call
, "tail-call", OP1 (U8_U24
))
1028 scm_t_uint32 nlocals
;
1030 SCM_UNPACK_RTL_24 (op
, nlocals
);
1032 VM_HANDLE_INTERRUPTS
;
1034 RESET_FRAME (nlocals
);
1037 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1040 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1044 /* receive dst:12 proc:12 _:8 nlocals:24
1046 * Receive a single return value from a call whose procedure was in
1047 * PROC, asserting that the call actually returned at least one
1048 * value. Afterwards, resets the frame to NLOCALS locals.
1050 VM_DEFINE_OP (3, receive
, "receive", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1052 scm_t_uint16 dst
, proc
;
1053 scm_t_uint32 nlocals
;
1054 SCM_UNPACK_RTL_12_12 (op
, dst
, proc
);
1055 SCM_UNPACK_RTL_24 (ip
[1], nlocals
);
1056 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ 1, vm_error_no_values ());
1057 LOCAL_SET (dst
, LOCAL_REF (proc
+ 1));
1058 RESET_FRAME (nlocals
);
1062 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
1064 * Receive a return of multiple values from a call whose procedure was
1065 * in PROC. If fewer than NVALUES values were returned, signal an
1066 * error. Unless ALLOW-EXTRA? is true, require that the number of
1067 * return values equals NVALUES exactly. After receive-values has
1068 * run, the values can be copied down via `mov'.
1070 VM_DEFINE_OP (4, receive_values
, "receive-values", OP2 (U8_U24
, B1_X7_U24
))
1072 scm_t_uint32 proc
, nvalues
;
1073 SCM_UNPACK_RTL_24 (op
, proc
);
1074 SCM_UNPACK_RTL_24 (ip
[1], nvalues
);
1076 VM_ASSERT (FRAME_LOCALS_COUNT () > proc
+ nvalues
,
1077 vm_error_not_enough_values ());
1079 VM_ASSERT (FRAME_LOCALS_COUNT () == proc
+ nvalues
,
1080 vm_error_wrong_number_of_values (nvalues
));
1088 VM_DEFINE_OP (5, return, "return", OP1 (U8_U24
))
1091 SCM_UNPACK_RTL_24 (op
, src
);
1092 RETURN_ONE_VALUE (LOCAL_REF (src
));
1095 /* return-values _:24
1097 * Return a number of values from a call frame. This opcode
1098 * corresponds to an application of `values' in tail position. As
1099 * with tail calls, we expect that the values have already been
1100 * shuffled down to a contiguous array starting at slot 1.
1101 * We also expect the frame has already been reset.
1103 VM_DEFINE_OP (6, return_values
, "return-values", OP1 (U8_X24
))
1105 scm_t_uint32 nvalues _GL_UNUSED
= FRAME_LOCALS_COUNT();
1108 VM_HANDLE_INTERRUPTS
;
1109 ip
= SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp
);
1110 fp
= vp
->fp
= SCM_FRAME_DYNAMIC_LINK (fp
);
1112 /* Clear stack frame. */
1113 base
[-2] = SCM_BOOL_F
;
1114 base
[-3] = SCM_BOOL_F
;
1115 base
[-4] = SCM_BOOL_F
;
1117 POP_CONTINUATION_HOOK (base
, nvalues
);
1126 * Specialized call stubs
1129 /* subr-call ptr-idx:24
1131 * Call a subr, passing all locals in this frame as arguments. Fetch
1132 * the foreign pointer from PTR-IDX, a free variable. Return from the
1133 * calling frame. This instruction is part of the trampolines
1134 * created in gsubr.c, and is not generated by the compiler.
1136 VM_DEFINE_OP (7, subr_call
, "subr-call", OP1 (U8_U24
))
1138 scm_t_uint32 ptr_idx
;
1142 SCM_UNPACK_RTL_24 (op
, ptr_idx
);
1144 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx
);
1145 subr
= SCM_POINTER_VALUE (pointer
);
1147 VM_HANDLE_INTERRUPTS
;
1150 switch (FRAME_LOCALS_COUNT ())
1159 ret
= subr (fp
[0], fp
[1]);
1162 ret
= subr (fp
[0], fp
[1], fp
[2]);
1165 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3]);
1168 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4]);
1171 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5]);
1174 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6]);
1177 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7]);
1180 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8]);
1183 ret
= subr (fp
[0], fp
[1], fp
[2], fp
[3], fp
[4], fp
[5], fp
[6], fp
[7], fp
[8], fp
[9]);
1189 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1191 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1192 /* multiple values returned to continuation */
1193 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1195 RETURN_ONE_VALUE (ret
);
1198 /* foreign-call cif-idx:12 ptr-idx:12
1200 * Call a foreign function. Fetch the CIF and foreign pointer from
1201 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1202 * frame. Arguments are taken from the stack. This instruction is
1203 * part of the trampolines created by the FFI, and is not generated by
1206 VM_DEFINE_OP (8, foreign_call
, "foreign-call", OP1 (U8_U12_U12
))
1208 scm_t_uint16 cif_idx
, ptr_idx
;
1209 SCM closure
, cif
, pointer
, ret
;
1211 SCM_UNPACK_RTL_12_12 (op
, cif_idx
, ptr_idx
);
1213 closure
= LOCAL_REF (0);
1214 cif
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, cif_idx
);
1215 pointer
= SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure
, ptr_idx
);
1218 VM_HANDLE_INTERRUPTS
;
1220 // FIXME: separate args
1221 ret
= scm_i_foreign_call (scm_cons (cif
, pointer
), fp
);
1223 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1225 if (SCM_UNLIKELY (SCM_VALUESP (ret
)))
1226 /* multiple values returned to continuation */
1227 RETURN_VALUE_LIST (scm_struct_ref (ret
, SCM_INUM0
));
1229 RETURN_ONE_VALUE (ret
);
1232 /* continuation-call contregs:24
1234 * Return to a continuation, nonlocally. The arguments to the
1235 * continuation are taken from the stack. CONTREGS is a free variable
1236 * containing the reified continuation. This instruction is part of
1237 * the implementation of undelimited continuations, and is not
1238 * generated by the compiler.
1240 VM_DEFINE_OP (9, continuation_call
, "continuation-call", OP1 (U8_U24
))
1243 scm_t_uint32 contregs_idx
;
1245 SCM_UNPACK_RTL_24 (op
, contregs_idx
);
1248 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx
);
1251 scm_i_check_continuation (contregs
);
1252 vm_return_to_continuation (scm_i_contregs_vm (contregs
),
1253 scm_i_contregs_vm_cont (contregs
),
1254 FRAME_LOCALS_COUNT (), fp
);
1255 scm_i_reinstate_continuation (contregs
);
1261 /* compose-continuation cont:24
1263 * Compose a partial continution with the current continuation. The
1264 * arguments to the continuation are taken from the stack. CONT is a
1265 * free variable containing the reified continuation. This
1266 * instruction is part of the implementation of partial continuations,
1267 * and is not generated by the compiler.
1269 VM_DEFINE_OP (10, compose_continuation
, "compose-continuation", OP1 (U8_U24
))
1272 scm_t_uint32 cont_idx
;
1274 SCM_UNPACK_RTL_24 (op
, cont_idx
);
1275 vmcont
= LOCAL_REF (cont_idx
);
1278 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont
),
1279 vm_error_continuation_not_rewindable (vmcont
));
1280 vm_reinstate_partial_continuation (vm
, vmcont
, FRAME_LOCALS_COUNT (), fp
,
1281 ¤t_thread
->dynstack
,
1289 * Tail-apply the procedure in local slot 0 to the rest of the
1290 * arguments. This instruction is part of the implementation of
1291 * `apply', and is not generated by the compiler.
1293 VM_DEFINE_OP (11, tail_apply
, "tail-apply", OP1 (U8_X24
))
1295 int i
, list_idx
, list_len
, nargs
;
1298 VM_HANDLE_INTERRUPTS
;
1300 VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
1301 nargs
= FRAME_LOCALS_COUNT ();
1302 list_idx
= nargs
- 1;
1303 list
= LOCAL_REF (list_idx
);
1304 list_len
= scm_ilength (list
);
1306 VM_ASSERT (list_len
>= 0, vm_error_apply_to_non_list (list
));
1308 nargs
= nargs
- 2 + list_len
;
1309 ALLOC_FRAME (nargs
);
1311 for (i
= 0; i
< list_idx
; i
++)
1312 LOCAL_SET(i
- 1, LOCAL_REF (i
));
1314 /* Null out these slots, just in case there are less than 2 elements
1316 LOCAL_SET (list_idx
- 1, SCM_UNDEFINED
);
1317 LOCAL_SET (list_idx
, SCM_UNDEFINED
);
1319 for (i
= 0; i
< list_len
; i
++, list
= SCM_CDR (list
))
1320 LOCAL_SET (list_idx
- 1 + i
, SCM_CAR (list
));
1324 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1327 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1333 * Capture the current continuation, and tail-apply the procedure in
1334 * local slot 0 to it. This instruction is part of the implementation
1335 * of `call/cc', and is not generated by the compiler.
1337 VM_DEFINE_OP (12, call_cc
, "call/cc", OP1 (U8_X24
))
1341 scm_t_dynstack
*dynstack
;
1343 VM_HANDLE_INTERRUPTS
;
1346 dynstack
= scm_dynstack_capture_all (¤t_thread
->dynstack
);
1347 vm_cont
= scm_i_vm_capture_stack (vp
->stack_base
,
1348 SCM_FRAME_DYNAMIC_LINK (fp
),
1349 SCM_FRAME_LOWER_ADDRESS (fp
) - 1,
1350 SCM_FRAME_RETURN_ADDRESS (fp
),
1351 SCM_FRAME_MV_RETURN_ADDRESS (fp
),
1354 cont
= scm_i_make_continuation (®isters
, vm
, vm_cont
);
1362 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp
))))
1365 ip
= SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp
));
1376 * Function prologues
1379 /* br-if-nargs-ne expected:24 _:8 offset:24
1380 * br-if-nargs-lt expected:24 _:8 offset:24
1381 * br-if-nargs-gt expected:24 _:8 offset:24
1383 * If the number of actual arguments is not equal, less than, or greater
1384 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1385 * the current instruction pointer.
1387 VM_DEFINE_OP (13, br_if_nargs_ne
, "br-if-nargs-ne", OP2 (U8_U24
, X8_L24
))
1391 VM_DEFINE_OP (14, br_if_nargs_lt
, "br-if-nargs-lt", OP2 (U8_U24
, X8_L24
))
1395 VM_DEFINE_OP (15, br_if_nargs_gt
, "br-if-nargs-gt", OP2 (U8_U24
, X8_L24
))
1400 /* assert-nargs-ee expected:24
1401 * assert-nargs-ge expected:24
1402 * assert-nargs-le expected:24
1404 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1405 * respectively, signal an error.
1407 VM_DEFINE_OP (16, assert_nargs_ee
, "assert-nargs-ee", OP1 (U8_U24
))
1409 scm_t_uint32 expected
;
1410 SCM_UNPACK_RTL_24 (op
, expected
);
1411 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1412 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1415 VM_DEFINE_OP (17, assert_nargs_ge
, "assert-nargs-ge", OP1 (U8_U24
))
1417 scm_t_uint32 expected
;
1418 SCM_UNPACK_RTL_24 (op
, expected
);
1419 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected
,
1420 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1423 VM_DEFINE_OP (18, assert_nargs_le
, "assert-nargs-le", OP1 (U8_U24
))
1425 scm_t_uint32 expected
;
1426 SCM_UNPACK_RTL_24 (op
, expected
);
1427 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected
,
1428 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1432 /* alloc-frame nlocals:24
1434 * Ensure that there is space on the stack for NLOCALS local variables,
1435 * setting them all to SCM_UNDEFINED, except those nargs values that
1436 * were passed as arguments and procedure.
1438 VM_DEFINE_OP (19, alloc_frame
, "alloc-frame", OP1 (U8_U24
))
1440 scm_t_uint32 nlocals
, nargs
;
1441 SCM_UNPACK_RTL_24 (op
, nlocals
);
1443 nargs
= FRAME_LOCALS_COUNT ();
1444 ALLOC_FRAME (nlocals
);
1445 while (nlocals
-- > nargs
)
1446 LOCAL_SET (nlocals
, SCM_UNDEFINED
);
1451 /* reset-frame nlocals:24
1453 * Like alloc-frame, but doesn't check that the stack is big enough.
1454 * Used to reset the frame size to something less than the size that
1455 * was previously set via alloc-frame.
1457 VM_DEFINE_OP (20, reset_frame
, "reset-frame", OP1 (U8_U24
))
1459 scm_t_uint32 nlocals
;
1460 SCM_UNPACK_RTL_24 (op
, nlocals
);
1461 RESET_FRAME (nlocals
);
1465 /* assert-nargs-ee/locals expected:12 nlocals:12
1467 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1468 * number of locals reserved is EXPECTED + NLOCALS.
1470 VM_DEFINE_OP (21, assert_nargs_ee_locals
, "assert-nargs-ee/locals", OP1 (U8_U12_U12
))
1472 scm_t_uint16 expected
, nlocals
;
1473 SCM_UNPACK_RTL_12_12 (op
, expected
, nlocals
);
1474 VM_ASSERT (FRAME_LOCALS_COUNT () == expected
,
1475 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp
)));
1476 ALLOC_FRAME (expected
+ nlocals
);
1478 LOCAL_SET (expected
+ nlocals
, SCM_UNDEFINED
);
1483 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1484 * _:8 ntotal:24 kw-offset:32
1486 * Find the last positional argument, and shuffle all the rest above
1487 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1488 * load the constant at KW-OFFSET words from the current IP, and use it
1489 * to bind keyword arguments. If HAS-REST, collect all shuffled
1490 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1491 * the arguments that we shuffled up.
1493 * A macro-mega-instruction.
1495 VM_DEFINE_OP (22, bind_kwargs
, "bind-kwargs", OP4 (U8_U24
, U8_U24
, X8_U24
, N32
))
1497 scm_t_uint32 nreq
, nreq_and_opt
, ntotal
, npositional
, nkw
, n
, nargs
;
1498 scm_t_int32 kw_offset
;
1501 char allow_other_keys
, has_rest
;
1503 SCM_UNPACK_RTL_24 (op
, nreq
);
1504 allow_other_keys
= ip
[1] & 0x1;
1505 has_rest
= ip
[1] & 0x2;
1506 SCM_UNPACK_RTL_24 (ip
[1], nreq_and_opt
);
1507 SCM_UNPACK_RTL_24 (ip
[2], ntotal
);
1509 kw_bits
= (scm_t_bits
) (ip
+ kw_offset
);
1510 VM_ASSERT (!(kw_bits
& 0x7), abort());
1511 kw
= SCM_PACK (kw_bits
);
1513 nargs
= FRAME_LOCALS_COUNT ();
1515 /* look in optionals for first keyword or last positional */
1516 /* starting after the last required positional arg */
1518 while (/* while we have args */
1520 /* and we still have positionals to fill */
1521 && npositional
< nreq_and_opt
1522 /* and we haven't reached a keyword yet */
1523 && !scm_is_keyword (LOCAL_REF (npositional
)))
1524 /* bind this optional arg (by leaving it in place) */
1526 nkw
= nargs
- npositional
;
1527 /* shuffle non-positional arguments above ntotal */
1528 ALLOC_FRAME (ntotal
+ nkw
);
1531 LOCAL_SET (ntotal
+ n
, LOCAL_REF (npositional
+ n
));
1532 /* and fill optionals & keyword args with SCM_UNDEFINED */
1535 LOCAL_SET (n
++, SCM_UNDEFINED
);
1537 VM_ASSERT (has_rest
|| (nkw
% 2) == 0,
1538 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp
)));
1540 /* Now bind keywords, in the order given. */
1541 for (n
= 0; n
< nkw
; n
++)
1542 if (scm_is_keyword (LOCAL_REF (ntotal
+ n
)))
1545 for (walk
= kw
; scm_is_pair (walk
); walk
= SCM_CDR (walk
))
1546 if (scm_is_eq (SCM_CAAR (walk
), LOCAL_REF (ntotal
+ n
)))
1548 SCM si
= SCM_CDAR (walk
);
1549 LOCAL_SET (SCM_I_INUMP (si
) ? SCM_I_INUM (si
) : scm_to_uint32 (si
),
1550 LOCAL_REF (ntotal
+ n
+ 1));
1553 VM_ASSERT (scm_is_pair (walk
) || allow_other_keys
,
1554 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp
),
1555 LOCAL_REF (ntotal
+ n
)));
1559 VM_ASSERT (has_rest
, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp
),
1560 LOCAL_REF (ntotal
+ n
)));
1567 rest
= scm_cons (LOCAL_REF (ntotal
+ n
), rest
);
1568 LOCAL_SET (nreq_and_opt
, rest
);
1571 RESET_FRAME (ntotal
);
1578 * Collect any arguments at or above DST into a list, and store that
1581 VM_DEFINE_OP (23, bind_rest
, "bind-rest", OP1 (U8_U24
) | OP_DST
)
1583 scm_t_uint32 dst
, nargs
;
1586 SCM_UNPACK_RTL_24 (op
, dst
);
1587 nargs
= FRAME_LOCALS_COUNT ();
1591 ALLOC_FRAME (dst
+ 1);
1593 LOCAL_SET (nargs
++, SCM_UNDEFINED
);
1597 while (nargs
-- > dst
)
1599 rest
= scm_cons (LOCAL_REF (nargs
), rest
);
1600 LOCAL_SET (nargs
, SCM_UNDEFINED
);
1603 RESET_FRAME (dst
+ 1);
1606 LOCAL_SET (dst
, rest
);
1615 * Branching instructions
1620 * Add OFFSET, a signed 24-bit number, to the current instruction
1623 VM_DEFINE_OP (24, br
, "br", OP1 (U8_L24
))
1625 scm_t_int32 offset
= op
;
1626 offset
>>= 8; /* Sign-extending shift. */
1630 /* br-if-true test:24 invert:1 _:7 offset:24
1632 * If the value in TEST is true for the purposes of Scheme, add
1633 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1635 VM_DEFINE_OP (25, br_if_true
, "br-if-true", OP2 (U8_U24
, B1_X7_L24
))
1637 BR_UNARY (x
, scm_is_true (x
));
1640 /* br-if-null test:24 invert:1 _:7 offset:24
1642 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1643 * signed 24-bit number, to the current instruction pointer.
1645 VM_DEFINE_OP (26, br_if_null
, "br-if-null", OP2 (U8_U24
, B1_X7_L24
))
1647 BR_UNARY (x
, scm_is_null (x
));
1650 /* br-if-nil test:24 invert:1 _:7 offset:24
1652 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1653 * number, to the current instruction pointer.
1655 VM_DEFINE_OP (27, br_if_nil
, "br-if-nil", OP2 (U8_U24
, B1_X7_L24
))
1657 BR_UNARY (x
, scm_is_lisp_false (x
));
1660 /* br-if-pair test:24 invert:1 _:7 offset:24
1662 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1663 * to the current instruction pointer.
1665 VM_DEFINE_OP (28, br_if_pair
, "br-if-pair", OP2 (U8_U24
, B1_X7_L24
))
1667 BR_UNARY (x
, scm_is_pair (x
));
1670 /* br-if-struct test:24 invert:1 _:7 offset:24
1672 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1673 * number, to the current instruction pointer.
1675 VM_DEFINE_OP (29, br_if_struct
, "br-if-struct", OP2 (U8_U24
, B1_X7_L24
))
1677 BR_UNARY (x
, SCM_STRUCTP (x
));
1680 /* br-if-char test:24 invert:1 _:7 offset:24
1682 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1683 * to the current instruction pointer.
1685 VM_DEFINE_OP (30, br_if_char
, "br-if-char", OP2 (U8_U24
, B1_X7_L24
))
1687 BR_UNARY (x
, SCM_CHARP (x
));
1690 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1692 * If the value in TEST has the TC7 given in the second word, add
1693 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1695 VM_DEFINE_OP (31, br_if_tc7
, "br-if-tc7", OP2 (U8_U24
, B1_U7_L24
))
1697 BR_UNARY (x
, SCM_HAS_TYP7 (x
, (ip
[1] >> 1) & 0x7f));
1700 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1702 * If the value in A is eq? to the value in B, add OFFSET, a signed
1703 * 24-bit number, to the current instruction pointer.
1705 VM_DEFINE_OP (32, br_if_eq
, "br-if-eq", OP2 (U8_U12_U12
, B1_X7_L24
))
1707 BR_BINARY (x
, y
, scm_is_eq (x
, y
));
1710 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1712 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1713 * 24-bit number, to the current instruction pointer.
1715 VM_DEFINE_OP (33, br_if_eqv
, "br-if-eqv", OP2 (U8_U12_U12
, B1_X7_L24
))
1719 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1720 && scm_is_true (scm_eqv_p (x
, y
))));
1723 // FIXME: remove, have compiler inline eqv test instead
1724 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1726 * If the value in A is equal? to the value in B, add OFFSET, a signed
1727 * 24-bit number, to the current instruction pointer.
1729 // FIXME: should sync_ip before calling out?
1730 VM_DEFINE_OP (34, br_if_equal
, "br-if-equal", OP2 (U8_U12_U12
, B1_X7_L24
))
1734 || (SCM_NIMP (x
) && SCM_NIMP (y
)
1735 && scm_is_true (scm_equal_p (x
, y
))));
1738 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1740 * If the value in A is = to the value in B, add OFFSET, a signed
1741 * 24-bit number, to the current instruction pointer.
1743 VM_DEFINE_OP (35, br_if_ee
, "br-if-=", OP2 (U8_U12_U12
, B1_X7_L24
))
1745 BR_ARITHMETIC (==, scm_num_eq_p
);
1748 /* br-if-< a:12 b:12 _:8 offset:24
1750 * If the value in A is < to the value in B, add OFFSET, a signed
1751 * 24-bit number, to the current instruction pointer.
1753 VM_DEFINE_OP (36, br_if_lt
, "br-if-<", OP2 (U8_U12_U12
, B1_X7_L24
))
1755 BR_ARITHMETIC (<, scm_less_p
);
1758 /* br-if-<= a:12 b:12 _:8 offset:24
1760 * If the value in A is <= to the value in B, add OFFSET, a signed
1761 * 24-bit number, to the current instruction pointer.
1763 VM_DEFINE_OP (37, br_if_le
, "br-if-<=", OP2 (U8_U12_U12
, B1_X7_L24
))
1765 BR_ARITHMETIC (<=, scm_leq_p
);
1772 * Lexical binding instructions
1775 /* mov dst:12 src:12
1777 * Copy a value from one local slot to another.
1779 VM_DEFINE_OP (38, mov
, "mov", OP1 (U8_U12_U12
) | OP_DST
)
1784 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1785 LOCAL_SET (dst
, LOCAL_REF (src
));
1790 /* long-mov dst:24 _:8 src:24
1792 * Copy a value from one local slot to another.
1794 VM_DEFINE_OP (39, long_mov
, "long-mov", OP2 (U8_U24
, X8_U24
) | OP_DST
)
1799 SCM_UNPACK_RTL_24 (op
, dst
);
1800 SCM_UNPACK_RTL_24 (ip
[1], src
);
1801 LOCAL_SET (dst
, LOCAL_REF (src
));
1806 /* box dst:12 src:12
1808 * Create a new variable holding SRC, and place it in DST.
1810 VM_DEFINE_OP (40, box
, "box", OP1 (U8_U12_U12
) | OP_DST
)
1812 scm_t_uint16 dst
, src
;
1813 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1814 LOCAL_SET (dst
, scm_cell (scm_tc7_variable
, SCM_UNPACK (LOCAL_REF (src
))));
1818 /* box-ref dst:12 src:12
1820 * Unpack the variable at SRC into DST, asserting that the variable is
1823 VM_DEFINE_OP (41, box_ref
, "box-ref", OP1 (U8_U12_U12
) | OP_DST
)
1825 scm_t_uint16 dst
, src
;
1827 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1828 var
= LOCAL_REF (src
);
1829 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1830 VM_ASSERT (VARIABLE_BOUNDP (var
),
1831 vm_error_unbound (SCM_FRAME_PROGRAM (fp
), var
));
1832 LOCAL_SET (dst
, VARIABLE_REF (var
));
1836 /* box-set! dst:12 src:12
1838 * Set the contents of the variable at DST to SET.
1840 VM_DEFINE_OP (42, box_set
, "box-set!", OP1 (U8_U12_U12
))
1842 scm_t_uint16 dst
, src
;
1844 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1845 var
= LOCAL_REF (dst
);
1846 VM_ASSERT (SCM_VARIABLEP (var
), abort ());
1847 VARIABLE_SET (var
, LOCAL_REF (src
));
1851 /* make-closure dst:24 offset:32 _:8 nfree:24
1853 * Make a new closure, and write it to DST. The code for the closure
1854 * will be found at OFFSET words from the current IP. OFFSET is a
1855 * signed 32-bit integer. Space for NFREE free variables will be
1858 VM_DEFINE_OP (43, make_closure
, "make-closure", OP3 (U8_U24
, L32
, X8_U24
) | OP_DST
)
1860 scm_t_uint32 dst
, nfree
, n
;
1864 SCM_UNPACK_RTL_24 (op
, dst
);
1866 SCM_UNPACK_RTL_24 (ip
[2], nfree
);
1868 // FIXME: Assert range of nfree?
1869 closure
= scm_words (scm_tc7_rtl_program
| (nfree
<< 16), nfree
+ 2);
1870 SCM_SET_CELL_WORD_1 (closure
, ip
+ offset
);
1871 // FIXME: Elide these initializations?
1872 for (n
= 0; n
< nfree
; n
++)
1873 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure
, n
, SCM_BOOL_F
);
1874 LOCAL_SET (dst
, closure
);
1878 /* free-ref dst:12 src:12 _:8 idx:24
1880 * Load free variable IDX from the closure SRC into local slot DST.
1882 VM_DEFINE_OP (44, free_ref
, "free-ref", OP2 (U8_U12_U12
, X8_U24
) | OP_DST
)
1884 scm_t_uint16 dst
, src
;
1886 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1887 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1888 /* CHECK_FREE_VARIABLE (src); */
1889 LOCAL_SET (dst
, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src
), idx
));
1893 /* free-set! dst:12 src:12 _8 idx:24
1895 * Set free variable IDX from the closure DST to SRC.
1897 VM_DEFINE_OP (45, free_set
, "free-set!", OP2 (U8_U12_U12
, X8_U24
))
1899 scm_t_uint16 dst
, src
;
1901 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
1902 SCM_UNPACK_RTL_24 (ip
[1], idx
);
1903 /* CHECK_FREE_VARIABLE (src); */
1904 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst
), idx
, LOCAL_REF (src
));
1912 * Immediates and statically allocated non-immediates
1915 /* make-short-immediate dst:8 low-bits:16
1917 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1920 VM_DEFINE_OP (46, make_short_immediate
, "make-short-immediate", OP1 (U8_U8_I16
) | OP_DST
)
1925 SCM_UNPACK_RTL_8_16 (op
, dst
, val
);
1926 LOCAL_SET (dst
, SCM_PACK (val
));
1930 /* make-long-immediate dst:24 low-bits:32
1932 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1935 VM_DEFINE_OP (47, make_long_immediate
, "make-long-immediate", OP2 (U8_U24
, I32
))
1940 SCM_UNPACK_RTL_24 (op
, dst
);
1942 LOCAL_SET (dst
, SCM_PACK (val
));
1946 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1948 * Make an immediate with HIGH-BITS and LOW-BITS.
1950 VM_DEFINE_OP (48, make_long_long_immediate
, "make-long-long-immediate", OP3 (U8_U24
, A32
, B32
) | OP_DST
)
1955 SCM_UNPACK_RTL_24 (op
, dst
);
1956 #if SIZEOF_SCM_T_BITS > 4
1961 ASSERT (ip
[1] == 0);
1964 LOCAL_SET (dst
, SCM_PACK (val
));
1968 /* make-non-immediate dst:24 offset:32
1970 * Load a pointer to statically allocated memory into DST. The
1971 * object's memory is will be found OFFSET 32-bit words away from the
1972 * current instruction pointer. OFFSET is a signed value. The
1973 * intention here is that the compiler would produce an object file
1974 * containing the words of a non-immediate object, and this
1975 * instruction creates a pointer to that memory, effectively
1976 * resurrecting that object.
1978 * Whether the object is mutable or immutable depends on where it was
1979 * allocated by the compiler, and loaded by the loader.
1981 VM_DEFINE_OP (49, make_non_immediate
, "make-non-immediate", OP2 (U8_U24
, N32
) | OP_DST
)
1986 scm_t_bits unpacked
;
1988 SCM_UNPACK_RTL_24 (op
, dst
);
1991 unpacked
= (scm_t_bits
) loc
;
1993 VM_ASSERT (!(unpacked
& 0x7), abort());
1995 LOCAL_SET (dst
, SCM_PACK (unpacked
));
2000 /* static-ref dst:24 offset:32
2002 * Load a SCM value into DST. The SCM value will be fetched from
2003 * memory, OFFSET 32-bit words away from the current instruction
2004 * pointer. OFFSET is a signed value.
2006 * The intention is for this instruction to be used to load constants
2007 * that the compiler is unable to statically allocate, like symbols.
2008 * These values would be initialized when the object file loads.
2010 VM_DEFINE_OP (50, static_ref
, "static-ref", OP2 (U8_U24
, S32
))
2015 scm_t_uintptr loc_bits
;
2017 SCM_UNPACK_RTL_24 (op
, dst
);
2020 loc_bits
= (scm_t_uintptr
) loc
;
2021 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2023 LOCAL_SET (dst
, *((SCM
*) loc_bits
));
2028 /* static-set! src:24 offset:32
2030 * Store a SCM value into memory, OFFSET 32-bit words away from the
2031 * current instruction pointer. OFFSET is a signed value.
2033 VM_DEFINE_OP (51, static_set
, "static-set!", OP2 (U8_U24
, LO32
))
2039 SCM_UNPACK_RTL_24 (op
, src
);
2042 VM_ASSERT (ALIGNED_P (loc
, SCM
), abort());
2044 *((SCM
*) loc
) = LOCAL_REF (src
);
2049 /* link-procedure! src:24 offset:32
2051 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2052 * words away from the current instruction pointer. OFFSET is a
2055 VM_DEFINE_OP (52, link_procedure
, "link-procedure!", OP2 (U8_U24
, L32
))
2061 SCM_UNPACK_RTL_24 (op
, src
);
2065 SCM_SET_CELL_WORD_1 (LOCAL_REF (src
), (scm_t_bits
) loc
);
2073 * Mutable top-level bindings
2076 /* There are three slightly different ways to resolve toplevel
2079 1. A toplevel reference outside of a function. These need to be
2080 looked up when the expression is evaluated -- no later, and no
2081 before. They are looked up relative to the module that is
2082 current when the expression is evaluated. For example:
2086 The "resolve" instruction resolves the variable (box), and then
2087 access is via box-ref or box-set!.
2089 2. A toplevel reference inside a function. These are looked up
2090 relative to the module that was current when the function was
2091 defined. Unlike code at the toplevel, which is usually run only
2092 once, these bindings benefit from memoized lookup, in which the
2093 variable resulting from the lookup is cached in the function.
2095 (lambda () (if (foo) a b))
2097 The toplevel-box instruction is equivalent to "resolve", but
2098 caches the resulting variable in statically allocated memory.
2100 3. A reference to an identifier with respect to a particular
2101 module. This can happen for primitive references, and
2102 references residualized by macro expansions. These can always
2103 be cached. Use module-box for these.
2106 /* current-module dst:24
2108 * Store the current module in DST.
2110 VM_DEFINE_OP (53, current_module
, "current-module", OP1 (U8_U24
) | OP_DST
)
2114 SCM_UNPACK_RTL_24 (op
, dst
);
2117 LOCAL_SET (dst
, scm_current_module ());
2122 /* resolve dst:24 bound?:1 _:7 sym:24
2124 * Resolve SYM in the current module, and place the resulting variable
2127 VM_DEFINE_OP (54, resolve
, "resolve", OP2 (U8_U24
, B1_X7_U24
) | OP_DST
)
2133 SCM_UNPACK_RTL_24 (op
, dst
);
2134 SCM_UNPACK_RTL_24 (ip
[1], sym
);
2137 var
= scm_lookup (LOCAL_REF (sym
));
2139 VM_ASSERT (VARIABLE_BOUNDP (var
),
2140 vm_error_unbound (fp
[-1], LOCAL_REF (sym
)));
2141 LOCAL_SET (dst
, var
);
2146 /* define sym:12 val:12
2148 * Look up a binding for SYM in the current module, creating it if
2149 * necessary. Set its value to VAL.
2151 VM_DEFINE_OP (55, define
, "define", OP1 (U8_U12_U12
))
2153 scm_t_uint16 sym
, val
;
2154 SCM_UNPACK_RTL_12_12 (op
, sym
, val
);
2156 scm_define (LOCAL_REF (sym
), LOCAL_REF (val
));
2160 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2162 * Load a SCM value. The SCM value will be fetched from memory,
2163 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2164 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
2167 * Then, if the loaded value is a variable, it is placed in DST, and control
2170 * Otherwise, we have to resolve the variable. In that case we load
2171 * the module from MOD-OFFSET, just as we loaded the variable.
2172 * Usually the module gets set when the closure is created. The name
2173 * is an offset to a symbol.
2175 * We use the module and the symbol to resolve the variable, placing it in
2176 * DST, and caching the resolved variable so that we will hit the cache next
2179 VM_DEFINE_OP (56, toplevel_box
, "toplevel-box", OP5 (U8_U24
, S32
, S32
, N32
, B1_X31
) | OP_DST
)
2182 scm_t_int32 var_offset
;
2183 scm_t_uint32
* var_loc_u32
;
2187 SCM_UNPACK_RTL_24 (op
, dst
);
2189 var_loc_u32
= ip
+ var_offset
;
2190 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2191 var_loc
= (SCM
*) var_loc_u32
;
2194 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2197 scm_t_int32 mod_offset
= ip
[2]; /* signed */
2198 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2199 scm_t_uint32
*mod_loc
= ip
+ mod_offset
;
2200 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2204 VM_ASSERT (ALIGNED_P (mod_loc
, SCM
), abort());
2205 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2207 mod
= *((SCM
*) mod_loc
);
2208 sym
= *((SCM
*) sym_loc
);
2210 var
= scm_module_lookup (mod
, sym
);
2212 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2217 LOCAL_SET (dst
, var
);
2221 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2223 * Like toplevel-box, except MOD-OFFSET points at the name of a module
2224 * instead of the module itself.
2226 VM_DEFINE_OP (57, module_box
, "module-box", OP5 (U8_U24
, S32
, N32
, N32
, B1_X31
) | OP_DST
)
2229 scm_t_int32 var_offset
;
2230 scm_t_uint32
* var_loc_u32
;
2234 SCM_UNPACK_RTL_24 (op
, dst
);
2236 var_loc_u32
= ip
+ var_offset
;
2237 VM_ASSERT (ALIGNED_P (var_loc_u32
, SCM
), abort());
2238 var_loc
= (SCM
*) var_loc_u32
;
2241 if (SCM_UNLIKELY (!SCM_VARIABLEP (var
)))
2244 scm_t_int32 modname_offset
= ip
[2]; /* signed */
2245 scm_t_int32 sym_offset
= ip
[3]; /* signed */
2246 scm_t_uint32
*modname_words
= ip
+ modname_offset
;
2247 scm_t_uint32
*sym_loc
= ip
+ sym_offset
;
2251 VM_ASSERT (!(((scm_t_uintptr
) modname_words
) & 0x7), abort());
2252 VM_ASSERT (ALIGNED_P (sym_loc
, SCM
), abort());
2254 modname
= SCM_PACK ((scm_t_bits
) modname_words
);
2255 sym
= *((SCM
*) sym_loc
);
2257 if (scm_is_true (SCM_CAR (modname
)))
2258 var
= scm_public_lookup (SCM_CDR (modname
), sym
);
2260 var
= scm_private_lookup (SCM_CDR (modname
), sym
);
2263 VM_ASSERT (VARIABLE_BOUNDP (var
), vm_error_unbound (fp
[-1], sym
));
2268 LOCAL_SET (dst
, var
);
2275 * The dynamic environment
2278 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2280 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2281 * handler at HANDLER-OFFSET words from the current IP. The handler
2282 * will expect a multiple-value return as if from a call with the
2283 * procedure at PROC-SLOT.
2285 VM_DEFINE_OP (58, prompt
, "prompt", OP3 (U8_U24
, B1_X7_U24
, X8_L24
))
2287 scm_t_uint32 tag
, proc_slot
;
2289 scm_t_uint8 escape_only_p
;
2290 scm_t_dynstack_prompt_flags flags
;
2292 SCM_UNPACK_RTL_24 (op
, tag
);
2293 escape_only_p
= ip
[1] & 0x1;
2294 SCM_UNPACK_RTL_24 (ip
[1], proc_slot
);
2296 offset
>>= 8; /* Sign extension */
2298 /* Push the prompt onto the dynamic stack. */
2299 flags
= escape_only_p
? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
: 0;
2300 scm_dynstack_push_prompt (¤t_thread
->dynstack
, flags
,
2303 &LOCAL_REF (proc_slot
),
2304 (scm_t_uint8
*)(ip
+ offset
),
2309 /* wind winder:12 unwinder:12
2311 * Push wind and unwind procedures onto the dynamic stack. Note that
2312 * neither are actually called; the compiler should emit calls to wind
2313 * and unwind for the normal dynamic-wind control flow. Also note that
2314 * the compiler should have inserted checks that they wind and unwind
2315 * procs are thunks, if it could not prove that to be the case.
2317 VM_DEFINE_OP (59, wind
, "wind", OP1 (U8_U12_U12
))
2319 scm_t_uint16 winder
, unwinder
;
2320 SCM_UNPACK_RTL_12_12 (op
, winder
, unwinder
);
2321 scm_dynstack_push_dynwind (¤t_thread
->dynstack
,
2322 LOCAL_REF (winder
), LOCAL_REF (unwinder
));
2326 /* abort tag:24 _:8 proc:24
2328 * Return a number of values to a prompt handler. The values are
2329 * expected in a frame pushed on at PROC.
2331 VM_DEFINE_OP (60, abort
, "abort", OP2 (U8_U24
, X8_U24
))
2334 scm_t_uint32 tag
, from
, nvalues
;
2337 SCM_UNPACK_RTL_24 (op
, tag
);
2338 SCM_UNPACK_RTL_24 (ip
[1], from
);
2339 base
= (fp
- 1) + from
+ 3;
2340 nvalues
= FRAME_LOCALS_COUNT () - from
- 3;
2343 vm_abort (vm
, LOCAL_REF (tag
), base
, nvalues
, ®isters
);
2345 /* vm_abort should not return */
2354 * A normal exit from the dynamic extent of an expression. Pop the top
2355 * entry off of the dynamic stack.
2357 VM_DEFINE_OP (61, unwind
, "unwind", OP1 (U8_X24
))
2359 scm_dynstack_pop (¤t_thread
->dynstack
);
2363 /* push-fluid fluid:12 value:12
2365 * Dynamically bind N fluids to values. The fluids are expected to be
2366 * allocated in a continguous range on the stack, starting from
2367 * FLUID-BASE. The values do not have this restriction.
2369 VM_DEFINE_OP (62, push_fluid
, "push-fluid", OP1 (U8_U12_U12
))
2371 scm_t_uint32 fluid
, value
;
2373 SCM_UNPACK_RTL_12_12 (op
, fluid
, value
);
2375 scm_dynstack_push_fluid (¤t_thread
->dynstack
,
2376 fp
[fluid
], fp
[value
],
2377 current_thread
->dynamic_state
);
2383 * Leave the dynamic extent of a with-fluids expression, restoring the
2384 * fluids to their previous values.
2386 VM_DEFINE_OP (63, pop_fluid
, "pop-fluid", OP1 (U8_X24
))
2388 /* This function must not allocate. */
2389 scm_dynstack_unwind_fluid (¤t_thread
->dynstack
,
2390 current_thread
->dynamic_state
);
2394 /* fluid-ref dst:12 src:12
2396 * Reference the fluid in SRC, and place the value in DST.
2398 VM_DEFINE_OP (64, fluid_ref
, "fluid-ref", OP1 (U8_U12_U12
) | OP_DST
)
2400 scm_t_uint16 dst
, src
;
2404 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2405 fluid
= LOCAL_REF (src
);
2406 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2407 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2408 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2410 /* Punt dynstate expansion and error handling to the C proc. */
2412 LOCAL_SET (dst
, scm_fluid_ref (fluid
));
2416 SCM val
= SCM_SIMPLE_VECTOR_REF (fluids
, num
);
2417 if (scm_is_eq (val
, SCM_UNDEFINED
))
2418 val
= SCM_I_FLUID_DEFAULT (fluid
);
2419 VM_ASSERT (!scm_is_eq (val
, SCM_UNDEFINED
),
2420 vm_error_unbound_fluid (program
, fluid
));
2421 LOCAL_SET (dst
, val
);
2427 /* fluid-set fluid:12 val:12
2429 * Set the value of the fluid in DST to the value in SRC.
2431 VM_DEFINE_OP (65, fluid_set
, "fluid-set", OP1 (U8_U12_U12
))
2437 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2438 fluid
= LOCAL_REF (a
);
2439 fluids
= SCM_I_DYNAMIC_STATE_FLUIDS (current_thread
->dynamic_state
);
2440 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid
))
2441 || ((num
= SCM_I_FLUID_NUM (fluid
)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
2443 /* Punt dynstate expansion and error handling to the C proc. */
2445 scm_fluid_set_x (fluid
, LOCAL_REF (b
));
2448 SCM_SIMPLE_VECTOR_SET (fluids
, num
, LOCAL_REF (b
));
2457 * Strings, symbols, and keywords
2460 /* string-length dst:12 src:12
2462 * Store the length of the string in SRC in DST.
2464 VM_DEFINE_OP (66, string_length
, "string-length", OP1 (U8_U12_U12
) | OP_DST
)
2467 if (SCM_LIKELY (scm_is_string (str
)))
2468 RETURN (SCM_I_MAKINUM (scm_i_string_length (str
)));
2472 RETURN (scm_string_length (str
));
2476 /* string-ref dst:8 src:8 idx:8
2478 * Fetch the character at position IDX in the string in SRC, and store
2481 VM_DEFINE_OP (67, string_ref
, "string-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2483 scm_t_signed_bits i
= 0;
2485 if (SCM_LIKELY (scm_is_string (str
)
2486 && SCM_I_INUMP (idx
)
2487 && ((i
= SCM_I_INUM (idx
)) >= 0)
2488 && i
< scm_i_string_length (str
)))
2489 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str
, i
)));
2493 RETURN (scm_string_ref (str
, idx
));
2497 /* No string-set! instruction, as there is no good fast path there. */
2499 /* string-to-number dst:12 src:12
2501 * Parse a string in SRC to a number, and store in DST.
2503 VM_DEFINE_OP (68, string_to_number
, "string->number", OP1 (U8_U12_U12
) | OP_DST
)
2505 scm_t_uint16 dst
, src
;
2507 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2510 scm_string_to_number (LOCAL_REF (src
),
2511 SCM_UNDEFINED
/* radix = 10 */));
2515 /* string-to-symbol dst:12 src:12
2517 * Parse a string in SRC to a symbol, and store in DST.
2519 VM_DEFINE_OP (69, string_to_symbol
, "string->symbol", OP1 (U8_U12_U12
) | OP_DST
)
2521 scm_t_uint16 dst
, src
;
2523 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2525 LOCAL_SET (dst
, scm_string_to_symbol (LOCAL_REF (src
)));
2529 /* symbol->keyword dst:12 src:12
2531 * Make a keyword from the symbol in SRC, and store it in DST.
2533 VM_DEFINE_OP (70, symbol_to_keyword
, "symbol->keyword", OP1 (U8_U12_U12
) | OP_DST
)
2535 scm_t_uint16 dst
, src
;
2536 SCM_UNPACK_RTL_12_12 (op
, dst
, src
);
2538 LOCAL_SET (dst
, scm_symbol_to_keyword (LOCAL_REF (src
)));
2548 /* cons dst:8 car:8 cdr:8
2550 * Cons CAR and CDR, and store the result in DST.
2552 VM_DEFINE_OP (71, cons
, "cons", OP1 (U8_U8_U8_U8
) | OP_DST
)
2555 RETURN (scm_cons (x
, y
));
2558 /* car dst:12 src:12
2560 * Place the car of SRC in DST.
2562 VM_DEFINE_OP (72, car
, "car", OP1 (U8_U12_U12
) | OP_DST
)
2565 VM_VALIDATE_PAIR (x
, "car");
2566 RETURN (SCM_CAR (x
));
2569 /* cdr dst:12 src:12
2571 * Place the cdr of SRC in DST.
2573 VM_DEFINE_OP (73, cdr
, "cdr", OP1 (U8_U12_U12
) | OP_DST
)
2576 VM_VALIDATE_PAIR (x
, "cdr");
2577 RETURN (SCM_CDR (x
));
2580 /* set-car! pair:12 car:12
2582 * Set the car of DST to SRC.
2584 VM_DEFINE_OP (74, set_car
, "set-car!", OP1 (U8_U12_U12
))
2588 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2591 VM_VALIDATE_PAIR (x
, "set-car!");
2596 /* set-cdr! pair:12 cdr:12
2598 * Set the cdr of DST to SRC.
2600 VM_DEFINE_OP (75, set_cdr
, "set-cdr!", OP1 (U8_U12_U12
))
2604 SCM_UNPACK_RTL_12_12 (op
, a
, b
);
2607 VM_VALIDATE_PAIR (x
, "set-car!");
2616 * Numeric operations
2619 /* add dst:8 a:8 b:8
2621 * Add A to B, and place the result in DST.
2623 VM_DEFINE_OP (76, add
, "add", OP1 (U8_U8_U8_U8
) | OP_DST
)
2625 BINARY_INTEGER_OP (+, scm_sum
);
2628 /* add1 dst:12 src:12
2630 * Add 1 to the value in SRC, and place the result in DST.
2632 VM_DEFINE_OP (77, add1
, "add1", OP1 (U8_U12_U12
) | OP_DST
)
2636 /* Check for overflow. We must avoid overflow in the signed
2637 addition below, even if X is not an inum. */
2638 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) <= INUM_MAX
- INUM_STEP
))
2642 /* Add 1 to the integer without untagging. */
2643 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) + INUM_STEP
);
2645 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2650 RETURN (scm_sum (x
, SCM_I_MAKINUM (1)));
2653 /* sub dst:8 a:8 b:8
2655 * Subtract B from A, and place the result in DST.
2657 VM_DEFINE_OP (78, sub
, "sub", OP1 (U8_U8_U8_U8
) | OP_DST
)
2659 BINARY_INTEGER_OP (-, scm_difference
);
2662 /* sub1 dst:12 src:12
2664 * Subtract 1 from SRC, and place the result in DST.
2666 VM_DEFINE_OP (79, sub1
, "sub1", OP1 (U8_U12_U12
) | OP_DST
)
2670 /* Check for overflow. We must avoid overflow in the signed
2671 subtraction below, even if X is not an inum. */
2672 if (SCM_LIKELY ((scm_t_signed_bits
) SCM_UNPACK (x
) >= INUM_MIN
+ INUM_STEP
))
2676 /* Substract 1 from the integer without untagging. */
2677 result
= SCM_PACK ((scm_t_signed_bits
) SCM_UNPACK (x
) - INUM_STEP
);
2679 if (SCM_LIKELY (SCM_I_INUMP (result
)))
2684 RETURN (scm_difference (x
, SCM_I_MAKINUM (1)));
2687 /* mul dst:8 a:8 b:8
2689 * Multiply A and B, and place the result in DST.
2691 VM_DEFINE_OP (80, mul
, "mul", OP1 (U8_U8_U8_U8
) | OP_DST
)
2695 RETURN (scm_product (x
, y
));
2698 /* div dst:8 a:8 b:8
2700 * Divide A by B, and place the result in DST.
2702 VM_DEFINE_OP (81, div
, "div", OP1 (U8_U8_U8_U8
) | OP_DST
)
2706 RETURN (scm_divide (x
, y
));
2709 /* quo dst:8 a:8 b:8
2711 * Divide A by B, and place the quotient in DST.
2713 VM_DEFINE_OP (82, quo
, "quo", OP1 (U8_U8_U8_U8
) | OP_DST
)
2717 RETURN (scm_quotient (x
, y
));
2720 /* rem dst:8 a:8 b:8
2722 * Divide A by B, and place the remainder in DST.
2724 VM_DEFINE_OP (83, rem
, "rem", OP1 (U8_U8_U8_U8
) | OP_DST
)
2728 RETURN (scm_remainder (x
, y
));
2731 /* mod dst:8 a:8 b:8
2733 * Place the modulo of A by B in DST.
2735 VM_DEFINE_OP (84, mod
, "mod", OP1 (U8_U8_U8_U8
) | OP_DST
)
2739 RETURN (scm_modulo (x
, y
));
2742 /* ash dst:8 a:8 b:8
2744 * Shift A arithmetically by B bits, and place the result in DST.
2746 VM_DEFINE_OP (85, ash
, "ash", OP1 (U8_U8_U8_U8
) | OP_DST
)
2749 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2751 if (SCM_I_INUM (y
) < 0)
2752 /* Right shift, will be a fixnum. */
2753 RETURN (SCM_I_MAKINUM
2754 (SCM_SRS (SCM_I_INUM (x
),
2755 (-SCM_I_INUM (y
) <= SCM_I_FIXNUM_BIT
-1)
2756 ? -SCM_I_INUM (y
) : SCM_I_FIXNUM_BIT
-1)));
2758 /* Left shift. See comments in scm_ash. */
2760 scm_t_signed_bits nn
, bits_to_shift
;
2762 nn
= SCM_I_INUM (x
);
2763 bits_to_shift
= SCM_I_INUM (y
);
2765 if (bits_to_shift
< SCM_I_FIXNUM_BIT
-1
2767 (SCM_SRS (nn
, (SCM_I_FIXNUM_BIT
-1 - bits_to_shift
)) + 1)
2769 RETURN (SCM_I_MAKINUM (nn
<< bits_to_shift
));
2775 RETURN (scm_ash (x
, y
));
2778 /* logand dst:8 a:8 b:8
2780 * Place the bitwise AND of A and B into DST.
2782 VM_DEFINE_OP (86, logand
, "logand", OP1 (U8_U8_U8_U8
) | OP_DST
)
2785 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2786 /* Compute bitwise AND without untagging */
2787 RETURN (SCM_PACK (SCM_UNPACK (x
) & SCM_UNPACK (y
)));
2789 RETURN (scm_logand (x
, y
));
2792 /* logior dst:8 a:8 b:8
2794 * Place the bitwise inclusive OR of A with B in DST.
2796 VM_DEFINE_OP (87, logior
, "logior", OP1 (U8_U8_U8_U8
) | OP_DST
)
2799 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2800 /* Compute bitwise OR without untagging */
2801 RETURN (SCM_PACK (SCM_UNPACK (x
) | SCM_UNPACK (y
)));
2803 RETURN (scm_logior (x
, y
));
2806 /* logxor dst:8 a:8 b:8
2808 * Place the bitwise exclusive OR of A with B in DST.
2810 VM_DEFINE_OP (88, logxor
, "logxor", OP1 (U8_U8_U8_U8
) | OP_DST
)
2813 if (SCM_I_INUMP (x
) && SCM_I_INUMP (y
))
2814 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x
) ^ SCM_I_INUM (y
)));
2816 RETURN (scm_logxor (x
, y
));
2819 /* vector-length dst:12 src:12
2821 * Store the length of the vector in SRC in DST.
2823 VM_DEFINE_OP (89, vector_length
, "vector-length", OP1 (U8_U12_U12
) | OP_DST
)
2826 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect
)))
2827 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect
)));
2831 RETURN (scm_vector_length (vect
));
2835 /* vector-ref dst:8 src:8 idx:8
2837 * Fetch the item at position IDX in the vector in SRC, and store it
2840 VM_DEFINE_OP (90, vector_ref
, "vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2842 scm_t_signed_bits i
= 0;
2844 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2845 && SCM_I_INUMP (idx
)
2846 && ((i
= SCM_I_INUM (idx
)) >= 0)
2847 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2848 RETURN (SCM_I_VECTOR_ELTS (vect
)[i
]);
2852 RETURN (scm_vector_ref (vect
, idx
));
2856 /* constant-vector-ref dst:8 src:8 idx:8
2858 * Fill DST with the item IDX elements into the vector at SRC. Useful
2859 * for building data types using vectors.
2861 VM_DEFINE_OP (91, constant_vector_ref
, "constant-vector-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2863 scm_t_uint8 dst
, src
, idx
;
2866 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
2867 v
= LOCAL_REF (src
);
2868 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v
)
2869 && idx
< SCM_I_VECTOR_LENGTH (v
)))
2870 LOCAL_SET (dst
, SCM_I_VECTOR_ELTS (LOCAL_REF (src
))[idx
]);
2872 LOCAL_SET (dst
, scm_c_vector_ref (v
, idx
));
2876 /* vector-set! dst:8 idx:8 src:8
2878 * Store SRC into the vector DST at index IDX.
2880 VM_DEFINE_OP (92, vector_set
, "vector-set", OP1 (U8_U8_U8_U8
))
2882 scm_t_uint8 dst
, idx_var
, src
;
2884 scm_t_signed_bits i
= 0;
2886 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx_var
, src
);
2887 vect
= LOCAL_REF (dst
);
2888 idx
= LOCAL_REF (idx_var
);
2889 val
= LOCAL_REF (src
);
2891 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect
)
2892 && SCM_I_INUMP (idx
)
2893 && ((i
= SCM_I_INUM (idx
)) >= 0)
2894 && i
< SCM_I_VECTOR_LENGTH (vect
)))
2895 SCM_I_VECTOR_WELTS (vect
)[i
] = val
;
2899 scm_vector_set_x (vect
, idx
, val
);
2911 /* struct-vtable dst:12 src:12
2913 * Store the vtable of SRC into DST.
2915 VM_DEFINE_OP (93, struct_vtable
, "struct-vtable", OP1 (U8_U12_U12
) | OP_DST
)
2918 VM_VALIDATE_STRUCT (obj
, "struct_vtable");
2919 RETURN (SCM_STRUCT_VTABLE (obj
));
2922 /* allocate-struct dst:8 vtable:8 nfields:8
2924 * Allocate a new struct with VTABLE, and place it in DST. The struct
2925 * will be constructed with space for NFIELDS fields, which should
2926 * correspond to the field count of the VTABLE.
2928 VM_DEFINE_OP (94, allocate_struct
, "allocate-struct", OP1 (U8_U8_U8_U8
) | OP_DST
)
2930 scm_t_uint8 dst
, vtable
, nfields
;
2933 SCM_UNPACK_RTL_8_8_8 (op
, dst
, vtable
, nfields
);
2936 ret
= scm_allocate_struct (LOCAL_REF (vtable
), SCM_I_MAKINUM (nfields
));
2937 LOCAL_SET (dst
, ret
);
2942 /* struct-ref dst:8 src:8 idx:8
2944 * Fetch the item at slot IDX in the struct in SRC, and store it
2947 VM_DEFINE_OP (95, struct_ref
, "struct-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
2951 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2952 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2953 SCM_VTABLE_FLAG_SIMPLE
)
2954 && SCM_I_INUMP (pos
)))
2957 scm_t_bits index
, len
;
2959 /* True, an inum is a signed value, but cast to unsigned it will
2960 certainly be more than the length, so we will fall through if
2961 index is negative. */
2962 index
= SCM_I_INUM (pos
);
2963 vtable
= SCM_STRUCT_VTABLE (obj
);
2964 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
2966 if (SCM_LIKELY (index
< len
))
2968 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
2969 RETURN (SCM_PACK (data
[index
]));
2974 RETURN (scm_struct_ref (obj
, pos
));
2977 /* struct-set! dst:8 idx:8 src:8
2979 * Store SRC into the struct DST at slot IDX.
2981 VM_DEFINE_OP (96, struct_set
, "struct-set!", OP1 (U8_U8_U8_U8
))
2983 scm_t_uint8 dst
, idx
, src
;
2986 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
2987 obj
= LOCAL_REF (dst
);
2988 pos
= LOCAL_REF (idx
);
2989 val
= LOCAL_REF (src
);
2991 if (SCM_LIKELY (SCM_STRUCTP (obj
)
2992 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2993 SCM_VTABLE_FLAG_SIMPLE
)
2994 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj
,
2995 SCM_VTABLE_FLAG_SIMPLE_RW
)
2996 && SCM_I_INUMP (pos
)))
2999 scm_t_bits index
, len
;
3001 /* See above regarding index being >= 0. */
3002 index
= SCM_I_INUM (pos
);
3003 vtable
= SCM_STRUCT_VTABLE (obj
);
3004 len
= SCM_STRUCT_DATA_REF (vtable
, scm_vtable_index_size
);
3005 if (SCM_LIKELY (index
< len
))
3007 scm_t_bits
*data
= SCM_STRUCT_DATA (obj
);
3008 data
[index
] = SCM_UNPACK (val
);
3014 scm_struct_set_x (obj
, pos
, val
);
3018 /* class-of dst:12 type:12
3020 * Store the vtable of SRC into DST.
3022 VM_DEFINE_OP (97, class_of
, "class-of", OP1 (U8_U12_U12
) | OP_DST
)
3025 if (SCM_INSTANCEP (obj
))
3026 RETURN (SCM_CLASS_OF (obj
));
3028 RETURN (scm_class_of (obj
));
3031 /* slot-ref dst:8 src:8 idx:8
3033 * Fetch the item at slot IDX in the struct in SRC, and store it in
3034 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3035 * index into the stack.
3037 VM_DEFINE_OP (98, slot_ref
, "slot-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3039 scm_t_uint8 dst
, src
, idx
;
3040 SCM_UNPACK_RTL_8_8_8 (op
, dst
, src
, idx
);
3042 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src
))[idx
]));
3046 /* slot-set! dst:8 idx:8 src:8
3048 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3049 * IDX is an 8-bit immediate value, not an index into the stack.
3051 VM_DEFINE_OP (99, slot_set
, "slot-set!", OP1 (U8_U8_U8_U8
))
3053 scm_t_uint8 dst
, idx
, src
;
3054 SCM_UNPACK_RTL_8_8_8 (op
, dst
, idx
, src
);
3055 SCM_STRUCT_DATA (LOCAL_REF (dst
))[idx
] = SCM_UNPACK (LOCAL_REF (src
));
3063 * Arrays, packed uniform arrays, and bytevectors.
3066 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3068 * Load the contiguous typed array located at OFFSET 32-bit words away
3069 * from the instruction pointer, and store into DST. LEN is a byte
3070 * length. OFFSET is signed.
3072 VM_DEFINE_OP (100, load_typed_array
, "load-typed-array", OP3 (U8_U8_U8_U8
, N32
, U32
) | OP_DST
)
3074 scm_t_uint8 dst
, type
, shape
;
3078 SCM_UNPACK_RTL_8_8_8 (op
, dst
, type
, shape
);
3082 LOCAL_SET (dst
, scm_from_contiguous_typed_array (LOCAL_REF (type
),
3088 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3090 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3092 VM_DEFINE_OP (101, make_array
, "make-array", OP2 (U8_U12_U12
, X8_U12_U12
) | OP_DST
)
3094 scm_t_uint16 dst
, type
, fill
, bounds
;
3095 SCM_UNPACK_RTL_12_12 (op
, dst
, type
);
3096 SCM_UNPACK_RTL_12_12 (ip
[1], fill
, bounds
);
3098 LOCAL_SET (dst
, scm_make_typed_array (LOCAL_REF (type
), LOCAL_REF (fill
),
3099 LOCAL_REF (bounds
)));
3103 /* bv-u8-ref dst:8 src:8 idx:8
3104 * bv-s8-ref dst:8 src:8 idx:8
3105 * bv-u16-ref dst:8 src:8 idx:8
3106 * bv-s16-ref dst:8 src:8 idx:8
3107 * bv-u32-ref dst:8 src:8 idx:8
3108 * bv-s32-ref dst:8 src:8 idx:8
3109 * bv-u64-ref dst:8 src:8 idx:8
3110 * bv-s64-ref dst:8 src:8 idx:8
3111 * bv-f32-ref dst:8 src:8 idx:8
3112 * bv-f64-ref dst:8 src:8 idx:8
3114 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3115 * it in DST. All accesses use native endianness.
3117 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3119 scm_t_signed_bits i; \
3120 const scm_t_ ## type *int_ptr; \
3123 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3124 i = SCM_I_INUM (idx); \
3125 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3127 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3129 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3130 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3131 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3135 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3139 #define BV_INT_REF(stem, type, size) \
3141 scm_t_signed_bits i; \
3142 const scm_t_ ## type *int_ptr; \
3145 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3146 i = SCM_I_INUM (idx); \
3147 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3149 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3151 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3152 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3154 scm_t_ ## type x = *int_ptr; \
3155 if (SCM_FIXABLE (x)) \
3156 RETURN (SCM_I_MAKINUM (x)); \
3160 RETURN (scm_from_ ## type (x)); \
3166 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3170 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3172 scm_t_signed_bits i; \
3173 const type *float_ptr; \
3176 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3177 i = SCM_I_INUM (idx); \
3178 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3181 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3183 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3184 && (ALIGNED_P (float_ptr, type)))) \
3185 RETURN (scm_from_double (*float_ptr)); \
3187 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3190 VM_DEFINE_OP (102, bv_u8_ref
, "bv-u8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3191 BV_FIXABLE_INT_REF (u8
, u8
, uint8
, 1);
3193 VM_DEFINE_OP (103, bv_s8_ref
, "bv-s8-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3194 BV_FIXABLE_INT_REF (s8
, s8
, int8
, 1);
3196 VM_DEFINE_OP (104, bv_u16_ref
, "bv-u16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3197 BV_FIXABLE_INT_REF (u16
, u16_native
, uint16
, 2);
3199 VM_DEFINE_OP (105, bv_s16_ref
, "bv-s16-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3200 BV_FIXABLE_INT_REF (s16
, s16_native
, int16
, 2);
3202 VM_DEFINE_OP (106, bv_u32_ref
, "bv-u32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3203 #if SIZEOF_VOID_P > 4
3204 BV_FIXABLE_INT_REF (u32
, u32_native
, uint32
, 4);
3206 BV_INT_REF (u32
, uint32
, 4);
3209 VM_DEFINE_OP (107, bv_s32_ref
, "bv-s32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3210 #if SIZEOF_VOID_P > 4
3211 BV_FIXABLE_INT_REF (s32
, s32_native
, int32
, 4);
3213 BV_INT_REF (s32
, int32
, 4);
3216 VM_DEFINE_OP (108, bv_u64_ref
, "bv-u64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3217 BV_INT_REF (u64
, uint64
, 8);
3219 VM_DEFINE_OP (109, bv_s64_ref
, "bv-s64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3220 BV_INT_REF (s64
, int64
, 8);
3222 VM_DEFINE_OP (110, bv_f32_ref
, "bv-f32-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3223 BV_FLOAT_REF (f32
, ieee_single
, float, 4);
3225 VM_DEFINE_OP (111, bv_f64_ref
, "bv-f64-ref", OP1 (U8_U8_U8_U8
) | OP_DST
)
3226 BV_FLOAT_REF (f64
, ieee_double
, double, 8);
3228 /* bv-u8-set! dst:8 idx:8 src:8
3229 * bv-s8-set! dst:8 idx:8 src:8
3230 * bv-u16-set! dst:8 idx:8 src:8
3231 * bv-s16-set! dst:8 idx:8 src:8
3232 * bv-u32-set! dst:8 idx:8 src:8
3233 * bv-s32-set! dst:8 idx:8 src:8
3234 * bv-u64-set! dst:8 idx:8 src:8
3235 * bv-s64-set! dst:8 idx:8 src:8
3236 * bv-f32-set! dst:8 idx:8 src:8
3237 * bv-f64-set! dst:8 idx:8 src:8
3239 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3240 * values are written using native endianness.
3242 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3244 scm_t_uint8 dst, idx, src; \
3245 scm_t_signed_bits i, j = 0; \
3246 SCM bv, scm_idx, val; \
3247 scm_t_ ## type *int_ptr; \
3249 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3250 bv = LOCAL_REF (dst); \
3251 scm_idx = LOCAL_REF (idx); \
3252 val = LOCAL_REF (src); \
3253 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3254 i = SCM_I_INUM (scm_idx); \
3255 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3257 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3259 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3260 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3261 && (SCM_I_INUMP (val)) \
3262 && ((j = SCM_I_INUM (val)) >= min) \
3264 *int_ptr = (scm_t_ ## type) j; \
3268 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3273 #define BV_INT_SET(stem, type, size) \
3275 scm_t_uint8 dst, idx, src; \
3276 scm_t_signed_bits i; \
3277 SCM bv, scm_idx, val; \
3278 scm_t_ ## type *int_ptr; \
3280 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3281 bv = LOCAL_REF (dst); \
3282 scm_idx = LOCAL_REF (idx); \
3283 val = LOCAL_REF (src); \
3284 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3285 i = SCM_I_INUM (scm_idx); \
3286 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3288 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3290 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3291 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3292 *int_ptr = scm_to_ ## type (val); \
3296 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3301 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3303 scm_t_uint8 dst, idx, src; \
3304 scm_t_signed_bits i; \
3305 SCM bv, scm_idx, val; \
3308 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3309 bv = LOCAL_REF (dst); \
3310 scm_idx = LOCAL_REF (idx); \
3311 val = LOCAL_REF (src); \
3312 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3313 i = SCM_I_INUM (scm_idx); \
3314 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3316 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3318 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3319 && (ALIGNED_P (float_ptr, type)))) \
3320 *float_ptr = scm_to_double (val); \
3324 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3329 VM_DEFINE_OP (112, bv_u8_set
, "bv-u8-set!", OP1 (U8_U8_U8_U8
))
3330 BV_FIXABLE_INT_SET (u8
, u8
, uint8
, 0, SCM_T_UINT8_MAX
, 1);
3332 VM_DEFINE_OP (113, bv_s8_set
, "bv-s8-set!", OP1 (U8_U8_U8_U8
))
3333 BV_FIXABLE_INT_SET (s8
, s8
, int8
, SCM_T_INT8_MIN
, SCM_T_INT8_MAX
, 1);
3335 VM_DEFINE_OP (114, bv_u16_set
, "bv-u16-set!", OP1 (U8_U8_U8_U8
))
3336 BV_FIXABLE_INT_SET (u16
, u16_native
, uint16
, 0, SCM_T_UINT16_MAX
, 2);
3338 VM_DEFINE_OP (115, bv_s16_set
, "bv-s16-set!", OP1 (U8_U8_U8_U8
))
3339 BV_FIXABLE_INT_SET (s16
, s16_native
, int16
, SCM_T_INT16_MIN
, SCM_T_INT16_MAX
, 2);
3341 VM_DEFINE_OP (116, bv_u32_set
, "bv-u32-set!", OP1 (U8_U8_U8_U8
))
3342 #if SIZEOF_VOID_P > 4
3343 BV_FIXABLE_INT_SET (u32
, u32_native
, uint32
, 0, SCM_T_UINT32_MAX
, 4);
3345 BV_INT_SET (u32
, uint32
, 4);
3348 VM_DEFINE_OP (117, bv_s32_set
, "bv-s32-set!", OP1 (U8_U8_U8_U8
))
3349 #if SIZEOF_VOID_P > 4
3350 BV_FIXABLE_INT_SET (s32
, s32_native
, int32
, SCM_T_INT32_MIN
, SCM_T_INT32_MAX
, 4);
3352 BV_INT_SET (s32
, int32
, 4);
3355 VM_DEFINE_OP (118, bv_u64_set
, "bv-u64-set!", OP1 (U8_U8_U8_U8
))
3356 BV_INT_SET (u64
, uint64
, 8);
3358 VM_DEFINE_OP (119, bv_s64_set
, "bv-s64-set!", OP1 (U8_U8_U8_U8
))
3359 BV_INT_SET (s64
, int64
, 8);
3361 VM_DEFINE_OP (120, bv_f32_set
, "bv-f32-set!", OP1 (U8_U8_U8_U8
))
3362 BV_FLOAT_SET (f32
, ieee_single
, float, 4);
3364 VM_DEFINE_OP (121, bv_f64_set
, "bv-f64-set!", OP1 (U8_U8_U8_U8
))
3365 BV_FLOAT_SET (f64
, ieee_double
, double, 8);
3367 END_DISPATCH_SWITCH
;
3369 vm_error_bad_instruction
:
3370 vm_error_bad_instruction (op
);
3372 abort (); /* never reached */
3376 #undef ABORT_CONTINUATION_HOOK
3381 #undef BEGIN_DISPATCH_SWITCH
3382 #undef BINARY_INTEGER_OP
3383 #undef BR_ARITHMETIC
3387 #undef BV_FIXABLE_INT_REF
3388 #undef BV_FIXABLE_INT_SET
3393 #undef CACHE_REGISTER
3394 #undef CHECK_OVERFLOW
3395 #undef END_DISPATCH_SWITCH
3396 #undef FREE_VARIABLE_REF
3405 #undef POP_CONTINUATION_HOOK
3406 #undef PUSH_CONTINUATION_HOOK
3407 #undef RESTORE_CONTINUATION_HOOK
3409 #undef RETURN_ONE_VALUE
3410 #undef RETURN_VALUE_LIST
3414 #undef SYNC_BEFORE_GC
3416 #undef SYNC_REGISTER
3417 #undef VARIABLE_BOUNDP
3420 #undef VM_CHECK_FREE_VARIABLE
3421 #undef VM_CHECK_OBJECT
3422 #undef VM_CHECK_UNDERFLOW
3424 #undef VM_INSTRUCTION_TO_LABEL
3426 #undef VM_VALIDATE_BYTEVECTOR
3427 #undef VM_VALIDATE_PAIR
3428 #undef VM_VALIDATE_STRUCT
3431 (defun renumber-ops ()
3432 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3435 (let ((counter -1)) (goto-char (point-min))
3436 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3438 (number-to-string (setq counter (1+ counter)))