RTL: Compile prompts
[bpt/guile.git] / libguile / vm-engine.c
1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
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
16 * 02110-1301 USA
17 */
18
19 /* This file is included in vm.c multiple times. */
20
21
22 /* Virtual Machine
23
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.
28
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.
34
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. */
40
41
42 /* The old VM. */
43 static SCM VM_NAME (SCM, SCM, SCM*, int);
44 /* The new VM. */
45 static SCM RTL_VM_NAME (SCM, SCM, SCM*, size_t);
46
47
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
52 #else
53 # error unknown debug engine VM_ENGINE
54 #endif
55
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. */
61 #ifdef __GNUC__
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
65 callee-saved. */
66 # define JT_REG asm ("r12")
67 # endif
68 #endif
69
70 #ifndef IP_REG
71 # define IP_REG
72 #endif
73 #ifndef SP_REG
74 # define SP_REG
75 #endif
76 #ifndef FP_REG
77 # define FP_REG
78 #endif
79 #ifndef JT_REG
80 # define JT_REG
81 #endif
82
83 #define VM_ASSERT(condition, handler) \
84 do { \
85 if (SCM_UNLIKELY (!(condition))) \
86 { \
87 SYNC_ALL(); \
88 handler; \
89 } \
90 } while (0)
91
92 #ifdef VM_ENABLE_ASSERTIONS
93 # define ASSERT(condition) VM_ASSERT (condition, abort())
94 #else
95 # define ASSERT(condition)
96 #endif
97
98 #if VM_USE_HOOKS
99 #define RUN_HOOK(h, args, n) \
100 do { \
101 if (SCM_UNLIKELY (vp->trace_level > 0)) \
102 { \
103 SYNC_REGISTER (); \
104 vm_dispatch_hook (vm, h, args, n); \
105 } \
106 } while (0)
107 #else
108 #define RUN_HOOK(h, args, n)
109 #endif
110 #define RUN_HOOK0(h) RUN_HOOK(h, NULL, 0)
111
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)
124
125 #define VM_HANDLE_INTERRUPTS \
126 SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
127
128
129 \f
130
131 /* Cache the VM's instruction, stack, and frame pointer in local variables. */
132 #define CACHE_REGISTER() \
133 { \
134 ip = vp->ip; \
135 sp = vp->sp; \
136 fp = vp->fp; \
137 }
138
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() \
143 { \
144 vp->ip = ip; \
145 vp->sp = sp; \
146 vp->fp = fp; \
147 }
148
149 /* FIXME */
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), \
155 abort())
156
157 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
158 #define CHECK_IP() \
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())
164 #else
165 #define CHECK_IP()
166 #define ASSERT_ALIGNED_PROCEDURE()
167 #define ASSERT_BOUND(x)
168 #endif
169
170 /* Cache the object table and free variables. */
171 #define CACHE_PROGRAM() \
172 { \
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)); \
178 } else { \
179 objects = NULL; \
180 } \
181 } \
182 }
183
184 #define SYNC_BEFORE_GC() \
185 { \
186 SYNC_REGISTER (); \
187 }
188
189 #define SYNC_ALL() \
190 { \
191 SYNC_REGISTER (); \
192 }
193
194 \f
195 /*
196 * Error check
197 */
198
199 /* Accesses to a program's object table. */
200 #define CHECK_OBJECT(_num)
201 #define CHECK_FREE_VARIABLE(_num)
202
203 \f
204 /*
205 * Stack operation
206 */
207
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
216 fix that. */
217 # define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
218 #else
219 # define CHECK_STACK_LEAKN(_n)
220 # define CHECK_STACK_LEAK()
221 # define NULLSTACK(_n)
222 # define NULLSTACK_FOR_NONLOCAL_EXIT()
223 #endif
224
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)
230
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)
235 #else
236 #define PRE_CHECK_UNDERFLOW(N) /* nop */
237 #define CHECK_UNDERFLOW() /* nop */
238 #endif
239
240
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)
247
248 /* Pop the N objects on top of the stack and push a list that contains
249 them. */
250 #define POP_LIST(n) \
251 do \
252 { \
253 int i; \
254 SCM l = SCM_EOL, x; \
255 SYNC_BEFORE_GC (); \
256 for (i = n; i; i--) \
257 { \
258 POP (x); \
259 l = scm_cons (x, l); \
260 } \
261 PUSH (l); \
262 } while (0)
263
264 /* The opposite: push all of the elements in L onto the list. */
265 #define PUSH_LIST(l, NILP) \
266 do \
267 { \
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)); \
271 } while (0)
272
273 \f
274 /*
275 * Instruction operation
276 */
277
278 #define FETCH() (*ip++)
279 #define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
280
281 #undef NEXT_JUMP
282 #ifdef HAVE_LABELS_AS_VALUES
283 # define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
284 #else
285 # define NEXT_JUMP() goto vm_start
286 #endif
287
288 #define NEXT \
289 { \
290 NEXT_HOOK (); \
291 CHECK_STACK_LEAK (); \
292 NEXT_JUMP (); \
293 }
294
295 \f
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() \
300 { \
301 sp -= 3; \
302 NULLSTACK (3); \
303 CHECK_UNDERFLOW (); \
304 }
305
306
307 static SCM
308 VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
309 {
310 /* VM registers */
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);
315
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 */
320
321 scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
322
323 /* Internal variables */
324 int nvalues = 0;
325 scm_i_jmp_buf registers; /* used for prompts */
326
327 #ifdef HAVE_LABELS_AS_VALUES
328 static const void **jump_table_pointer = NULL;
329 #endif
330
331 #ifdef HAVE_LABELS_AS_VALUES
332 register const void **jump_table JT_REG;
333
334 if (SCM_UNLIKELY (!jump_table_pointer))
335 {
336 int i;
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>
346 #undef jump_table
347 #undef VM_INSTRUCTION_TO_LABEL
348 }
349
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;
353 #endif
354
355 if (SCM_I_SETJMP (registers))
356 {
357 /* Non-local return. Cache the VM registers back from the vp, and
358 go to the handler.
359
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.
363 */
364 CACHE_REGISTER ();
365 program = SCM_FRAME_PROGRAM (fp);
366 CACHE_PROGRAM ();
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));
370 NEXT;
371 }
372
373 CACHE_REGISTER ();
374
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
377 arguments first. */
378 VM_ASSERT (sp + 8 + nargs < stack_limit, vm_error_too_many_args (nargs));
379 {
380 int i;
381 for (i = nargs - 1; i >= 0; i--)
382 sp[9 + i] = argv[i];
383 }
384
385 /* Initial frame */
386 PUSH (SCM_PACK (fp)); /* dynamic link */
387 PUSH (SCM_PACK (0)); /* mvra */
388 PUSH (SCM_PACK (ip)); /* ra */
389 PUSH (boot_continuation);
390 fp = sp + 1;
391 ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
392
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 */
397 PUSH (program);
398 fp = sp + 1;
399 sp += nargs;
400
401 PUSH_CONTINUATION_HOOK ();
402
403 apply:
404 program = fp[-1];
405 if (!SCM_PROGRAM_P (program))
406 {
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))
410 {
411 SCM ret;
412 SYNC_ALL ();
413
414 ret = RTL_VM_NAME (vm, program, fp, sp - fp + 1);
415
416 NULLSTACK_FOR_NONLOCAL_EXIT ();
417
418 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
419 {
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;
425 }
426 else
427 {
428 PUSH (ret);
429 goto vm_return;
430 }
431 }
432 else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
433 && SCM_SMOB_APPLICABLE_P (program))
434 {
435 /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
436 int i;
437 PUSH (SCM_BOOL_F);
438 for (i = sp - fp; i >= 0; i--)
439 fp[i] = fp[i - 1];
440 fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline;
441 }
442 else
443 {
444 SYNC_ALL();
445 vm_error_wrong_type_apply (program);
446 }
447 goto apply;
448 }
449
450 CACHE_PROGRAM ();
451 ip = SCM_C_OBJCODE_BASE (bp);
452
453 APPLY_HOOK ();
454
455 /* Let's go! */
456 NEXT;
457
458 #ifndef HAVE_LABELS_AS_VALUES
459 vm_start:
460 switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
461 #endif
462
463 #include "vm-expand.h"
464 #include "vm-i-system.c"
465 #include "vm-i-scheme.c"
466 #include "vm-i-loader.c"
467
468 #ifndef HAVE_LABELS_AS_VALUES
469 default:
470 goto vm_error_bad_instruction;
471 }
472 #endif
473
474 abort (); /* never reached */
475
476 vm_error_bad_instruction:
477 vm_error_bad_instruction (ip[-1]);
478 abort (); /* never reached */
479
480 handle_overflow:
481 SYNC_ALL ();
482 vm_error_stack_overflow (vp);
483 abort (); /* never reached */
484 }
485
486 #undef ALIGNED_P
487 #undef CACHE_REGISTER
488 #undef CHECK_OVERFLOW
489 #undef FUNC2
490 #undef INIT
491 #undef INUM_MAX
492 #undef INUM_MIN
493 #undef INUM_STEP
494 #undef jump_table
495 #undef LOCAL_REF
496 #undef LOCAL_SET
497 #undef NEXT
498 #undef NEXT_JUMP
499 #undef REL
500 #undef RETURN
501 #undef RETURN_ONE_VALUE
502 #undef RETURN_VALUE_LIST
503 #undef SYNC_ALL
504 #undef SYNC_BEFORE_GC
505 #undef SYNC_IP
506 #undef SYNC_REGISTER
507 #undef VARIABLE_BOUNDP
508 #undef VARIABLE_REF
509 #undef VARIABLE_SET
510 #undef VM_DEFINE_OP
511 #undef VM_INSTRUCTION_TO_LABEL
512
513
514 \f
515
516 /* Virtual Machine
517
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.
525
526 <more overview here>
527 */
528
529
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.
535
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
542 exception. */
543
544 #define SYNC_IP() \
545 vp->ip = (scm_t_uint8 *) (ip)
546
547 #define SYNC_REGISTER() \
548 SYNC_IP()
549 #define SYNC_BEFORE_GC() /* Only SP and FP needed to trace GC */
550 #define SYNC_ALL() /* FP already saved */ \
551 SYNC_IP()
552
553 #define CHECK_OVERFLOW(sp) \
554 do { \
555 if (SCM_UNLIKELY ((sp) >= stack_limit)) \
556 vm_error_stack_overflow (vp); \
557 } while (0)
558
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) \
564 do { \
565 SCM *new_sp = vp->sp = fp - 1 + n - 1; \
566 CHECK_OVERFLOW (new_sp + 4); \
567 } while (0)
568
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) \
572 do { \
573 vp->sp = fp - 2 + n; \
574 } while (0)
575
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))
581
582 /* Restore registers after returning from a frame. */
583 #define RESTORE_FRAME() \
584 do { \
585 } while (0)
586
587
588 #define CACHE_REGISTER() \
589 do { \
590 ip = (scm_t_uint32 *) vp->ip; \
591 fp = vp->fp; \
592 } while (0)
593
594 #ifdef HAVE_LABELS_AS_VALUES
595 # define BEGIN_DISPATCH_SWITCH /* */
596 # define END_DISPATCH_SWITCH /* */
597 # define NEXT(n) \
598 do \
599 { \
600 ip += n; \
601 NEXT_HOOK (); \
602 op = *ip; \
603 goto *jump_table[op & 0xff]; \
604 } \
605 while (0)
606 # define VM_DEFINE_OP(opcode, tag, name, meta) \
607 op_##tag:
608 #else
609 # define BEGIN_DISPATCH_SWITCH \
610 vm_start: \
611 NEXT_HOOK (); \
612 op = *ip; \
613 switch (op & 0xff) \
614 {
615 # define END_DISPATCH_SWITCH \
616 default: \
617 goto vm_error_bad_instruction; \
618 }
619 # define NEXT(n) \
620 do \
621 { \
622 ip += n; \
623 goto vm_start; \
624 } \
625 while (0)
626 # define VM_DEFINE_OP(opcode, tag, name, meta) \
627 op_##tag: \
628 case opcode:
629 #endif
630
631 #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, (i) - 1)
632 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, (i) - 1) = o
633
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))
637
638 #define RETURN_ONE_VALUE(ret) \
639 do { \
640 SCM val = 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); \
645 /* Clear frame. */ \
646 sp[0] = SCM_BOOL_F; \
647 sp[1] = SCM_BOOL_F; \
648 sp[2] = SCM_BOOL_F; \
649 /* Leave proc. */ \
650 sp[4] = val; \
651 vp->sp = sp + 4; \
652 POP_CONTINUATION_HOOK (sp, 1); \
653 NEXT (0); \
654 } while (0)
655
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_) \
659 do { \
660 SCM vals = vals_; \
661 VM_HANDLE_INTERRUPTS; \
662 fp[-1] = rtl_apply; \
663 fp[0] = rtl_values; \
664 fp[1] = vals; \
665 RESET_FRAME (3); \
666 ip = (scm_t_uint32 *) rtl_apply_code; \
667 goto op_tail_apply; \
668 } while (0)
669
670 #define BR_NARGS(rel) \
671 scm_t_uint16 expected; \
672 SCM_UNPACK_RTL_24 (op, expected); \
673 if (FRAME_LOCALS_COUNT() rel expected) \
674 { \
675 scm_t_int32 offset = ip[1]; \
676 offset >>= 8; /* Sign-extending shift. */ \
677 NEXT (offset); \
678 } \
679 NEXT (2)
680
681 #define BR_UNARY(x, exp) \
682 scm_t_uint32 test; \
683 SCM x; \
684 SCM_UNPACK_RTL_24 (op, test); \
685 x = LOCAL_REF (test); \
686 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
687 { \
688 scm_t_int32 offset = ip[1]; \
689 offset >>= 8; /* Sign-extending shift. */ \
690 if (offset < 0) \
691 VM_HANDLE_INTERRUPTS; \
692 NEXT (offset); \
693 } \
694 NEXT (2)
695
696 #define BR_BINARY(x, y, exp) \
697 scm_t_uint16 a, b; \
698 SCM x, y; \
699 SCM_UNPACK_RTL_12_12 (op, a, b); \
700 x = LOCAL_REF (a); \
701 y = LOCAL_REF (b); \
702 if ((ip[1] & 0x1) ? !(exp) : (exp)) \
703 { \
704 scm_t_int32 offset = ip[1]; \
705 offset >>= 8; /* Sign-extending shift. */ \
706 if (offset < 0) \
707 VM_HANDLE_INTERRUPTS; \
708 NEXT (offset); \
709 } \
710 NEXT (2)
711
712 #define BR_ARITHMETIC(crel,srel) \
713 { \
714 scm_t_uint16 a, b; \
715 SCM x, y; \
716 SCM_UNPACK_RTL_12_12 (op, a, b); \
717 x = LOCAL_REF (a); \
718 y = LOCAL_REF (b); \
719 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
720 { \
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)) \
724 { \
725 scm_t_int32 offset = ip[1]; \
726 offset >>= 8; /* Sign-extending shift. */ \
727 if (offset < 0) \
728 VM_HANDLE_INTERRUPTS; \
729 NEXT (offset); \
730 } \
731 NEXT (2); \
732 } \
733 else \
734 { \
735 SCM res; \
736 SYNC_IP (); \
737 res = srel (x, y); \
738 if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
739 { \
740 scm_t_int32 offset = ip[1]; \
741 offset >>= 8; /* Sign-extending shift. */ \
742 if (offset < 0) \
743 VM_HANDLE_INTERRUPTS; \
744 NEXT (offset); \
745 } \
746 NEXT (2); \
747 } \
748 }
749
750 #define ARGS1(a1) \
751 scm_t_uint16 dst, src; \
752 SCM a1; \
753 SCM_UNPACK_RTL_12_12 (op, dst, src); \
754 a1 = LOCAL_REF (src)
755 #define ARGS2(a1, a2) \
756 scm_t_uint8 dst, src1, src2; \
757 SCM a1, a2; \
758 SCM_UNPACK_RTL_8_8_8 (op, dst, src1, src2); \
759 a1 = LOCAL_REF (src1); \
760 a2 = LOCAL_REF (src2)
761 #define RETURN(x) \
762 do { LOCAL_SET (dst, x); NEXT (1); } while (0)
763
764 /* The maximum/minimum tagged integers. */
765 #define INUM_MAX \
766 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
767 #define INUM_MIN \
768 ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
769 #define INUM_STEP \
770 ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
771 - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
772
773 #define BINARY_INTEGER_OP(CFUNC,SFUNC) \
774 { \
775 ARGS2 (x, y); \
776 if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
777 { \
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)); \
781 } \
782 SYNC_IP (); \
783 RETURN (SFUNC (x, y)); \
784 }
785
786 #define VM_VALIDATE_PAIR(x, proc) \
787 VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
788
789 #define VM_VALIDATE_STRUCT(obj, proc) \
790 VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
791
792 #define VM_VALIDATE_BYTEVECTOR(x, proc) \
793 VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
794
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)
798
799 static SCM
800 RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t nargs_)
801 {
802 /* Instruction pointer: A pointer to the opcode that is currently
803 running. */
804 register scm_t_uint32 *ip IP_REG;
805
806 /* Frame pointer: A pointer into the stack, off of which we index
807 arguments and local variables. Pushed at function calls, popped on
808 returns. */
809 register SCM *fp FP_REG;
810
811 /* Current opcode: A cache of *ip. */
812 register scm_t_uint32 op;
813
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 */
819
820 #ifdef HAVE_LABELS_AS_VALUES
821 static const void **jump_table_pointer = NULL;
822 register const void **jump_table JT_REG;
823
824 if (SCM_UNLIKELY (!jump_table_pointer))
825 {
826 int i;
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);
832 #undef INIT
833 }
834
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;
838 #endif
839
840 if (SCM_I_SETJMP (registers))
841 {
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
845 body of `values'.
846
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.
850 */
851 CACHE_REGISTER ();
852 ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT());
853 NEXT (0);
854 }
855
856 /* Load previous VM registers. */
857 CACHE_REGISTER ();
858
859 VM_HANDLE_INTERRUPTS;
860
861 /* Initialization */
862 {
863 SCM *base;
864
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. */
868 base = vp->sp + 1;
869 CHECK_OVERFLOW (vp->sp + 4 + 4 + nargs_ + 4);
870
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
873 arguments first. */
874 {
875 int i;
876 for (i = nargs_ - 1; i >= 0; i--)
877 base[8 + i] = argv[i];
878 }
879
880 /* Initial frame, saving previous fp and ip, with the boot
881 continuation. */
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;
886 fp = &base[4];
887 ip = (scm_t_uint32 *) rtl_boot_continuation_code;
888
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 */
893 base[7] = program;
894 fp = vp->fp = &base[8];
895 RESET_FRAME (nargs_ + 1);
896 }
897
898 apply:
899 while (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp)))
900 {
901 #if 0
902 SCM proc = SCM_FRAME_PROGRAM (fp);
903
904 if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
905 {
906 fp[-1] = SCM_STRUCT_PROCEDURE (proc);
907 continue;
908 }
909 if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
910 {
911 scm_t_uint32 n = FRAME_LOCALS_COUNT();
912
913 /* Shuffle args up, place smob in local 0. */
914 CHECK_OVERFLOW (vp->sp + 1);
915 vp->sp++;
916 while (n--)
917 LOCAL_SET (n + 1, LOCAL_REF (n));
918
919 fp[-1] = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
920 continue;
921 }
922
923 SYNC_IP();
924 vm_error_wrong_type_apply (proc);
925 #else
926 SCM ret;
927 SYNC_ALL ();
928
929 ret = VM_NAME (vm, fp[-1], fp, FRAME_LOCALS_COUNT () - 1);
930
931 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
932 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
933 else
934 RETURN_ONE_VALUE (ret);
935 #endif
936 }
937
938 /* Let's go! */
939 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
940 NEXT (0);
941
942 BEGIN_DISPATCH_SWITCH;
943
944
945 \f
946
947 /*
948 * Call and return
949 */
950
951 /* halt _:24
952 *
953 * Bring the VM to a halt, returning all the values from the stack.
954 */
955 VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
956 {
957 scm_t_uint32 nvals = FRAME_LOCALS_COUNT() - 5;
958 SCM ret;
959
960 /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
961
962 if (nvals == 1)
963 ret = LOCAL_REF (5);
964 else
965 {
966 scm_t_uint32 n;
967 ret = SCM_EOL;
968 SYNC_BEFORE_GC();
969 for (n = nvals; n > 0; n--)
970 ret = scm_cons (LOCAL_REF (5 + n - 1), ret);
971 ret = scm_values (ret);
972 }
973
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);
977
978 return ret;
979 }
980
981 /* call proc:24 _:8 nlocals:24
982 *
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.
988 *
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.
993 */
994 VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
995 {
996 scm_t_uint32 proc, nlocals;
997 SCM *old_fp = fp;
998
999 SCM_UNPACK_RTL_24 (op, proc);
1000 SCM_UNPACK_RTL_24 (ip[1], nlocals);
1001
1002 VM_HANDLE_INTERRUPTS;
1003
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);
1008
1009 RESET_FRAME (nlocals);
1010
1011 PUSH_CONTINUATION_HOOK ();
1012 APPLY_HOOK ();
1013
1014 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1015 goto apply;
1016
1017 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1018 NEXT (0);
1019 }
1020
1021 /* tail-call nlocals:24
1022 *
1023 * Tail-call a procedure. Requires that the procedure and all of the
1024 * arguments have already been shuffled into position.
1025 */
1026 VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
1027 {
1028 scm_t_uint32 nlocals;
1029
1030 SCM_UNPACK_RTL_24 (op, nlocals);
1031
1032 VM_HANDLE_INTERRUPTS;
1033
1034 RESET_FRAME (nlocals);
1035 APPLY_HOOK ();
1036
1037 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1038 goto apply;
1039
1040 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1041 NEXT (0);
1042 }
1043
1044 /* receive dst:12 proc:12 _:8 nlocals:24
1045 *
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.
1049 */
1050 VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
1051 {
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);
1059 NEXT (2);
1060 }
1061
1062 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
1063 *
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'.
1069 */
1070 VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
1071 {
1072 scm_t_uint32 proc, nvalues;
1073 SCM_UNPACK_RTL_24 (op, proc);
1074 SCM_UNPACK_RTL_24 (ip[1], nvalues);
1075 if (ip[1] & 0x1)
1076 VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
1077 vm_error_not_enough_values ());
1078 else
1079 VM_ASSERT (FRAME_LOCALS_COUNT () == proc + nvalues,
1080 vm_error_wrong_number_of_values (nvalues));
1081 NEXT (2);
1082 }
1083
1084 /* return src:24
1085 *
1086 * Return a value.
1087 */
1088 VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
1089 {
1090 scm_t_uint32 src;
1091 SCM_UNPACK_RTL_24 (op, src);
1092 RETURN_ONE_VALUE (LOCAL_REF (src));
1093 }
1094
1095 /* return-values _:24
1096 *
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.
1102 */
1103 VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_X24))
1104 {
1105 scm_t_uint32 nvalues _GL_UNUSED = FRAME_LOCALS_COUNT();
1106 SCM *base = fp;
1107
1108 VM_HANDLE_INTERRUPTS;
1109 ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
1110 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
1111
1112 /* Clear stack frame. */
1113 base[-2] = SCM_BOOL_F;
1114 base[-3] = SCM_BOOL_F;
1115 base[-4] = SCM_BOOL_F;
1116
1117 POP_CONTINUATION_HOOK (base, nvalues);
1118
1119 NEXT (0);
1120 }
1121
1122
1123 \f
1124
1125 /*
1126 * Specialized call stubs
1127 */
1128
1129 /* subr-call ptr-idx:24
1130 *
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.
1135 */
1136 VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
1137 {
1138 scm_t_uint32 ptr_idx;
1139 SCM pointer, ret;
1140 SCM (*subr)();
1141
1142 SCM_UNPACK_RTL_24 (op, ptr_idx);
1143
1144 pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
1145 subr = SCM_POINTER_VALUE (pointer);
1146
1147 VM_HANDLE_INTERRUPTS;
1148 SYNC_IP ();
1149
1150 switch (FRAME_LOCALS_COUNT ())
1151 {
1152 case 0:
1153 ret = subr ();
1154 break;
1155 case 1:
1156 ret = subr (fp[0]);
1157 break;
1158 case 2:
1159 ret = subr (fp[0], fp[1]);
1160 break;
1161 case 3:
1162 ret = subr (fp[0], fp[1], fp[2]);
1163 break;
1164 case 4:
1165 ret = subr (fp[0], fp[1], fp[2], fp[3]);
1166 break;
1167 case 5:
1168 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]);
1169 break;
1170 case 6:
1171 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]);
1172 break;
1173 case 7:
1174 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
1175 break;
1176 case 8:
1177 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
1178 break;
1179 case 9:
1180 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
1181 break;
1182 case 10:
1183 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
1184 break;
1185 default:
1186 abort ();
1187 }
1188
1189 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1190
1191 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1192 /* multiple values returned to continuation */
1193 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1194 else
1195 RETURN_ONE_VALUE (ret);
1196 }
1197
1198 /* foreign-call cif-idx:12 ptr-idx:12
1199 *
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
1204 * the compiler.
1205 */
1206 VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
1207 {
1208 scm_t_uint16 cif_idx, ptr_idx;
1209 SCM closure, cif, pointer, ret;
1210
1211 SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
1212
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);
1216
1217 SYNC_IP ();
1218 VM_HANDLE_INTERRUPTS;
1219
1220 // FIXME: separate args
1221 ret = scm_i_foreign_call (scm_cons (cif, pointer), fp);
1222
1223 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1224
1225 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1226 /* multiple values returned to continuation */
1227 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1228 else
1229 RETURN_ONE_VALUE (ret);
1230 }
1231
1232 /* continuation-call contregs:24
1233 *
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.
1239 */
1240 VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
1241 {
1242 SCM contregs;
1243 scm_t_uint32 contregs_idx;
1244
1245 SCM_UNPACK_RTL_24 (op, contregs_idx);
1246
1247 contregs =
1248 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
1249
1250 SYNC_IP ();
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);
1256
1257 /* no NEXT */
1258 abort ();
1259 }
1260
1261 /* compose-continuation cont:24
1262 *
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.
1268 */
1269 VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
1270 {
1271 SCM vmcont;
1272 scm_t_uint32 cont_idx;
1273
1274 SCM_UNPACK_RTL_24 (op, cont_idx);
1275 vmcont = LOCAL_REF (cont_idx);
1276
1277 SYNC_IP ();
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 &current_thread->dynstack,
1282 &registers);
1283 CACHE_REGISTER ();
1284 NEXT (0);
1285 }
1286
1287 /* tail-apply _:24
1288 *
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.
1292 */
1293 VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
1294 {
1295 int i, list_idx, list_len, nargs;
1296 SCM list;
1297
1298 VM_HANDLE_INTERRUPTS;
1299
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);
1305
1306 VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
1307
1308 nargs = nargs - 2 + list_len;
1309 ALLOC_FRAME (nargs);
1310
1311 for (i = 0; i < list_idx; i++)
1312 LOCAL_SET(i - 1, LOCAL_REF (i));
1313
1314 /* Null out these slots, just in case there are less than 2 elements
1315 in the list. */
1316 LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
1317 LOCAL_SET (list_idx, SCM_UNDEFINED);
1318
1319 for (i = 0; i < list_len; i++, list = SCM_CDR (list))
1320 LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
1321
1322 APPLY_HOOK ();
1323
1324 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1325 goto apply;
1326
1327 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1328 NEXT (0);
1329 }
1330
1331 /* call/cc _:24
1332 *
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.
1336 */
1337 VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
1338 #if 0
1339 {
1340 SCM vm_cont, cont;
1341 scm_t_dynstack *dynstack;
1342
1343 VM_HANDLE_INTERRUPTS;
1344
1345 SYNC_IP ();
1346 dynstack = scm_dynstack_capture_all (&current_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),
1352 dynstack,
1353 0);
1354 cont = scm_i_make_continuation (&registers, vm, vm_cont);
1355
1356 fp[-1] = fp[0];
1357 fp[0] = cont;
1358 RESET_FRAME (2);
1359
1360 APPLY_HOOK ();
1361
1362 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1363 goto apply;
1364
1365 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1366 NEXT (0);
1367 }
1368 #else
1369 abort();
1370 #endif
1371
1372
1373 \f
1374
1375 /*
1376 * Function prologues
1377 */
1378
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
1382 *
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.
1386 */
1387 VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
1388 {
1389 BR_NARGS (!=);
1390 }
1391 VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
1392 {
1393 BR_NARGS (<);
1394 }
1395 VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
1396 {
1397 BR_NARGS (>);
1398 }
1399
1400 /* assert-nargs-ee expected:24
1401 * assert-nargs-ge expected:24
1402 * assert-nargs-le expected:24
1403 *
1404 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1405 * respectively, signal an error.
1406 */
1407 VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
1408 {
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)));
1413 NEXT (1);
1414 }
1415 VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
1416 {
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)));
1421 NEXT (1);
1422 }
1423 VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
1424 {
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)));
1429 NEXT (1);
1430 }
1431
1432 /* alloc-frame nlocals:24
1433 *
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.
1437 */
1438 VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
1439 {
1440 scm_t_uint32 nlocals, nargs;
1441 SCM_UNPACK_RTL_24 (op, nlocals);
1442
1443 nargs = FRAME_LOCALS_COUNT ();
1444 ALLOC_FRAME (nlocals);
1445 while (nlocals-- > nargs)
1446 LOCAL_SET (nlocals, SCM_UNDEFINED);
1447
1448 NEXT (1);
1449 }
1450
1451 /* reset-frame nlocals:24
1452 *
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.
1456 */
1457 VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
1458 {
1459 scm_t_uint32 nlocals;
1460 SCM_UNPACK_RTL_24 (op, nlocals);
1461 RESET_FRAME (nlocals);
1462 NEXT (1);
1463 }
1464
1465 /* assert-nargs-ee/locals expected:12 nlocals:12
1466 *
1467 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1468 * number of locals reserved is EXPECTED + NLOCALS.
1469 */
1470 VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
1471 {
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);
1477 while (nlocals--)
1478 LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
1479
1480 NEXT (1);
1481 }
1482
1483 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1484 * _:8 ntotal:24 kw-offset:32
1485 *
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.
1492 *
1493 * A macro-mega-instruction.
1494 */
1495 VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
1496 {
1497 scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
1498 scm_t_int32 kw_offset;
1499 scm_t_bits kw_bits;
1500 SCM kw;
1501 char allow_other_keys, has_rest;
1502
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);
1508 kw_offset = ip[3];
1509 kw_bits = (scm_t_bits) (ip + kw_offset);
1510 VM_ASSERT (!(kw_bits & 0x7), abort());
1511 kw = SCM_PACK (kw_bits);
1512
1513 nargs = FRAME_LOCALS_COUNT ();
1514
1515 /* look in optionals for first keyword or last positional */
1516 /* starting after the last required positional arg */
1517 npositional = nreq;
1518 while (/* while we have args */
1519 npositional < nargs
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) */
1525 npositional++;
1526 nkw = nargs - npositional;
1527 /* shuffle non-positional arguments above ntotal */
1528 ALLOC_FRAME (ntotal + nkw);
1529 n = nkw;
1530 while (n--)
1531 LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n));
1532 /* and fill optionals & keyword args with SCM_UNDEFINED */
1533 n = npositional;
1534 while (n < ntotal)
1535 LOCAL_SET (n++, SCM_UNDEFINED);
1536
1537 VM_ASSERT (has_rest || (nkw % 2) == 0,
1538 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp)));
1539
1540 /* Now bind keywords, in the order given. */
1541 for (n = 0; n < nkw; n++)
1542 if (scm_is_keyword (LOCAL_REF (ntotal + n)))
1543 {
1544 SCM walk;
1545 for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
1546 if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n)))
1547 {
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));
1551 break;
1552 }
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)));
1556 n++;
1557 }
1558 else
1559 VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
1560 LOCAL_REF (ntotal + n)));
1561
1562 if (has_rest)
1563 {
1564 SCM rest = SCM_EOL;
1565 n = nkw;
1566 while (n--)
1567 rest = scm_cons (LOCAL_REF (ntotal + n), rest);
1568 LOCAL_SET (nreq_and_opt, rest);
1569 }
1570
1571 RESET_FRAME (ntotal);
1572
1573 NEXT (4);
1574 }
1575
1576 /* bind-rest dst:24
1577 *
1578 * Collect any arguments at or above DST into a list, and store that
1579 * list at DST.
1580 */
1581 VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
1582 {
1583 scm_t_uint32 dst, nargs;
1584 SCM rest = SCM_EOL;
1585
1586 SCM_UNPACK_RTL_24 (op, dst);
1587 nargs = FRAME_LOCALS_COUNT ();
1588
1589 while (nargs-- > dst)
1590 {
1591 rest = scm_cons (LOCAL_REF (nargs), rest);
1592 LOCAL_SET (nargs, SCM_UNDEFINED);
1593 }
1594
1595 LOCAL_SET (dst, rest);
1596
1597 RESET_FRAME (dst + 1);
1598
1599 NEXT (1);
1600 }
1601
1602
1603 \f
1604
1605 /*
1606 * Branching instructions
1607 */
1608
1609 /* br offset:24
1610 *
1611 * Add OFFSET, a signed 24-bit number, to the current instruction
1612 * pointer.
1613 */
1614 VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
1615 {
1616 scm_t_int32 offset = op;
1617 offset >>= 8; /* Sign-extending shift. */
1618 NEXT (offset);
1619 }
1620
1621 /* br-if-true test:24 invert:1 _:7 offset:24
1622 *
1623 * If the value in TEST is true for the purposes of Scheme, add
1624 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1625 */
1626 VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
1627 {
1628 BR_UNARY (x, scm_is_true (x));
1629 }
1630
1631 /* br-if-null test:24 invert:1 _:7 offset:24
1632 *
1633 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1634 * signed 24-bit number, to the current instruction pointer.
1635 */
1636 VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
1637 {
1638 BR_UNARY (x, scm_is_null (x));
1639 }
1640
1641 /* br-if-nil test:24 invert:1 _:7 offset:24
1642 *
1643 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1644 * number, to the current instruction pointer.
1645 */
1646 VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
1647 {
1648 BR_UNARY (x, scm_is_lisp_false (x));
1649 }
1650
1651 /* br-if-pair test:24 invert:1 _:7 offset:24
1652 *
1653 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1654 * to the current instruction pointer.
1655 */
1656 VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
1657 {
1658 BR_UNARY (x, scm_is_pair (x));
1659 }
1660
1661 /* br-if-struct test:24 invert:1 _:7 offset:24
1662 *
1663 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1664 * number, to the current instruction pointer.
1665 */
1666 VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
1667 {
1668 BR_UNARY (x, SCM_STRUCTP (x));
1669 }
1670
1671 /* br-if-char test:24 invert:1 _:7 offset:24
1672 *
1673 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1674 * to the current instruction pointer.
1675 */
1676 VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
1677 {
1678 BR_UNARY (x, SCM_CHARP (x));
1679 }
1680
1681 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1682 *
1683 * If the value in TEST has the TC7 given in the second word, add
1684 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1685 */
1686 VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
1687 {
1688 BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
1689 }
1690
1691 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1692 *
1693 * If the value in A is eq? to the value in B, add OFFSET, a signed
1694 * 24-bit number, to the current instruction pointer.
1695 */
1696 VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
1697 {
1698 BR_BINARY (x, y, scm_is_eq (x, y));
1699 }
1700
1701 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1702 *
1703 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1704 * 24-bit number, to the current instruction pointer.
1705 */
1706 VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
1707 {
1708 BR_BINARY (x, y,
1709 scm_is_eq (x, y)
1710 || (SCM_NIMP (x) && SCM_NIMP (y)
1711 && scm_is_true (scm_eqv_p (x, y))));
1712 }
1713
1714 // FIXME: remove, have compiler inline eqv test instead
1715 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1716 *
1717 * If the value in A is equal? to the value in B, add OFFSET, a signed
1718 * 24-bit number, to the current instruction pointer.
1719 */
1720 // FIXME: should sync_ip before calling out?
1721 VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
1722 {
1723 BR_BINARY (x, y,
1724 scm_is_eq (x, y)
1725 || (SCM_NIMP (x) && SCM_NIMP (y)
1726 && scm_is_true (scm_equal_p (x, y))));
1727 }
1728
1729 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1730 *
1731 * If the value in A is = to the value in B, add OFFSET, a signed
1732 * 24-bit number, to the current instruction pointer.
1733 */
1734 VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
1735 {
1736 BR_ARITHMETIC (==, scm_num_eq_p);
1737 }
1738
1739 /* br-if-< a:12 b:12 _:8 offset:24
1740 *
1741 * If the value in A is < to the value in B, add OFFSET, a signed
1742 * 24-bit number, to the current instruction pointer.
1743 */
1744 VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
1745 {
1746 BR_ARITHMETIC (<, scm_less_p);
1747 }
1748
1749 /* br-if-<= a:12 b:12 _:8 offset:24
1750 *
1751 * If the value in A is <= to the value in B, add OFFSET, a signed
1752 * 24-bit number, to the current instruction pointer.
1753 */
1754 VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
1755 {
1756 BR_ARITHMETIC (<=, scm_leq_p);
1757 }
1758
1759
1760 \f
1761
1762 /*
1763 * Lexical binding instructions
1764 */
1765
1766 /* mov dst:12 src:12
1767 *
1768 * Copy a value from one local slot to another.
1769 */
1770 VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
1771 {
1772 scm_t_uint16 dst;
1773 scm_t_uint16 src;
1774
1775 SCM_UNPACK_RTL_12_12 (op, dst, src);
1776 LOCAL_SET (dst, LOCAL_REF (src));
1777
1778 NEXT (1);
1779 }
1780
1781 /* long-mov dst:24 _:8 src:24
1782 *
1783 * Copy a value from one local slot to another.
1784 */
1785 VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
1786 {
1787 scm_t_uint32 dst;
1788 scm_t_uint32 src;
1789
1790 SCM_UNPACK_RTL_24 (op, dst);
1791 SCM_UNPACK_RTL_24 (ip[1], src);
1792 LOCAL_SET (dst, LOCAL_REF (src));
1793
1794 NEXT (2);
1795 }
1796
1797 /* box dst:12 src:12
1798 *
1799 * Create a new variable holding SRC, and place it in DST.
1800 */
1801 VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
1802 {
1803 scm_t_uint16 dst, src;
1804 SCM_UNPACK_RTL_12_12 (op, dst, src);
1805 LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src))));
1806 NEXT (1);
1807 }
1808
1809 /* box-ref dst:12 src:12
1810 *
1811 * Unpack the variable at SRC into DST, asserting that the variable is
1812 * actually bound.
1813 */
1814 VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
1815 {
1816 scm_t_uint16 dst, src;
1817 SCM var;
1818 SCM_UNPACK_RTL_12_12 (op, dst, src);
1819 var = LOCAL_REF (src);
1820 VM_ASSERT (SCM_VARIABLEP (var), abort ());
1821 VM_ASSERT (VARIABLE_BOUNDP (var),
1822 vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
1823 LOCAL_SET (dst, VARIABLE_REF (var));
1824 NEXT (1);
1825 }
1826
1827 /* box-set! dst:12 src:12
1828 *
1829 * Set the contents of the variable at DST to SET.
1830 */
1831 VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12))
1832 {
1833 scm_t_uint16 dst, src;
1834 SCM var;
1835 SCM_UNPACK_RTL_12_12 (op, dst, src);
1836 var = LOCAL_REF (dst);
1837 VM_ASSERT (SCM_VARIABLEP (var), abort ());
1838 VARIABLE_SET (var, LOCAL_REF (src));
1839 NEXT (1);
1840 }
1841
1842 /* make-closure dst:24 offset:32 _:8 nfree:24
1843 *
1844 * Make a new closure, and write it to DST. The code for the closure
1845 * will be found at OFFSET words from the current IP. OFFSET is a
1846 * signed 32-bit integer. Space for NFREE free variables will be
1847 * allocated.
1848 */
1849 VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
1850 {
1851 scm_t_uint32 dst, nfree, n;
1852 scm_t_int32 offset;
1853 SCM closure;
1854
1855 SCM_UNPACK_RTL_24 (op, dst);
1856 offset = ip[1];
1857 SCM_UNPACK_RTL_24 (ip[2], nfree);
1858
1859 // FIXME: Assert range of nfree?
1860 closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
1861 SCM_SET_CELL_WORD_1 (closure, ip + offset);
1862 // FIXME: Elide these initializations?
1863 for (n = 0; n < nfree; n++)
1864 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
1865 LOCAL_SET (dst, closure);
1866 NEXT (3);
1867 }
1868
1869 /* free-ref dst:12 src:12 _:8 idx:24
1870 *
1871 * Load free variable IDX from the closure SRC into local slot DST.
1872 */
1873 VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
1874 {
1875 scm_t_uint16 dst, src;
1876 scm_t_uint32 idx;
1877 SCM_UNPACK_RTL_12_12 (op, dst, src);
1878 SCM_UNPACK_RTL_24 (ip[1], idx);
1879 /* CHECK_FREE_VARIABLE (src); */
1880 LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
1881 NEXT (2);
1882 }
1883
1884 /* free-set! dst:12 src:12 _8 idx:24
1885 *
1886 * Set free variable IDX from the closure DST to SRC.
1887 */
1888 VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
1889 {
1890 scm_t_uint16 dst, src;
1891 scm_t_uint32 idx;
1892 SCM_UNPACK_RTL_12_12 (op, dst, src);
1893 SCM_UNPACK_RTL_24 (ip[1], idx);
1894 /* CHECK_FREE_VARIABLE (src); */
1895 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
1896 NEXT (2);
1897 }
1898
1899
1900 \f
1901
1902 /*
1903 * Immediates and statically allocated non-immediates
1904 */
1905
1906 /* make-short-immediate dst:8 low-bits:16
1907 *
1908 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1909 * 0.
1910 */
1911 VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
1912 {
1913 scm_t_uint8 dst;
1914 scm_t_bits val;
1915
1916 SCM_UNPACK_RTL_8_16 (op, dst, val);
1917 LOCAL_SET (dst, SCM_PACK (val));
1918 NEXT (1);
1919 }
1920
1921 /* make-long-immediate dst:24 low-bits:32
1922 *
1923 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1924 * 0.
1925 */
1926 VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
1927 {
1928 scm_t_uint8 dst;
1929 scm_t_bits val;
1930
1931 SCM_UNPACK_RTL_24 (op, dst);
1932 val = ip[1];
1933 LOCAL_SET (dst, SCM_PACK (val));
1934 NEXT (2);
1935 }
1936
1937 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1938 *
1939 * Make an immediate with HIGH-BITS and LOW-BITS.
1940 */
1941 VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
1942 {
1943 scm_t_uint8 dst;
1944 scm_t_bits val;
1945
1946 SCM_UNPACK_RTL_24 (op, dst);
1947 #if SIZEOF_SCM_T_BITS > 4
1948 val = ip[1];
1949 val <<= 32;
1950 val |= ip[2];
1951 #else
1952 ASSERT (ip[1] == 0);
1953 val = ip[2];
1954 #endif
1955 LOCAL_SET (dst, SCM_PACK (val));
1956 NEXT (3);
1957 }
1958
1959 /* make-non-immediate dst:24 offset:32
1960 *
1961 * Load a pointer to statically allocated memory into DST. The
1962 * object's memory is will be found OFFSET 32-bit words away from the
1963 * current instruction pointer. OFFSET is a signed value. The
1964 * intention here is that the compiler would produce an object file
1965 * containing the words of a non-immediate object, and this
1966 * instruction creates a pointer to that memory, effectively
1967 * resurrecting that object.
1968 *
1969 * Whether the object is mutable or immutable depends on where it was
1970 * allocated by the compiler, and loaded by the loader.
1971 */
1972 VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
1973 {
1974 scm_t_uint32 dst;
1975 scm_t_int32 offset;
1976 scm_t_uint32* loc;
1977 scm_t_bits unpacked;
1978
1979 SCM_UNPACK_RTL_24 (op, dst);
1980 offset = ip[1];
1981 loc = ip + offset;
1982 unpacked = (scm_t_bits) loc;
1983
1984 VM_ASSERT (!(unpacked & 0x7), abort());
1985
1986 LOCAL_SET (dst, SCM_PACK (unpacked));
1987
1988 NEXT (2);
1989 }
1990
1991 /* static-ref dst:24 offset:32
1992 *
1993 * Load a SCM value into DST. The SCM value will be fetched from
1994 * memory, OFFSET 32-bit words away from the current instruction
1995 * pointer. OFFSET is a signed value.
1996 *
1997 * The intention is for this instruction to be used to load constants
1998 * that the compiler is unable to statically allocate, like symbols.
1999 * These values would be initialized when the object file loads.
2000 */
2001 VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
2002 {
2003 scm_t_uint32 dst;
2004 scm_t_int32 offset;
2005 scm_t_uint32* loc;
2006 scm_t_uintptr loc_bits;
2007
2008 SCM_UNPACK_RTL_24 (op, dst);
2009 offset = ip[1];
2010 loc = ip + offset;
2011 loc_bits = (scm_t_uintptr) loc;
2012 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2013
2014 LOCAL_SET (dst, *((SCM *) loc_bits));
2015
2016 NEXT (2);
2017 }
2018
2019 /* static-set! src:24 offset:32
2020 *
2021 * Store a SCM value into memory, OFFSET 32-bit words away from the
2022 * current instruction pointer. OFFSET is a signed value.
2023 */
2024 VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
2025 {
2026 scm_t_uint32 src;
2027 scm_t_int32 offset;
2028 scm_t_uint32* loc;
2029
2030 SCM_UNPACK_RTL_24 (op, src);
2031 offset = ip[1];
2032 loc = ip + offset;
2033 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2034
2035 *((SCM *) loc) = LOCAL_REF (src);
2036
2037 NEXT (2);
2038 }
2039
2040 /* link-procedure! src:24 offset:32
2041 *
2042 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2043 * words away from the current instruction pointer. OFFSET is a
2044 * signed value.
2045 */
2046 VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
2047 {
2048 scm_t_uint32 src;
2049 scm_t_int32 offset;
2050 scm_t_uint32* loc;
2051
2052 SCM_UNPACK_RTL_24 (op, src);
2053 offset = ip[1];
2054 loc = ip + offset;
2055
2056 SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
2057
2058 NEXT (2);
2059 }
2060
2061 \f
2062
2063 /*
2064 * Mutable top-level bindings
2065 */
2066
2067 /* There are three slightly different ways to resolve toplevel
2068 variables.
2069
2070 1. A toplevel reference outside of a function. These need to be
2071 looked up when the expression is evaluated -- no later, and no
2072 before. They are looked up relative to the module that is
2073 current when the expression is evaluated. For example:
2074
2075 (if (foo) a b)
2076
2077 The "resolve" instruction resolves the variable (box), and then
2078 access is via box-ref or box-set!.
2079
2080 2. A toplevel reference inside a function. These are looked up
2081 relative to the module that was current when the function was
2082 defined. Unlike code at the toplevel, which is usually run only
2083 once, these bindings benefit from memoized lookup, in which the
2084 variable resulting from the lookup is cached in the function.
2085
2086 (lambda () (if (foo) a b))
2087
2088 The toplevel-box instruction is equivalent to "resolve", but
2089 caches the resulting variable in statically allocated memory.
2090
2091 3. A reference to an identifier with respect to a particular
2092 module. This can happen for primitive references, and
2093 references residualized by macro expansions. These can always
2094 be cached. Use module-box for these.
2095 */
2096
2097 /* current-module dst:24
2098 *
2099 * Store the current module in DST.
2100 */
2101 VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
2102 {
2103 scm_t_uint32 dst;
2104
2105 SCM_UNPACK_RTL_24 (op, dst);
2106
2107 SYNC_IP ();
2108 LOCAL_SET (dst, scm_current_module ());
2109
2110 NEXT (1);
2111 }
2112
2113 /* resolve dst:24 bound?:1 _:7 sym:24
2114 *
2115 * Resolve SYM in the current module, and place the resulting variable
2116 * in DST.
2117 */
2118 VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
2119 {
2120 scm_t_uint32 dst;
2121 scm_t_uint32 sym;
2122 SCM var;
2123
2124 SCM_UNPACK_RTL_24 (op, dst);
2125 SCM_UNPACK_RTL_24 (ip[1], sym);
2126
2127 SYNC_IP ();
2128 var = scm_lookup (LOCAL_REF (sym));
2129 if (ip[1] & 0x1)
2130 VM_ASSERT (VARIABLE_BOUNDP (var),
2131 vm_error_unbound (fp[-1], LOCAL_REF (sym)));
2132 LOCAL_SET (dst, var);
2133
2134 NEXT (2);
2135 }
2136
2137 /* define sym:12 val:12
2138 *
2139 * Look up a binding for SYM in the current module, creating it if
2140 * necessary. Set its value to VAL.
2141 */
2142 VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
2143 {
2144 scm_t_uint16 sym, val;
2145 SCM_UNPACK_RTL_12_12 (op, sym, val);
2146 SYNC_IP ();
2147 scm_define (LOCAL_REF (sym), LOCAL_REF (val));
2148 NEXT (1);
2149 }
2150
2151 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2152 *
2153 * Load a SCM value. The SCM value will be fetched from memory,
2154 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2155 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
2156 * static-ref.
2157 *
2158 * Then, if the loaded value is a variable, it is placed in DST, and control
2159 * flow continues.
2160 *
2161 * Otherwise, we have to resolve the variable. In that case we load
2162 * the module from MOD-OFFSET, just as we loaded the variable.
2163 * Usually the module gets set when the closure is created. The name
2164 * is an offset to a symbol.
2165 *
2166 * We use the module and the symbol to resolve the variable, placing it in
2167 * DST, and caching the resolved variable so that we will hit the cache next
2168 * time.
2169 */
2170 VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
2171 {
2172 scm_t_uint32 dst;
2173 scm_t_int32 var_offset;
2174 scm_t_uint32* var_loc_u32;
2175 SCM *var_loc;
2176 SCM var;
2177
2178 SCM_UNPACK_RTL_24 (op, dst);
2179 var_offset = ip[1];
2180 var_loc_u32 = ip + var_offset;
2181 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2182 var_loc = (SCM *) var_loc_u32;
2183 var = *var_loc;
2184
2185 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2186 {
2187 SCM mod, sym;
2188 scm_t_int32 mod_offset = ip[2]; /* signed */
2189 scm_t_int32 sym_offset = ip[3]; /* signed */
2190 scm_t_uint32 *mod_loc = ip + mod_offset;
2191 scm_t_uint32 *sym_loc = ip + sym_offset;
2192
2193 SYNC_IP ();
2194
2195 VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
2196 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2197
2198 mod = *((SCM *) mod_loc);
2199 sym = *((SCM *) sym_loc);
2200
2201 var = scm_module_lookup (mod, sym);
2202 if (ip[4] & 0x1)
2203 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
2204
2205 *var_loc = var;
2206 }
2207
2208 LOCAL_SET (dst, var);
2209 NEXT (5);
2210 }
2211
2212 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2213 *
2214 * Like toplevel-box, except MOD-OFFSET points at the name of a module
2215 * instead of the module itself.
2216 */
2217 VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
2218 {
2219 scm_t_uint32 dst;
2220 scm_t_int32 var_offset;
2221 scm_t_uint32* var_loc_u32;
2222 SCM *var_loc;
2223 SCM var;
2224
2225 SCM_UNPACK_RTL_24 (op, dst);
2226 var_offset = ip[1];
2227 var_loc_u32 = ip + var_offset;
2228 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2229 var_loc = (SCM *) var_loc_u32;
2230 var = *var_loc;
2231
2232 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2233 {
2234 SCM modname, sym;
2235 scm_t_int32 modname_offset = ip[2]; /* signed */
2236 scm_t_int32 sym_offset = ip[3]; /* signed */
2237 scm_t_uint32 *modname_words = ip + modname_offset;
2238 scm_t_uint32 *sym_loc = ip + sym_offset;
2239
2240 SYNC_IP ();
2241
2242 VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
2243 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2244
2245 modname = SCM_PACK ((scm_t_bits) modname_words);
2246 sym = *((SCM *) sym_loc);
2247
2248 if (scm_is_true (SCM_CAR (modname)))
2249 var = scm_public_lookup (SCM_CDR (modname), sym);
2250 else
2251 var = scm_private_lookup (SCM_CDR (modname), sym);
2252
2253 if (ip[4] & 0x1)
2254 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
2255
2256 *var_loc = var;
2257 }
2258
2259 LOCAL_SET (dst, var);
2260 NEXT (5);
2261 }
2262
2263 \f
2264
2265 /*
2266 * The dynamic environment
2267 */
2268
2269 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2270 *
2271 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2272 * handler at HANDLER-OFFSET words from the current IP. The handler
2273 * will expect a multiple-value return as if from a call with the
2274 * procedure at PROC-SLOT.
2275 */
2276 VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
2277 {
2278 scm_t_uint32 tag, proc_slot;
2279 scm_t_int32 offset;
2280 scm_t_uint8 escape_only_p;
2281 scm_t_dynstack_prompt_flags flags;
2282
2283 SCM_UNPACK_RTL_24 (op, tag);
2284 escape_only_p = ip[1] & 0x1;
2285 SCM_UNPACK_RTL_24 (ip[1], proc_slot);
2286 offset = ip[2];
2287 offset >>= 8; /* Sign extension */
2288
2289 /* Push the prompt onto the dynamic stack. */
2290 flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
2291 scm_dynstack_push_prompt (&current_thread->dynstack, flags,
2292 LOCAL_REF (tag),
2293 fp,
2294 &LOCAL_REF (proc_slot),
2295 (scm_t_uint8 *)(ip + offset),
2296 &registers);
2297 NEXT (3);
2298 }
2299
2300 /* wind winder:12 unwinder:12
2301 *
2302 * Push wind and unwind procedures onto the dynamic stack. Note that
2303 * neither are actually called; the compiler should emit calls to wind
2304 * and unwind for the normal dynamic-wind control flow. Also note that
2305 * the compiler should have inserted checks that they wind and unwind
2306 * procs are thunks, if it could not prove that to be the case.
2307 */
2308 VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
2309 {
2310 scm_t_uint16 winder, unwinder;
2311 SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
2312 scm_dynstack_push_dynwind (&current_thread->dynstack,
2313 LOCAL_REF (winder), LOCAL_REF (unwinder));
2314 NEXT (1);
2315 }
2316
2317 /* abort tag:24 _:8 proc:24
2318 *
2319 * Return a number of values to a prompt handler. The values are
2320 * expected in a frame pushed on at PROC.
2321 */
2322 VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
2323 #if 0
2324 {
2325 scm_t_uint32 tag, from, nvalues;
2326 SCM *base;
2327
2328 SCM_UNPACK_RTL_24 (op, tag);
2329 SCM_UNPACK_RTL_24 (ip[1], from);
2330 base = (fp - 1) + from + 3;
2331 nvalues = FRAME_LOCALS_COUNT () - from - 3;
2332
2333 SYNC_IP ();
2334 vm_abort (vm, LOCAL_REF (tag), base, nvalues, &registers);
2335
2336 /* vm_abort should not return */
2337 abort ();
2338 }
2339 #else
2340 abort();
2341 #endif
2342
2343 /* unwind _:24
2344 *
2345 * A normal exit from the dynamic extent of an expression. Pop the top
2346 * entry off of the dynamic stack.
2347 */
2348 VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
2349 {
2350 scm_dynstack_pop (&current_thread->dynstack);
2351 NEXT (1);
2352 }
2353
2354 /* push-fluid fluid:12 value:12
2355 *
2356 * Dynamically bind N fluids to values. The fluids are expected to be
2357 * allocated in a continguous range on the stack, starting from
2358 * FLUID-BASE. The values do not have this restriction.
2359 */
2360 VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
2361 {
2362 scm_t_uint32 fluid, value;
2363
2364 SCM_UNPACK_RTL_12_12 (op, fluid, value);
2365
2366 scm_dynstack_push_fluid (&current_thread->dynstack,
2367 fp[fluid], fp[value],
2368 current_thread->dynamic_state);
2369 NEXT (1);
2370 }
2371
2372 /* pop-fluid _:24
2373 *
2374 * Leave the dynamic extent of a with-fluids expression, restoring the
2375 * fluids to their previous values.
2376 */
2377 VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
2378 {
2379 /* This function must not allocate. */
2380 scm_dynstack_unwind_fluid (&current_thread->dynstack,
2381 current_thread->dynamic_state);
2382 NEXT (1);
2383 }
2384
2385 /* fluid-ref dst:12 src:12
2386 *
2387 * Reference the fluid in SRC, and place the value in DST.
2388 */
2389 VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
2390 {
2391 scm_t_uint16 dst, src;
2392 size_t num;
2393 SCM fluid, fluids;
2394
2395 SCM_UNPACK_RTL_12_12 (op, dst, src);
2396 fluid = LOCAL_REF (src);
2397 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2398 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2399 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2400 {
2401 /* Punt dynstate expansion and error handling to the C proc. */
2402 SYNC_IP ();
2403 LOCAL_SET (dst, scm_fluid_ref (fluid));
2404 }
2405 else
2406 {
2407 SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
2408 if (scm_is_eq (val, SCM_UNDEFINED))
2409 val = SCM_I_FLUID_DEFAULT (fluid);
2410 VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
2411 vm_error_unbound_fluid (program, fluid));
2412 LOCAL_SET (dst, val);
2413 }
2414
2415 NEXT (1);
2416 }
2417
2418 /* fluid-set fluid:12 val:12
2419 *
2420 * Set the value of the fluid in DST to the value in SRC.
2421 */
2422 VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
2423 {
2424 scm_t_uint16 a, b;
2425 size_t num;
2426 SCM fluid, fluids;
2427
2428 SCM_UNPACK_RTL_12_12 (op, a, b);
2429 fluid = LOCAL_REF (a);
2430 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2431 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2432 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2433 {
2434 /* Punt dynstate expansion and error handling to the C proc. */
2435 SYNC_IP ();
2436 scm_fluid_set_x (fluid, LOCAL_REF (b));
2437 }
2438 else
2439 SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b));
2440
2441 NEXT (1);
2442 }
2443
2444
2445 \f
2446
2447 /*
2448 * Strings, symbols, and keywords
2449 */
2450
2451 /* string-length dst:12 src:12
2452 *
2453 * Store the length of the string in SRC in DST.
2454 */
2455 VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
2456 {
2457 ARGS1 (str);
2458 if (SCM_LIKELY (scm_is_string (str)))
2459 RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
2460 else
2461 {
2462 SYNC_IP ();
2463 RETURN (scm_string_length (str));
2464 }
2465 }
2466
2467 /* string-ref dst:8 src:8 idx:8
2468 *
2469 * Fetch the character at position IDX in the string in SRC, and store
2470 * it in DST.
2471 */
2472 VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2473 {
2474 scm_t_signed_bits i = 0;
2475 ARGS2 (str, idx);
2476 if (SCM_LIKELY (scm_is_string (str)
2477 && SCM_I_INUMP (idx)
2478 && ((i = SCM_I_INUM (idx)) >= 0)
2479 && i < scm_i_string_length (str)))
2480 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
2481 else
2482 {
2483 SYNC_IP ();
2484 RETURN (scm_string_ref (str, idx));
2485 }
2486 }
2487
2488 /* No string-set! instruction, as there is no good fast path there. */
2489
2490 /* string-to-number dst:12 src:12
2491 *
2492 * Parse a string in SRC to a number, and store in DST.
2493 */
2494 VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
2495 {
2496 scm_t_uint16 dst, src;
2497
2498 SCM_UNPACK_RTL_12_12 (op, dst, src);
2499 SYNC_IP ();
2500 LOCAL_SET (dst,
2501 scm_string_to_number (LOCAL_REF (src),
2502 SCM_UNDEFINED /* radix = 10 */));
2503 NEXT (1);
2504 }
2505
2506 /* string-to-symbol dst:12 src:12
2507 *
2508 * Parse a string in SRC to a symbol, and store in DST.
2509 */
2510 VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
2511 {
2512 scm_t_uint16 dst, src;
2513
2514 SCM_UNPACK_RTL_12_12 (op, dst, src);
2515 SYNC_IP ();
2516 LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
2517 NEXT (1);
2518 }
2519
2520 /* symbol->keyword dst:12 src:12
2521 *
2522 * Make a keyword from the symbol in SRC, and store it in DST.
2523 */
2524 VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
2525 {
2526 scm_t_uint16 dst, src;
2527 SCM_UNPACK_RTL_12_12 (op, dst, src);
2528 SYNC_IP ();
2529 LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
2530 NEXT (1);
2531 }
2532
2533 \f
2534
2535 /*
2536 * Pairs
2537 */
2538
2539 /* cons dst:8 car:8 cdr:8
2540 *
2541 * Cons CAR and CDR, and store the result in DST.
2542 */
2543 VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
2544 {
2545 ARGS2 (x, y);
2546 RETURN (scm_cons (x, y));
2547 }
2548
2549 /* car dst:12 src:12
2550 *
2551 * Place the car of SRC in DST.
2552 */
2553 VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
2554 {
2555 ARGS1 (x);
2556 VM_VALIDATE_PAIR (x, "car");
2557 RETURN (SCM_CAR (x));
2558 }
2559
2560 /* cdr dst:12 src:12
2561 *
2562 * Place the cdr of SRC in DST.
2563 */
2564 VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
2565 {
2566 ARGS1 (x);
2567 VM_VALIDATE_PAIR (x, "cdr");
2568 RETURN (SCM_CDR (x));
2569 }
2570
2571 /* set-car! pair:12 car:12
2572 *
2573 * Set the car of DST to SRC.
2574 */
2575 VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
2576 {
2577 scm_t_uint16 a, b;
2578 SCM x, y;
2579 SCM_UNPACK_RTL_12_12 (op, a, b);
2580 x = LOCAL_REF (a);
2581 y = LOCAL_REF (b);
2582 VM_VALIDATE_PAIR (x, "set-car!");
2583 SCM_SETCAR (x, y);
2584 NEXT (1);
2585 }
2586
2587 /* set-cdr! pair:12 cdr:12
2588 *
2589 * Set the cdr of DST to SRC.
2590 */
2591 VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
2592 {
2593 scm_t_uint16 a, b;
2594 SCM x, y;
2595 SCM_UNPACK_RTL_12_12 (op, a, b);
2596 x = LOCAL_REF (a);
2597 y = LOCAL_REF (b);
2598 VM_VALIDATE_PAIR (x, "set-car!");
2599 SCM_SETCDR (x, y);
2600 NEXT (1);
2601 }
2602
2603
2604 \f
2605
2606 /*
2607 * Numeric operations
2608 */
2609
2610 /* add dst:8 a:8 b:8
2611 *
2612 * Add A to B, and place the result in DST.
2613 */
2614 VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
2615 {
2616 BINARY_INTEGER_OP (+, scm_sum);
2617 }
2618
2619 /* add1 dst:12 src:12
2620 *
2621 * Add 1 to the value in SRC, and place the result in DST.
2622 */
2623 VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
2624 {
2625 ARGS1 (x);
2626
2627 /* Check for overflow. We must avoid overflow in the signed
2628 addition below, even if X is not an inum. */
2629 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
2630 {
2631 SCM result;
2632
2633 /* Add 1 to the integer without untagging. */
2634 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
2635
2636 if (SCM_LIKELY (SCM_I_INUMP (result)))
2637 RETURN (result);
2638 }
2639
2640 SYNC_IP ();
2641 RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
2642 }
2643
2644 /* sub dst:8 a:8 b:8
2645 *
2646 * Subtract B from A, and place the result in DST.
2647 */
2648 VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
2649 {
2650 BINARY_INTEGER_OP (-, scm_difference);
2651 }
2652
2653 /* sub1 dst:12 src:12
2654 *
2655 * Subtract 1 from SRC, and place the result in DST.
2656 */
2657 VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
2658 {
2659 ARGS1 (x);
2660
2661 /* Check for overflow. We must avoid overflow in the signed
2662 subtraction below, even if X is not an inum. */
2663 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
2664 {
2665 SCM result;
2666
2667 /* Substract 1 from the integer without untagging. */
2668 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
2669
2670 if (SCM_LIKELY (SCM_I_INUMP (result)))
2671 RETURN (result);
2672 }
2673
2674 SYNC_IP ();
2675 RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
2676 }
2677
2678 /* mul dst:8 a:8 b:8
2679 *
2680 * Multiply A and B, and place the result in DST.
2681 */
2682 VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
2683 {
2684 ARGS2 (x, y);
2685 SYNC_IP ();
2686 RETURN (scm_product (x, y));
2687 }
2688
2689 /* div dst:8 a:8 b:8
2690 *
2691 * Divide A by B, and place the result in DST.
2692 */
2693 VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
2694 {
2695 ARGS2 (x, y);
2696 SYNC_IP ();
2697 RETURN (scm_divide (x, y));
2698 }
2699
2700 /* quo dst:8 a:8 b:8
2701 *
2702 * Divide A by B, and place the quotient in DST.
2703 */
2704 VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
2705 {
2706 ARGS2 (x, y);
2707 SYNC_IP ();
2708 RETURN (scm_quotient (x, y));
2709 }
2710
2711 /* rem dst:8 a:8 b:8
2712 *
2713 * Divide A by B, and place the remainder in DST.
2714 */
2715 VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
2716 {
2717 ARGS2 (x, y);
2718 SYNC_IP ();
2719 RETURN (scm_remainder (x, y));
2720 }
2721
2722 /* mod dst:8 a:8 b:8
2723 *
2724 * Place the modulo of A by B in DST.
2725 */
2726 VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
2727 {
2728 ARGS2 (x, y);
2729 SYNC_IP ();
2730 RETURN (scm_modulo (x, y));
2731 }
2732
2733 /* ash dst:8 a:8 b:8
2734 *
2735 * Shift A arithmetically by B bits, and place the result in DST.
2736 */
2737 VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
2738 {
2739 ARGS2 (x, y);
2740 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2741 {
2742 if (SCM_I_INUM (y) < 0)
2743 /* Right shift, will be a fixnum. */
2744 RETURN (SCM_I_MAKINUM
2745 (SCM_SRS (SCM_I_INUM (x),
2746 (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
2747 ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
2748 else
2749 /* Left shift. See comments in scm_ash. */
2750 {
2751 scm_t_signed_bits nn, bits_to_shift;
2752
2753 nn = SCM_I_INUM (x);
2754 bits_to_shift = SCM_I_INUM (y);
2755
2756 if (bits_to_shift < SCM_I_FIXNUM_BIT-1
2757 && ((scm_t_bits)
2758 (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
2759 <= 1))
2760 RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
2761 /* fall through */
2762 }
2763 /* fall through */
2764 }
2765 SYNC_IP ();
2766 RETURN (scm_ash (x, y));
2767 }
2768
2769 /* logand dst:8 a:8 b:8
2770 *
2771 * Place the bitwise AND of A and B into DST.
2772 */
2773 VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
2774 {
2775 ARGS2 (x, y);
2776 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2777 /* Compute bitwise AND without untagging */
2778 RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
2779 SYNC_IP ();
2780 RETURN (scm_logand (x, y));
2781 }
2782
2783 /* logior dst:8 a:8 b:8
2784 *
2785 * Place the bitwise inclusive OR of A with B in DST.
2786 */
2787 VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
2788 {
2789 ARGS2 (x, y);
2790 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2791 /* Compute bitwise OR without untagging */
2792 RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
2793 SYNC_IP ();
2794 RETURN (scm_logior (x, y));
2795 }
2796
2797 /* logxor dst:8 a:8 b:8
2798 *
2799 * Place the bitwise exclusive OR of A with B in DST.
2800 */
2801 VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
2802 {
2803 ARGS2 (x, y);
2804 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2805 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
2806 SYNC_IP ();
2807 RETURN (scm_logxor (x, y));
2808 }
2809
2810 /* vector-length dst:12 src:12
2811 *
2812 * Store the length of the vector in SRC in DST.
2813 */
2814 VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
2815 {
2816 ARGS1 (vect);
2817 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
2818 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
2819 else
2820 {
2821 SYNC_IP ();
2822 RETURN (scm_vector_length (vect));
2823 }
2824 }
2825
2826 /* vector-ref dst:8 src:8 idx:8
2827 *
2828 * Fetch the item at position IDX in the vector in SRC, and store it
2829 * in DST.
2830 */
2831 VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2832 {
2833 scm_t_signed_bits i = 0;
2834 ARGS2 (vect, idx);
2835 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2836 && SCM_I_INUMP (idx)
2837 && ((i = SCM_I_INUM (idx)) >= 0)
2838 && i < SCM_I_VECTOR_LENGTH (vect)))
2839 RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
2840 else
2841 {
2842 SYNC_IP ();
2843 RETURN (scm_vector_ref (vect, idx));
2844 }
2845 }
2846
2847 /* constant-vector-ref dst:8 src:8 idx:8
2848 *
2849 * Fill DST with the item IDX elements into the vector at SRC. Useful
2850 * for building data types using vectors.
2851 */
2852 VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2853 {
2854 scm_t_uint8 dst, src, idx;
2855 SCM v;
2856
2857 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
2858 v = LOCAL_REF (src);
2859 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v)
2860 && idx < SCM_I_VECTOR_LENGTH (v)))
2861 LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
2862 else
2863 LOCAL_SET (dst, scm_c_vector_ref (v, idx));
2864 NEXT (1);
2865 }
2866
2867 /* vector-set! dst:8 idx:8 src:8
2868 *
2869 * Store SRC into the vector DST at index IDX.
2870 */
2871 VM_DEFINE_OP (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
2872 {
2873 scm_t_uint8 dst, idx_var, src;
2874 SCM vect, idx, val;
2875 scm_t_signed_bits i = 0;
2876
2877 SCM_UNPACK_RTL_8_8_8 (op, dst, idx_var, src);
2878 vect = LOCAL_REF (dst);
2879 idx = LOCAL_REF (idx_var);
2880 val = LOCAL_REF (src);
2881
2882 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2883 && SCM_I_INUMP (idx)
2884 && ((i = SCM_I_INUM (idx)) >= 0)
2885 && i < SCM_I_VECTOR_LENGTH (vect)))
2886 SCM_I_VECTOR_WELTS (vect)[i] = val;
2887 else
2888 {
2889 SYNC_IP ();
2890 scm_vector_set_x (vect, idx, val);
2891 }
2892 NEXT (1);
2893 }
2894
2895
2896 \f
2897
2898 /*
2899 * Structs and GOOPS
2900 */
2901
2902 /* struct-vtable dst:12 src:12
2903 *
2904 * Store the vtable of SRC into DST.
2905 */
2906 VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
2907 {
2908 ARGS1 (obj);
2909 VM_VALIDATE_STRUCT (obj, "struct_vtable");
2910 RETURN (SCM_STRUCT_VTABLE (obj));
2911 }
2912
2913 /* allocate-struct dst:8 vtable:8 nfields:8
2914 *
2915 * Allocate a new struct with VTABLE, and place it in DST. The struct
2916 * will be constructed with space for NFIELDS fields, which should
2917 * correspond to the field count of the VTABLE.
2918 */
2919 VM_DEFINE_OP (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
2920 {
2921 scm_t_uint8 dst, vtable, nfields;
2922 SCM ret;
2923
2924 SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
2925
2926 SYNC_IP ();
2927 ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
2928 LOCAL_SET (dst, ret);
2929
2930 NEXT (1);
2931 }
2932
2933 /* struct-ref dst:8 src:8 idx:8
2934 *
2935 * Fetch the item at slot IDX in the struct in SRC, and store it
2936 * in DST.
2937 */
2938 VM_DEFINE_OP (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2939 {
2940 ARGS2 (obj, pos);
2941
2942 if (SCM_LIKELY (SCM_STRUCTP (obj)
2943 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2944 SCM_VTABLE_FLAG_SIMPLE)
2945 && SCM_I_INUMP (pos)))
2946 {
2947 SCM vtable;
2948 scm_t_bits index, len;
2949
2950 /* True, an inum is a signed value, but cast to unsigned it will
2951 certainly be more than the length, so we will fall through if
2952 index is negative. */
2953 index = SCM_I_INUM (pos);
2954 vtable = SCM_STRUCT_VTABLE (obj);
2955 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
2956
2957 if (SCM_LIKELY (index < len))
2958 {
2959 scm_t_bits *data = SCM_STRUCT_DATA (obj);
2960 RETURN (SCM_PACK (data[index]));
2961 }
2962 }
2963
2964 SYNC_IP ();
2965 RETURN (scm_struct_ref (obj, pos));
2966 }
2967
2968 /* struct-set! dst:8 idx:8 src:8
2969 *
2970 * Store SRC into the struct DST at slot IDX.
2971 */
2972 VM_DEFINE_OP (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
2973 {
2974 scm_t_uint8 dst, idx, src;
2975 SCM obj, pos, val;
2976
2977 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
2978 obj = LOCAL_REF (dst);
2979 pos = LOCAL_REF (idx);
2980 val = LOCAL_REF (src);
2981
2982 if (SCM_LIKELY (SCM_STRUCTP (obj)
2983 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2984 SCM_VTABLE_FLAG_SIMPLE)
2985 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2986 SCM_VTABLE_FLAG_SIMPLE_RW)
2987 && SCM_I_INUMP (pos)))
2988 {
2989 SCM vtable;
2990 scm_t_bits index, len;
2991
2992 /* See above regarding index being >= 0. */
2993 index = SCM_I_INUM (pos);
2994 vtable = SCM_STRUCT_VTABLE (obj);
2995 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
2996 if (SCM_LIKELY (index < len))
2997 {
2998 scm_t_bits *data = SCM_STRUCT_DATA (obj);
2999 data[index] = SCM_UNPACK (val);
3000 NEXT (1);
3001 }
3002 }
3003
3004 SYNC_IP ();
3005 scm_struct_set_x (obj, pos, val);
3006 NEXT (1);
3007 }
3008
3009 /* class-of dst:12 type:12
3010 *
3011 * Store the vtable of SRC into DST.
3012 */
3013 VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
3014 {
3015 ARGS1 (obj);
3016 if (SCM_INSTANCEP (obj))
3017 RETURN (SCM_CLASS_OF (obj));
3018 SYNC_IP ();
3019 RETURN (scm_class_of (obj));
3020 }
3021
3022 /* slot-ref dst:8 src:8 idx:8
3023 *
3024 * Fetch the item at slot IDX in the struct in SRC, and store it in
3025 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3026 * index into the stack.
3027 */
3028 VM_DEFINE_OP (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3029 {
3030 scm_t_uint8 dst, src, idx;
3031 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
3032 LOCAL_SET (dst,
3033 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
3034 NEXT (1);
3035 }
3036
3037 /* slot-set! dst:8 idx:8 src:8
3038 *
3039 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3040 * IDX is an 8-bit immediate value, not an index into the stack.
3041 */
3042 VM_DEFINE_OP (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
3043 {
3044 scm_t_uint8 dst, idx, src;
3045 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
3046 SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
3047 NEXT (1);
3048 }
3049
3050
3051 \f
3052
3053 /*
3054 * Arrays, packed uniform arrays, and bytevectors.
3055 */
3056
3057 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3058 *
3059 * Load the contiguous typed array located at OFFSET 32-bit words away
3060 * from the instruction pointer, and store into DST. LEN is a byte
3061 * length. OFFSET is signed.
3062 */
3063 VM_DEFINE_OP (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
3064 {
3065 scm_t_uint8 dst, type, shape;
3066 scm_t_int32 offset;
3067 scm_t_uint32 len;
3068
3069 SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape);
3070 offset = ip[1];
3071 len = ip[2];
3072 SYNC_IP ();
3073 LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type),
3074 LOCAL_REF (shape),
3075 ip + offset, len));
3076 NEXT (3);
3077 }
3078
3079 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3080 *
3081 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3082 */
3083 VM_DEFINE_OP (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
3084 {
3085 scm_t_uint16 dst, type, fill, bounds;
3086 SCM_UNPACK_RTL_12_12 (op, dst, type);
3087 SCM_UNPACK_RTL_12_12 (ip[1], fill, bounds);
3088 SYNC_IP ();
3089 LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
3090 LOCAL_REF (bounds)));
3091 NEXT (2);
3092 }
3093
3094 /* bv-u8-ref dst:8 src:8 idx:8
3095 * bv-s8-ref dst:8 src:8 idx:8
3096 * bv-u16-ref dst:8 src:8 idx:8
3097 * bv-s16-ref dst:8 src:8 idx:8
3098 * bv-u32-ref dst:8 src:8 idx:8
3099 * bv-s32-ref dst:8 src:8 idx:8
3100 * bv-u64-ref dst:8 src:8 idx:8
3101 * bv-s64-ref dst:8 src:8 idx:8
3102 * bv-f32-ref dst:8 src:8 idx:8
3103 * bv-f64-ref dst:8 src:8 idx:8
3104 *
3105 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3106 * it in DST. All accesses use native endianness.
3107 */
3108 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3109 do { \
3110 scm_t_signed_bits i; \
3111 const scm_t_ ## type *int_ptr; \
3112 ARGS2 (bv, idx); \
3113 \
3114 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3115 i = SCM_I_INUM (idx); \
3116 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3117 \
3118 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3119 && (i >= 0) \
3120 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3121 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3122 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3123 else \
3124 { \
3125 SYNC_IP (); \
3126 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3127 } \
3128 } while (0)
3129
3130 #define BV_INT_REF(stem, type, size) \
3131 do { \
3132 scm_t_signed_bits i; \
3133 const scm_t_ ## type *int_ptr; \
3134 ARGS2 (bv, idx); \
3135 \
3136 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3137 i = SCM_I_INUM (idx); \
3138 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3139 \
3140 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3141 && (i >= 0) \
3142 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3143 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3144 { \
3145 scm_t_ ## type x = *int_ptr; \
3146 if (SCM_FIXABLE (x)) \
3147 RETURN (SCM_I_MAKINUM (x)); \
3148 else \
3149 { \
3150 SYNC_IP (); \
3151 RETURN (scm_from_ ## type (x)); \
3152 } \
3153 } \
3154 else \
3155 { \
3156 SYNC_IP (); \
3157 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3158 } \
3159 } while (0)
3160
3161 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3162 do { \
3163 scm_t_signed_bits i; \
3164 const type *float_ptr; \
3165 ARGS2 (bv, idx); \
3166 \
3167 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3168 i = SCM_I_INUM (idx); \
3169 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3170 \
3171 SYNC_IP (); \
3172 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3173 && (i >= 0) \
3174 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3175 && (ALIGNED_P (float_ptr, type)))) \
3176 RETURN (scm_from_double (*float_ptr)); \
3177 else \
3178 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3179 } while (0)
3180
3181 VM_DEFINE_OP (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3182 BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
3183
3184 VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3185 BV_FIXABLE_INT_REF (s8, s8, int8, 1);
3186
3187 VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3188 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
3189
3190 VM_DEFINE_OP (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3191 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
3192
3193 VM_DEFINE_OP (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3194 #if SIZEOF_VOID_P > 4
3195 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
3196 #else
3197 BV_INT_REF (u32, uint32, 4);
3198 #endif
3199
3200 VM_DEFINE_OP (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3201 #if SIZEOF_VOID_P > 4
3202 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
3203 #else
3204 BV_INT_REF (s32, int32, 4);
3205 #endif
3206
3207 VM_DEFINE_OP (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3208 BV_INT_REF (u64, uint64, 8);
3209
3210 VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3211 BV_INT_REF (s64, int64, 8);
3212
3213 VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3214 BV_FLOAT_REF (f32, ieee_single, float, 4);
3215
3216 VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3217 BV_FLOAT_REF (f64, ieee_double, double, 8);
3218
3219 /* bv-u8-set! dst:8 idx:8 src:8
3220 * bv-s8-set! dst:8 idx:8 src:8
3221 * bv-u16-set! dst:8 idx:8 src:8
3222 * bv-s16-set! dst:8 idx:8 src:8
3223 * bv-u32-set! dst:8 idx:8 src:8
3224 * bv-s32-set! dst:8 idx:8 src:8
3225 * bv-u64-set! dst:8 idx:8 src:8
3226 * bv-s64-set! dst:8 idx:8 src:8
3227 * bv-f32-set! dst:8 idx:8 src:8
3228 * bv-f64-set! dst:8 idx:8 src:8
3229 *
3230 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3231 * values are written using native endianness.
3232 */
3233 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3234 do { \
3235 scm_t_uint8 dst, idx, src; \
3236 scm_t_signed_bits i, j = 0; \
3237 SCM bv, scm_idx, val; \
3238 scm_t_ ## type *int_ptr; \
3239 \
3240 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3241 bv = LOCAL_REF (dst); \
3242 scm_idx = LOCAL_REF (idx); \
3243 val = LOCAL_REF (src); \
3244 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3245 i = SCM_I_INUM (scm_idx); \
3246 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3247 \
3248 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3249 && (i >= 0) \
3250 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3251 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3252 && (SCM_I_INUMP (val)) \
3253 && ((j = SCM_I_INUM (val)) >= min) \
3254 && (j <= max))) \
3255 *int_ptr = (scm_t_ ## type) j; \
3256 else \
3257 { \
3258 SYNC_IP (); \
3259 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3260 } \
3261 NEXT (1); \
3262 } while (0)
3263
3264 #define BV_INT_SET(stem, type, size) \
3265 do { \
3266 scm_t_uint8 dst, idx, src; \
3267 scm_t_signed_bits i; \
3268 SCM bv, scm_idx, val; \
3269 scm_t_ ## type *int_ptr; \
3270 \
3271 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3272 bv = LOCAL_REF (dst); \
3273 scm_idx = LOCAL_REF (idx); \
3274 val = LOCAL_REF (src); \
3275 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3276 i = SCM_I_INUM (scm_idx); \
3277 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3278 \
3279 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3280 && (i >= 0) \
3281 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3282 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3283 *int_ptr = scm_to_ ## type (val); \
3284 else \
3285 { \
3286 SYNC_IP (); \
3287 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3288 } \
3289 NEXT (1); \
3290 } while (0)
3291
3292 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3293 do { \
3294 scm_t_uint8 dst, idx, src; \
3295 scm_t_signed_bits i; \
3296 SCM bv, scm_idx, val; \
3297 type *float_ptr; \
3298 \
3299 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3300 bv = LOCAL_REF (dst); \
3301 scm_idx = LOCAL_REF (idx); \
3302 val = LOCAL_REF (src); \
3303 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3304 i = SCM_I_INUM (scm_idx); \
3305 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3306 \
3307 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3308 && (i >= 0) \
3309 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3310 && (ALIGNED_P (float_ptr, type)))) \
3311 *float_ptr = scm_to_double (val); \
3312 else \
3313 { \
3314 SYNC_IP (); \
3315 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3316 } \
3317 NEXT (1); \
3318 } while (0)
3319
3320 VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
3321 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
3322
3323 VM_DEFINE_OP (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
3324 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
3325
3326 VM_DEFINE_OP (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
3327 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
3328
3329 VM_DEFINE_OP (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
3330 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
3331
3332 VM_DEFINE_OP (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
3333 #if SIZEOF_VOID_P > 4
3334 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
3335 #else
3336 BV_INT_SET (u32, uint32, 4);
3337 #endif
3338
3339 VM_DEFINE_OP (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
3340 #if SIZEOF_VOID_P > 4
3341 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
3342 #else
3343 BV_INT_SET (s32, int32, 4);
3344 #endif
3345
3346 VM_DEFINE_OP (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
3347 BV_INT_SET (u64, uint64, 8);
3348
3349 VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
3350 BV_INT_SET (s64, int64, 8);
3351
3352 VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
3353 BV_FLOAT_SET (f32, ieee_single, float, 4);
3354
3355 VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
3356 BV_FLOAT_SET (f64, ieee_double, double, 8);
3357
3358 END_DISPATCH_SWITCH;
3359
3360 vm_error_bad_instruction:
3361 vm_error_bad_instruction (op);
3362
3363 abort (); /* never reached */
3364 }
3365
3366
3367 #undef ABORT_CONTINUATION_HOOK
3368 #undef ALIGNED_P
3369 #undef APPLY_HOOK
3370 #undef ARGS1
3371 #undef ARGS2
3372 #undef BEGIN_DISPATCH_SWITCH
3373 #undef BINARY_INTEGER_OP
3374 #undef BR_ARITHMETIC
3375 #undef BR_BINARY
3376 #undef BR_NARGS
3377 #undef BR_UNARY
3378 #undef BV_FIXABLE_INT_REF
3379 #undef BV_FIXABLE_INT_SET
3380 #undef BV_FLOAT_REF
3381 #undef BV_FLOAT_SET
3382 #undef BV_INT_REF
3383 #undef BV_INT_SET
3384 #undef CACHE_REGISTER
3385 #undef CHECK_OVERFLOW
3386 #undef END_DISPATCH_SWITCH
3387 #undef FREE_VARIABLE_REF
3388 #undef INIT
3389 #undef INUM_MAX
3390 #undef INUM_MIN
3391 #undef LOCAL_REF
3392 #undef LOCAL_SET
3393 #undef NEXT
3394 #undef NEXT_HOOK
3395 #undef NEXT_JUMP
3396 #undef POP_CONTINUATION_HOOK
3397 #undef PUSH_CONTINUATION_HOOK
3398 #undef RESTORE_CONTINUATION_HOOK
3399 #undef RETURN
3400 #undef RETURN_ONE_VALUE
3401 #undef RETURN_VALUE_LIST
3402 #undef RUN_HOOK
3403 #undef RUN_HOOK0
3404 #undef SYNC_ALL
3405 #undef SYNC_BEFORE_GC
3406 #undef SYNC_IP
3407 #undef SYNC_REGISTER
3408 #undef VARIABLE_BOUNDP
3409 #undef VARIABLE_REF
3410 #undef VARIABLE_SET
3411 #undef VM_CHECK_FREE_VARIABLE
3412 #undef VM_CHECK_OBJECT
3413 #undef VM_CHECK_UNDERFLOW
3414 #undef VM_DEFINE_OP
3415 #undef VM_INSTRUCTION_TO_LABEL
3416 #undef VM_USE_HOOKS
3417 #undef VM_VALIDATE_BYTEVECTOR
3418 #undef VM_VALIDATE_PAIR
3419 #undef VM_VALIDATE_STRUCT
3420
3421 /*
3422 (defun renumber-ops ()
3423 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3424 (interactive "")
3425 (save-excursion
3426 (let ((counter -1)) (goto-char (point-min))
3427 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3428 (replace-match
3429 (number-to-string (setq counter (1+ counter)))
3430 t t nil 1)))))
3431 (renumber-ops)
3432 */
3433 /*
3434 Local Variables:
3435 c-file-style: "gnu"
3436 End:
3437 */