HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Add make-vector, constant-make-vector instructions
[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 - 1), i)
632 #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE ((fp - 1), i) = 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 () - 1);
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 SCM proc = SCM_FRAME_PROGRAM (fp);
902
903 if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
904 {
905 fp[-1] = SCM_STRUCT_PROCEDURE (proc);
906 continue;
907 }
908 if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
909 {
910 scm_t_uint32 n = FRAME_LOCALS_COUNT();
911
912 /* Shuffle args up. */
913 RESET_FRAME (n + 1);
914 while (n--)
915 LOCAL_SET (n + 1, LOCAL_REF (n));
916
917 LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline);
918 continue;
919 }
920
921 #if 0
922 SYNC_IP();
923 vm_error_wrong_type_apply (proc);
924 #else
925 {
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 }
936 #endif
937 }
938
939 /* Let's go! */
940 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
941 NEXT (0);
942
943 BEGIN_DISPATCH_SWITCH;
944
945
946 \f
947
948 /*
949 * Call and return
950 */
951
952 /* halt _:24
953 *
954 * Bring the VM to a halt, returning all the values from the stack.
955 */
956 VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
957 {
958 scm_t_uint32 nvals = FRAME_LOCALS_COUNT() - 5;
959 SCM ret;
960
961 /* Boot closure in r0, empty frame in r1/r2/r3, proc in r4, values from r5. */
962
963 if (nvals == 1)
964 ret = LOCAL_REF (5);
965 else
966 {
967 scm_t_uint32 n;
968 ret = SCM_EOL;
969 SYNC_BEFORE_GC();
970 for (n = nvals; n > 0; n--)
971 ret = scm_cons (LOCAL_REF (5 + n - 1), ret);
972 ret = scm_values (ret);
973 }
974
975 vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
976 vp->sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
977 vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
978
979 return ret;
980 }
981
982 /* call proc:24 _:8 nlocals:24
983 *
984 * Call a procedure. PROC is the local corresponding to a procedure.
985 * The three values below PROC will be overwritten by the saved call
986 * frame data. The new frame will have space for NLOCALS locals: one
987 * for the procedure, and the rest for the arguments which should
988 * already have been pushed on.
989 *
990 * When the call returns, execution proceeds with the next
991 * instruction. There may be any number of values on the return
992 * stack; the precise number can be had by subtracting the address of
993 * PROC from the post-call SP.
994 */
995 VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
996 {
997 scm_t_uint32 proc, nlocals;
998 SCM *old_fp = fp;
999
1000 SCM_UNPACK_RTL_24 (op, proc);
1001 SCM_UNPACK_RTL_24 (ip[1], nlocals);
1002
1003 VM_HANDLE_INTERRUPTS;
1004
1005 fp = vp->fp = old_fp + proc;
1006 SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
1007 SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS (fp, ip + 2);
1008 SCM_FRAME_SET_RTL_RETURN_ADDRESS (fp, ip + 2);
1009
1010 RESET_FRAME (nlocals);
1011
1012 PUSH_CONTINUATION_HOOK ();
1013 APPLY_HOOK ();
1014
1015 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1016 goto apply;
1017
1018 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1019 NEXT (0);
1020 }
1021
1022 /* tail-call nlocals:24
1023 *
1024 * Tail-call a procedure. Requires that the procedure and all of the
1025 * arguments have already been shuffled into position.
1026 */
1027 VM_DEFINE_OP (2, tail_call, "tail-call", OP1 (U8_U24))
1028 {
1029 scm_t_uint32 nlocals;
1030
1031 SCM_UNPACK_RTL_24 (op, nlocals);
1032
1033 VM_HANDLE_INTERRUPTS;
1034
1035 RESET_FRAME (nlocals);
1036 APPLY_HOOK ();
1037
1038 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1039 goto apply;
1040
1041 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1042 NEXT (0);
1043 }
1044
1045 /* receive dst:12 proc:12 _:8 nlocals:24
1046 *
1047 * Receive a single return value from a call whose procedure was in
1048 * PROC, asserting that the call actually returned at least one
1049 * value. Afterwards, resets the frame to NLOCALS locals.
1050 */
1051 VM_DEFINE_OP (3, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
1052 {
1053 scm_t_uint16 dst, proc;
1054 scm_t_uint32 nlocals;
1055 SCM_UNPACK_RTL_12_12 (op, dst, proc);
1056 SCM_UNPACK_RTL_24 (ip[1], nlocals);
1057 VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ());
1058 LOCAL_SET (dst, LOCAL_REF (proc + 1));
1059 RESET_FRAME (nlocals);
1060 NEXT (2);
1061 }
1062
1063 /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
1064 *
1065 * Receive a return of multiple values from a call whose procedure was
1066 * in PROC. If fewer than NVALUES values were returned, signal an
1067 * error. Unless ALLOW-EXTRA? is true, require that the number of
1068 * return values equals NVALUES exactly. After receive-values has
1069 * run, the values can be copied down via `mov'.
1070 */
1071 VM_DEFINE_OP (4, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
1072 {
1073 scm_t_uint32 proc, nvalues;
1074 SCM_UNPACK_RTL_24 (op, proc);
1075 SCM_UNPACK_RTL_24 (ip[1], nvalues);
1076 if (ip[1] & 0x1)
1077 VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
1078 vm_error_not_enough_values ());
1079 else
1080 VM_ASSERT (FRAME_LOCALS_COUNT () == proc + nvalues,
1081 vm_error_wrong_number_of_values (nvalues));
1082 NEXT (2);
1083 }
1084
1085 /* return src:24
1086 *
1087 * Return a value.
1088 */
1089 VM_DEFINE_OP (5, return, "return", OP1 (U8_U24))
1090 {
1091 scm_t_uint32 src;
1092 SCM_UNPACK_RTL_24 (op, src);
1093 RETURN_ONE_VALUE (LOCAL_REF (src));
1094 }
1095
1096 /* return-values _:24
1097 *
1098 * Return a number of values from a call frame. This opcode
1099 * corresponds to an application of `values' in tail position. As
1100 * with tail calls, we expect that the values have already been
1101 * shuffled down to a contiguous array starting at slot 1.
1102 * We also expect the frame has already been reset.
1103 */
1104 VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_X24))
1105 {
1106 scm_t_uint32 nvalues _GL_UNUSED = FRAME_LOCALS_COUNT();
1107 SCM *base = fp;
1108
1109 VM_HANDLE_INTERRUPTS;
1110 ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
1111 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
1112
1113 /* Clear stack frame. */
1114 base[-2] = SCM_BOOL_F;
1115 base[-3] = SCM_BOOL_F;
1116 base[-4] = SCM_BOOL_F;
1117
1118 POP_CONTINUATION_HOOK (base, nvalues);
1119
1120 NEXT (0);
1121 }
1122
1123
1124 \f
1125
1126 /*
1127 * Specialized call stubs
1128 */
1129
1130 /* subr-call ptr-idx:24
1131 *
1132 * Call a subr, passing all locals in this frame as arguments. Fetch
1133 * the foreign pointer from PTR-IDX, a free variable. Return from the
1134 * calling frame. This instruction is part of the trampolines
1135 * created in gsubr.c, and is not generated by the compiler.
1136 */
1137 VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
1138 {
1139 scm_t_uint32 ptr_idx;
1140 SCM pointer, ret;
1141 SCM (*subr)();
1142
1143 SCM_UNPACK_RTL_24 (op, ptr_idx);
1144
1145 pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
1146 subr = SCM_POINTER_VALUE (pointer);
1147
1148 VM_HANDLE_INTERRUPTS;
1149 SYNC_IP ();
1150
1151 switch (FRAME_LOCALS_COUNT () - 1)
1152 {
1153 case 0:
1154 ret = subr ();
1155 break;
1156 case 1:
1157 ret = subr (fp[0]);
1158 break;
1159 case 2:
1160 ret = subr (fp[0], fp[1]);
1161 break;
1162 case 3:
1163 ret = subr (fp[0], fp[1], fp[2]);
1164 break;
1165 case 4:
1166 ret = subr (fp[0], fp[1], fp[2], fp[3]);
1167 break;
1168 case 5:
1169 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]);
1170 break;
1171 case 6:
1172 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]);
1173 break;
1174 case 7:
1175 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
1176 break;
1177 case 8:
1178 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
1179 break;
1180 case 9:
1181 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
1182 break;
1183 case 10:
1184 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
1185 break;
1186 default:
1187 abort ();
1188 }
1189
1190 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1191
1192 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1193 /* multiple values returned to continuation */
1194 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1195 else
1196 RETURN_ONE_VALUE (ret);
1197 }
1198
1199 /* foreign-call cif-idx:12 ptr-idx:12
1200 *
1201 * Call a foreign function. Fetch the CIF and foreign pointer from
1202 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1203 * frame. Arguments are taken from the stack. This instruction is
1204 * part of the trampolines created by the FFI, and is not generated by
1205 * the compiler.
1206 */
1207 VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
1208 {
1209 scm_t_uint16 cif_idx, ptr_idx;
1210 SCM closure, cif, pointer, ret;
1211
1212 SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
1213
1214 closure = LOCAL_REF (0);
1215 cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
1216 pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
1217
1218 SYNC_IP ();
1219 VM_HANDLE_INTERRUPTS;
1220
1221 // FIXME: separate args
1222 ret = scm_i_foreign_call (scm_cons (cif, pointer), fp);
1223
1224 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1225
1226 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1227 /* multiple values returned to continuation */
1228 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1229 else
1230 RETURN_ONE_VALUE (ret);
1231 }
1232
1233 /* continuation-call contregs:24
1234 *
1235 * Return to a continuation, nonlocally. The arguments to the
1236 * continuation are taken from the stack. CONTREGS is a free variable
1237 * containing the reified continuation. This instruction is part of
1238 * the implementation of undelimited continuations, and is not
1239 * generated by the compiler.
1240 */
1241 VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
1242 {
1243 SCM contregs;
1244 scm_t_uint32 contregs_idx;
1245
1246 SCM_UNPACK_RTL_24 (op, contregs_idx);
1247
1248 contregs =
1249 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
1250
1251 SYNC_IP ();
1252 scm_i_check_continuation (contregs);
1253 vm_return_to_continuation (scm_i_contregs_vm (contregs),
1254 scm_i_contregs_vm_cont (contregs),
1255 FRAME_LOCALS_COUNT () - 1, fp);
1256 scm_i_reinstate_continuation (contregs);
1257
1258 /* no NEXT */
1259 abort ();
1260 }
1261
1262 /* compose-continuation cont:24
1263 *
1264 * Compose a partial continution with the current continuation. The
1265 * arguments to the continuation are taken from the stack. CONT is a
1266 * free variable containing the reified continuation. This
1267 * instruction is part of the implementation of partial continuations,
1268 * and is not generated by the compiler.
1269 */
1270 VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
1271 {
1272 SCM vmcont;
1273 scm_t_uint32 cont_idx;
1274
1275 SCM_UNPACK_RTL_24 (op, cont_idx);
1276 vmcont = LOCAL_REF (cont_idx);
1277
1278 SYNC_IP ();
1279 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
1280 vm_error_continuation_not_rewindable (vmcont));
1281 vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT () - 1, fp,
1282 &current_thread->dynstack,
1283 &registers);
1284 CACHE_REGISTER ();
1285 NEXT (0);
1286 }
1287
1288 /* tail-apply _:24
1289 *
1290 * Tail-apply the procedure in local slot 0 to the rest of the
1291 * arguments. This instruction is part of the implementation of
1292 * `apply', and is not generated by the compiler.
1293 */
1294 VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
1295 {
1296 int i, list_idx, list_len, nlocals;
1297 SCM list;
1298
1299 VM_HANDLE_INTERRUPTS;
1300
1301 nlocals = FRAME_LOCALS_COUNT ();
1302 // At a minimum, there should be apply, f, and the list.
1303 VM_ASSERT (nlocals >= 3, abort ());
1304 list_idx = nlocals - 1;
1305 list = LOCAL_REF (list_idx);
1306 list_len = scm_ilength (list);
1307
1308 VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
1309
1310 nlocals = nlocals - 2 + list_len;
1311 ALLOC_FRAME (nlocals);
1312
1313 for (i = 1; i < list_idx; i++)
1314 LOCAL_SET (i - 1, LOCAL_REF (i));
1315
1316 /* Null out these slots, just in case there are less than 2 elements
1317 in the list. */
1318 LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
1319 LOCAL_SET (list_idx, SCM_UNDEFINED);
1320
1321 for (i = 0; i < list_len; i++, list = SCM_CDR (list))
1322 LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
1323
1324 APPLY_HOOK ();
1325
1326 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1327 goto apply;
1328
1329 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1330 NEXT (0);
1331 }
1332
1333 /* call/cc _:24
1334 *
1335 * Capture the current continuation, and tail-apply the procedure in
1336 * local slot 1 to it. This instruction is part of the implementation
1337 * of `call/cc', and is not generated by the compiler.
1338 */
1339 VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
1340 {
1341 SCM vm_cont, cont;
1342 scm_t_dynstack *dynstack;
1343 int first;
1344
1345 VM_HANDLE_INTERRUPTS;
1346
1347 SYNC_IP ();
1348 dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
1349 vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1350 SCM_FRAME_DYNAMIC_LINK (fp),
1351 SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1352 SCM_FRAME_RETURN_ADDRESS (fp),
1353 SCM_FRAME_MV_RETURN_ADDRESS (fp),
1354 dynstack,
1355 0);
1356 /* FIXME: Seems silly to capture the registers here, when they are
1357 already captured in the registers local, which here we are
1358 copying out to the heap; and likewise, the setjmp(&registers)
1359 code already has the non-local return handler. But oh
1360 well! */
1361 cont = scm_i_make_continuation (&first, vm, vm_cont);
1362
1363 if (first)
1364 {
1365 LOCAL_SET (0, LOCAL_REF (1));
1366 LOCAL_SET (1, cont);
1367 RESET_FRAME (2);
1368
1369 APPLY_HOOK ();
1370
1371 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1372 goto apply;
1373
1374 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1375 NEXT (0);
1376 }
1377 else
1378 {
1379 CACHE_REGISTER ();
1380 ABORT_CONTINUATION_HOOK (fp, FRAME_LOCALS_COUNT () - 1);
1381 NEXT (0);
1382 }
1383 }
1384
1385
1386 \f
1387
1388 /*
1389 * Function prologues
1390 */
1391
1392 /* br-if-nargs-ne expected:24 _:8 offset:24
1393 * br-if-nargs-lt expected:24 _:8 offset:24
1394 * br-if-nargs-gt expected:24 _:8 offset:24
1395 *
1396 * If the number of actual arguments is not equal, less than, or greater
1397 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1398 * the current instruction pointer.
1399 */
1400 VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
1401 {
1402 BR_NARGS (!=);
1403 }
1404 VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
1405 {
1406 BR_NARGS (<);
1407 }
1408 VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
1409 {
1410 BR_NARGS (>);
1411 }
1412
1413 /* assert-nargs-ee expected:24
1414 * assert-nargs-ge expected:24
1415 * assert-nargs-le expected:24
1416 *
1417 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1418 * respectively, signal an error.
1419 */
1420 VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
1421 {
1422 scm_t_uint32 expected;
1423 SCM_UNPACK_RTL_24 (op, expected);
1424 VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
1425 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1426 NEXT (1);
1427 }
1428 VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
1429 {
1430 scm_t_uint32 expected;
1431 SCM_UNPACK_RTL_24 (op, expected);
1432 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
1433 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1434 NEXT (1);
1435 }
1436 VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
1437 {
1438 scm_t_uint32 expected;
1439 SCM_UNPACK_RTL_24 (op, expected);
1440 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
1441 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1442 NEXT (1);
1443 }
1444
1445 /* alloc-frame nlocals:24
1446 *
1447 * Ensure that there is space on the stack for NLOCALS local variables,
1448 * setting them all to SCM_UNDEFINED, except those nargs values that
1449 * were passed as arguments and procedure.
1450 */
1451 VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
1452 {
1453 scm_t_uint32 nlocals, nargs;
1454 SCM_UNPACK_RTL_24 (op, nlocals);
1455
1456 nargs = FRAME_LOCALS_COUNT ();
1457 ALLOC_FRAME (nlocals);
1458 while (nlocals-- > nargs)
1459 LOCAL_SET (nlocals, SCM_UNDEFINED);
1460
1461 NEXT (1);
1462 }
1463
1464 /* reset-frame nlocals:24
1465 *
1466 * Like alloc-frame, but doesn't check that the stack is big enough.
1467 * Used to reset the frame size to something less than the size that
1468 * was previously set via alloc-frame.
1469 */
1470 VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
1471 {
1472 scm_t_uint32 nlocals;
1473 SCM_UNPACK_RTL_24 (op, nlocals);
1474 RESET_FRAME (nlocals);
1475 NEXT (1);
1476 }
1477
1478 /* assert-nargs-ee/locals expected:12 nlocals:12
1479 *
1480 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1481 * number of locals reserved is EXPECTED + NLOCALS.
1482 */
1483 VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
1484 {
1485 scm_t_uint16 expected, nlocals;
1486 SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
1487 VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
1488 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1489 ALLOC_FRAME (expected + nlocals);
1490 while (nlocals--)
1491 LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
1492
1493 NEXT (1);
1494 }
1495
1496 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1497 * _:8 ntotal:24 kw-offset:32
1498 *
1499 * Find the last positional argument, and shuffle all the rest above
1500 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1501 * load the constant at KW-OFFSET words from the current IP, and use it
1502 * to bind keyword arguments. If HAS-REST, collect all shuffled
1503 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1504 * the arguments that we shuffled up.
1505 *
1506 * A macro-mega-instruction.
1507 */
1508 VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
1509 {
1510 scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
1511 scm_t_int32 kw_offset;
1512 scm_t_bits kw_bits;
1513 SCM kw;
1514 char allow_other_keys, has_rest;
1515
1516 SCM_UNPACK_RTL_24 (op, nreq);
1517 allow_other_keys = ip[1] & 0x1;
1518 has_rest = ip[1] & 0x2;
1519 SCM_UNPACK_RTL_24 (ip[1], nreq_and_opt);
1520 SCM_UNPACK_RTL_24 (ip[2], ntotal);
1521 kw_offset = ip[3];
1522 kw_bits = (scm_t_bits) (ip + kw_offset);
1523 VM_ASSERT (!(kw_bits & 0x7), abort());
1524 kw = SCM_PACK (kw_bits);
1525
1526 nargs = FRAME_LOCALS_COUNT ();
1527
1528 /* look in optionals for first keyword or last positional */
1529 /* starting after the last required positional arg */
1530 npositional = nreq;
1531 while (/* while we have args */
1532 npositional < nargs
1533 /* and we still have positionals to fill */
1534 && npositional < nreq_and_opt
1535 /* and we haven't reached a keyword yet */
1536 && !scm_is_keyword (LOCAL_REF (npositional)))
1537 /* bind this optional arg (by leaving it in place) */
1538 npositional++;
1539 nkw = nargs - npositional;
1540 /* shuffle non-positional arguments above ntotal */
1541 ALLOC_FRAME (ntotal + nkw);
1542 n = nkw;
1543 while (n--)
1544 LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n));
1545 /* and fill optionals & keyword args with SCM_UNDEFINED */
1546 n = npositional;
1547 while (n < ntotal)
1548 LOCAL_SET (n++, SCM_UNDEFINED);
1549
1550 VM_ASSERT (has_rest || (nkw % 2) == 0,
1551 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp)));
1552
1553 /* Now bind keywords, in the order given. */
1554 for (n = 0; n < nkw; n++)
1555 if (scm_is_keyword (LOCAL_REF (ntotal + n)))
1556 {
1557 SCM walk;
1558 for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
1559 if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n)))
1560 {
1561 SCM si = SCM_CDAR (walk);
1562 LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si),
1563 LOCAL_REF (ntotal + n + 1));
1564 break;
1565 }
1566 VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
1567 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp),
1568 LOCAL_REF (ntotal + n)));
1569 n++;
1570 }
1571 else
1572 VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
1573 LOCAL_REF (ntotal + n)));
1574
1575 if (has_rest)
1576 {
1577 SCM rest = SCM_EOL;
1578 n = nkw;
1579 while (n--)
1580 rest = scm_cons (LOCAL_REF (ntotal + n), rest);
1581 LOCAL_SET (nreq_and_opt, rest);
1582 }
1583
1584 RESET_FRAME (ntotal);
1585
1586 NEXT (4);
1587 }
1588
1589 /* bind-rest dst:24
1590 *
1591 * Collect any arguments at or above DST into a list, and store that
1592 * list at DST.
1593 */
1594 VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
1595 {
1596 scm_t_uint32 dst, nargs;
1597 SCM rest = SCM_EOL;
1598
1599 SCM_UNPACK_RTL_24 (op, dst);
1600 nargs = FRAME_LOCALS_COUNT ();
1601
1602 if (nargs <= dst)
1603 {
1604 ALLOC_FRAME (dst + 1);
1605 while (nargs < dst)
1606 LOCAL_SET (nargs++, SCM_UNDEFINED);
1607 }
1608 else
1609 {
1610 while (nargs-- > dst)
1611 {
1612 rest = scm_cons (LOCAL_REF (nargs), rest);
1613 LOCAL_SET (nargs, SCM_UNDEFINED);
1614 }
1615
1616 RESET_FRAME (dst + 1);
1617 }
1618
1619 LOCAL_SET (dst, rest);
1620
1621 NEXT (1);
1622 }
1623
1624
1625 \f
1626
1627 /*
1628 * Branching instructions
1629 */
1630
1631 /* br offset:24
1632 *
1633 * Add OFFSET, a signed 24-bit number, to the current instruction
1634 * pointer.
1635 */
1636 VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
1637 {
1638 scm_t_int32 offset = op;
1639 offset >>= 8; /* Sign-extending shift. */
1640 NEXT (offset);
1641 }
1642
1643 /* br-if-true test:24 invert:1 _:7 offset:24
1644 *
1645 * If the value in TEST is true for the purposes of Scheme, add
1646 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1647 */
1648 VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
1649 {
1650 BR_UNARY (x, scm_is_true (x));
1651 }
1652
1653 /* br-if-null test:24 invert:1 _:7 offset:24
1654 *
1655 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1656 * signed 24-bit number, to the current instruction pointer.
1657 */
1658 VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
1659 {
1660 BR_UNARY (x, scm_is_null (x));
1661 }
1662
1663 /* br-if-nil test:24 invert:1 _:7 offset:24
1664 *
1665 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1666 * number, to the current instruction pointer.
1667 */
1668 VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
1669 {
1670 BR_UNARY (x, scm_is_lisp_false (x));
1671 }
1672
1673 /* br-if-pair test:24 invert:1 _:7 offset:24
1674 *
1675 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1676 * to the current instruction pointer.
1677 */
1678 VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
1679 {
1680 BR_UNARY (x, scm_is_pair (x));
1681 }
1682
1683 /* br-if-struct test:24 invert:1 _:7 offset:24
1684 *
1685 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1686 * number, to the current instruction pointer.
1687 */
1688 VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
1689 {
1690 BR_UNARY (x, SCM_STRUCTP (x));
1691 }
1692
1693 /* br-if-char test:24 invert:1 _:7 offset:24
1694 *
1695 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1696 * to the current instruction pointer.
1697 */
1698 VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
1699 {
1700 BR_UNARY (x, SCM_CHARP (x));
1701 }
1702
1703 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1704 *
1705 * If the value in TEST has the TC7 given in the second word, add
1706 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1707 */
1708 VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
1709 {
1710 BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
1711 }
1712
1713 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1714 *
1715 * If the value in A is eq? to the value in B, add OFFSET, a signed
1716 * 24-bit number, to the current instruction pointer.
1717 */
1718 VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
1719 {
1720 BR_BINARY (x, y, scm_is_eq (x, y));
1721 }
1722
1723 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1724 *
1725 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1726 * 24-bit number, to the current instruction pointer.
1727 */
1728 VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
1729 {
1730 BR_BINARY (x, y,
1731 scm_is_eq (x, y)
1732 || (SCM_NIMP (x) && SCM_NIMP (y)
1733 && scm_is_true (scm_eqv_p (x, y))));
1734 }
1735
1736 // FIXME: remove, have compiler inline eqv test instead
1737 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1738 *
1739 * If the value in A is equal? to the value in B, add OFFSET, a signed
1740 * 24-bit number, to the current instruction pointer.
1741 */
1742 // FIXME: should sync_ip before calling out?
1743 VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
1744 {
1745 BR_BINARY (x, y,
1746 scm_is_eq (x, y)
1747 || (SCM_NIMP (x) && SCM_NIMP (y)
1748 && scm_is_true (scm_equal_p (x, y))));
1749 }
1750
1751 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
1752 *
1753 * If the value in A is = to the value in B, add OFFSET, a signed
1754 * 24-bit number, to the current instruction pointer.
1755 */
1756 VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
1757 {
1758 BR_ARITHMETIC (==, scm_num_eq_p);
1759 }
1760
1761 /* br-if-< a:12 b:12 _:8 offset:24
1762 *
1763 * If the value in A is < to the value in B, add OFFSET, a signed
1764 * 24-bit number, to the current instruction pointer.
1765 */
1766 VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
1767 {
1768 BR_ARITHMETIC (<, scm_less_p);
1769 }
1770
1771 /* br-if-<= a:12 b:12 _:8 offset:24
1772 *
1773 * If the value in A is <= to the value in B, add OFFSET, a signed
1774 * 24-bit number, to the current instruction pointer.
1775 */
1776 VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
1777 {
1778 BR_ARITHMETIC (<=, scm_leq_p);
1779 }
1780
1781
1782 \f
1783
1784 /*
1785 * Lexical binding instructions
1786 */
1787
1788 /* mov dst:12 src:12
1789 *
1790 * Copy a value from one local slot to another.
1791 */
1792 VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
1793 {
1794 scm_t_uint16 dst;
1795 scm_t_uint16 src;
1796
1797 SCM_UNPACK_RTL_12_12 (op, dst, src);
1798 LOCAL_SET (dst, LOCAL_REF (src));
1799
1800 NEXT (1);
1801 }
1802
1803 /* long-mov dst:24 _:8 src:24
1804 *
1805 * Copy a value from one local slot to another.
1806 */
1807 VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
1808 {
1809 scm_t_uint32 dst;
1810 scm_t_uint32 src;
1811
1812 SCM_UNPACK_RTL_24 (op, dst);
1813 SCM_UNPACK_RTL_24 (ip[1], src);
1814 LOCAL_SET (dst, LOCAL_REF (src));
1815
1816 NEXT (2);
1817 }
1818
1819 /* box dst:12 src:12
1820 *
1821 * Create a new variable holding SRC, and place it in DST.
1822 */
1823 VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
1824 {
1825 scm_t_uint16 dst, src;
1826 SCM_UNPACK_RTL_12_12 (op, dst, src);
1827 LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src))));
1828 NEXT (1);
1829 }
1830
1831 /* box-ref dst:12 src:12
1832 *
1833 * Unpack the variable at SRC into DST, asserting that the variable is
1834 * actually bound.
1835 */
1836 VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
1837 {
1838 scm_t_uint16 dst, src;
1839 SCM var;
1840 SCM_UNPACK_RTL_12_12 (op, dst, src);
1841 var = LOCAL_REF (src);
1842 VM_ASSERT (SCM_VARIABLEP (var),
1843 vm_error_not_a_variable ("variable-ref", var));
1844 VM_ASSERT (VARIABLE_BOUNDP (var),
1845 vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
1846 LOCAL_SET (dst, VARIABLE_REF (var));
1847 NEXT (1);
1848 }
1849
1850 /* box-set! dst:12 src:12
1851 *
1852 * Set the contents of the variable at DST to SET.
1853 */
1854 VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12))
1855 {
1856 scm_t_uint16 dst, src;
1857 SCM var;
1858 SCM_UNPACK_RTL_12_12 (op, dst, src);
1859 var = LOCAL_REF (dst);
1860 VM_ASSERT (SCM_VARIABLEP (var),
1861 vm_error_not_a_variable ("variable-set!", var));
1862 VARIABLE_SET (var, LOCAL_REF (src));
1863 NEXT (1);
1864 }
1865
1866 /* make-closure dst:24 offset:32 _:8 nfree:24
1867 *
1868 * Make a new closure, and write it to DST. The code for the closure
1869 * will be found at OFFSET words from the current IP. OFFSET is a
1870 * signed 32-bit integer. Space for NFREE free variables will be
1871 * allocated.
1872 */
1873 VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
1874 {
1875 scm_t_uint32 dst, nfree, n;
1876 scm_t_int32 offset;
1877 SCM closure;
1878
1879 SCM_UNPACK_RTL_24 (op, dst);
1880 offset = ip[1];
1881 SCM_UNPACK_RTL_24 (ip[2], nfree);
1882
1883 // FIXME: Assert range of nfree?
1884 closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
1885 SCM_SET_CELL_WORD_1 (closure, ip + offset);
1886 // FIXME: Elide these initializations?
1887 for (n = 0; n < nfree; n++)
1888 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
1889 LOCAL_SET (dst, closure);
1890 NEXT (3);
1891 }
1892
1893 /* free-ref dst:12 src:12 _:8 idx:24
1894 *
1895 * Load free variable IDX from the closure SRC into local slot DST.
1896 */
1897 VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
1898 {
1899 scm_t_uint16 dst, src;
1900 scm_t_uint32 idx;
1901 SCM_UNPACK_RTL_12_12 (op, dst, src);
1902 SCM_UNPACK_RTL_24 (ip[1], idx);
1903 /* CHECK_FREE_VARIABLE (src); */
1904 LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
1905 NEXT (2);
1906 }
1907
1908 /* free-set! dst:12 src:12 _8 idx:24
1909 *
1910 * Set free variable IDX from the closure DST to SRC.
1911 */
1912 VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
1913 {
1914 scm_t_uint16 dst, src;
1915 scm_t_uint32 idx;
1916 SCM_UNPACK_RTL_12_12 (op, dst, src);
1917 SCM_UNPACK_RTL_24 (ip[1], idx);
1918 /* CHECK_FREE_VARIABLE (src); */
1919 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
1920 NEXT (2);
1921 }
1922
1923
1924 \f
1925
1926 /*
1927 * Immediates and statically allocated non-immediates
1928 */
1929
1930 /* make-short-immediate dst:8 low-bits:16
1931 *
1932 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1933 * 0.
1934 */
1935 VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
1936 {
1937 scm_t_uint8 dst;
1938 scm_t_bits val;
1939
1940 SCM_UNPACK_RTL_8_16 (op, dst, val);
1941 LOCAL_SET (dst, SCM_PACK (val));
1942 NEXT (1);
1943 }
1944
1945 /* make-long-immediate dst:24 low-bits:32
1946 *
1947 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1948 * 0.
1949 */
1950 VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
1951 {
1952 scm_t_uint8 dst;
1953 scm_t_bits val;
1954
1955 SCM_UNPACK_RTL_24 (op, dst);
1956 val = ip[1];
1957 LOCAL_SET (dst, SCM_PACK (val));
1958 NEXT (2);
1959 }
1960
1961 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1962 *
1963 * Make an immediate with HIGH-BITS and LOW-BITS.
1964 */
1965 VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
1966 {
1967 scm_t_uint8 dst;
1968 scm_t_bits val;
1969
1970 SCM_UNPACK_RTL_24 (op, dst);
1971 #if SIZEOF_SCM_T_BITS > 4
1972 val = ip[1];
1973 val <<= 32;
1974 val |= ip[2];
1975 #else
1976 ASSERT (ip[1] == 0);
1977 val = ip[2];
1978 #endif
1979 LOCAL_SET (dst, SCM_PACK (val));
1980 NEXT (3);
1981 }
1982
1983 /* make-non-immediate dst:24 offset:32
1984 *
1985 * Load a pointer to statically allocated memory into DST. The
1986 * object's memory is will be found OFFSET 32-bit words away from the
1987 * current instruction pointer. OFFSET is a signed value. The
1988 * intention here is that the compiler would produce an object file
1989 * containing the words of a non-immediate object, and this
1990 * instruction creates a pointer to that memory, effectively
1991 * resurrecting that object.
1992 *
1993 * Whether the object is mutable or immutable depends on where it was
1994 * allocated by the compiler, and loaded by the loader.
1995 */
1996 VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
1997 {
1998 scm_t_uint32 dst;
1999 scm_t_int32 offset;
2000 scm_t_uint32* loc;
2001 scm_t_bits unpacked;
2002
2003 SCM_UNPACK_RTL_24 (op, dst);
2004 offset = ip[1];
2005 loc = ip + offset;
2006 unpacked = (scm_t_bits) loc;
2007
2008 VM_ASSERT (!(unpacked & 0x7), abort());
2009
2010 LOCAL_SET (dst, SCM_PACK (unpacked));
2011
2012 NEXT (2);
2013 }
2014
2015 /* static-ref dst:24 offset:32
2016 *
2017 * Load a SCM value into DST. The SCM value will be fetched from
2018 * memory, OFFSET 32-bit words away from the current instruction
2019 * pointer. OFFSET is a signed value.
2020 *
2021 * The intention is for this instruction to be used to load constants
2022 * that the compiler is unable to statically allocate, like symbols.
2023 * These values would be initialized when the object file loads.
2024 */
2025 VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
2026 {
2027 scm_t_uint32 dst;
2028 scm_t_int32 offset;
2029 scm_t_uint32* loc;
2030 scm_t_uintptr loc_bits;
2031
2032 SCM_UNPACK_RTL_24 (op, dst);
2033 offset = ip[1];
2034 loc = ip + offset;
2035 loc_bits = (scm_t_uintptr) loc;
2036 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2037
2038 LOCAL_SET (dst, *((SCM *) loc_bits));
2039
2040 NEXT (2);
2041 }
2042
2043 /* static-set! src:24 offset:32
2044 *
2045 * Store a SCM value into memory, OFFSET 32-bit words away from the
2046 * current instruction pointer. OFFSET is a signed value.
2047 */
2048 VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
2049 {
2050 scm_t_uint32 src;
2051 scm_t_int32 offset;
2052 scm_t_uint32* loc;
2053
2054 SCM_UNPACK_RTL_24 (op, src);
2055 offset = ip[1];
2056 loc = ip + offset;
2057 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2058
2059 *((SCM *) loc) = LOCAL_REF (src);
2060
2061 NEXT (2);
2062 }
2063
2064 /* link-procedure! src:24 offset:32
2065 *
2066 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2067 * words away from the current instruction pointer. OFFSET is a
2068 * signed value.
2069 */
2070 VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
2071 {
2072 scm_t_uint32 src;
2073 scm_t_int32 offset;
2074 scm_t_uint32* loc;
2075
2076 SCM_UNPACK_RTL_24 (op, src);
2077 offset = ip[1];
2078 loc = ip + offset;
2079
2080 SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
2081
2082 NEXT (2);
2083 }
2084
2085 \f
2086
2087 /*
2088 * Mutable top-level bindings
2089 */
2090
2091 /* There are three slightly different ways to resolve toplevel
2092 variables.
2093
2094 1. A toplevel reference outside of a function. These need to be
2095 looked up when the expression is evaluated -- no later, and no
2096 before. They are looked up relative to the module that is
2097 current when the expression is evaluated. For example:
2098
2099 (if (foo) a b)
2100
2101 The "resolve" instruction resolves the variable (box), and then
2102 access is via box-ref or box-set!.
2103
2104 2. A toplevel reference inside a function. These are looked up
2105 relative to the module that was current when the function was
2106 defined. Unlike code at the toplevel, which is usually run only
2107 once, these bindings benefit from memoized lookup, in which the
2108 variable resulting from the lookup is cached in the function.
2109
2110 (lambda () (if (foo) a b))
2111
2112 The toplevel-box instruction is equivalent to "resolve", but
2113 caches the resulting variable in statically allocated memory.
2114
2115 3. A reference to an identifier with respect to a particular
2116 module. This can happen for primitive references, and
2117 references residualized by macro expansions. These can always
2118 be cached. Use module-box for these.
2119 */
2120
2121 /* current-module dst:24
2122 *
2123 * Store the current module in DST.
2124 */
2125 VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
2126 {
2127 scm_t_uint32 dst;
2128
2129 SCM_UNPACK_RTL_24 (op, dst);
2130
2131 SYNC_IP ();
2132 LOCAL_SET (dst, scm_current_module ());
2133
2134 NEXT (1);
2135 }
2136
2137 /* resolve dst:24 bound?:1 _:7 sym:24
2138 *
2139 * Resolve SYM in the current module, and place the resulting variable
2140 * in DST.
2141 */
2142 VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
2143 {
2144 scm_t_uint32 dst;
2145 scm_t_uint32 sym;
2146 SCM var;
2147
2148 SCM_UNPACK_RTL_24 (op, dst);
2149 SCM_UNPACK_RTL_24 (ip[1], sym);
2150
2151 SYNC_IP ();
2152 var = scm_lookup (LOCAL_REF (sym));
2153 if (ip[1] & 0x1)
2154 VM_ASSERT (VARIABLE_BOUNDP (var),
2155 vm_error_unbound (fp[-1], LOCAL_REF (sym)));
2156 LOCAL_SET (dst, var);
2157
2158 NEXT (2);
2159 }
2160
2161 /* define sym:12 val:12
2162 *
2163 * Look up a binding for SYM in the current module, creating it if
2164 * necessary. Set its value to VAL.
2165 */
2166 VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
2167 {
2168 scm_t_uint16 sym, val;
2169 SCM_UNPACK_RTL_12_12 (op, sym, val);
2170 SYNC_IP ();
2171 scm_define (LOCAL_REF (sym), LOCAL_REF (val));
2172 NEXT (1);
2173 }
2174
2175 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2176 *
2177 * Load a SCM value. The SCM value will be fetched from memory,
2178 * VAR-OFFSET 32-bit words away from the current instruction pointer.
2179 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
2180 * static-ref.
2181 *
2182 * Then, if the loaded value is a variable, it is placed in DST, and control
2183 * flow continues.
2184 *
2185 * Otherwise, we have to resolve the variable. In that case we load
2186 * the module from MOD-OFFSET, just as we loaded the variable.
2187 * Usually the module gets set when the closure is created. The name
2188 * is an offset to a symbol.
2189 *
2190 * We use the module and the symbol to resolve the variable, placing it in
2191 * DST, and caching the resolved variable so that we will hit the cache next
2192 * time.
2193 */
2194 VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
2195 {
2196 scm_t_uint32 dst;
2197 scm_t_int32 var_offset;
2198 scm_t_uint32* var_loc_u32;
2199 SCM *var_loc;
2200 SCM var;
2201
2202 SCM_UNPACK_RTL_24 (op, dst);
2203 var_offset = ip[1];
2204 var_loc_u32 = ip + var_offset;
2205 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2206 var_loc = (SCM *) var_loc_u32;
2207 var = *var_loc;
2208
2209 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2210 {
2211 SCM mod, sym;
2212 scm_t_int32 mod_offset = ip[2]; /* signed */
2213 scm_t_int32 sym_offset = ip[3]; /* signed */
2214 scm_t_uint32 *mod_loc = ip + mod_offset;
2215 scm_t_uint32 *sym_loc = ip + sym_offset;
2216
2217 SYNC_IP ();
2218
2219 VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
2220 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2221
2222 mod = *((SCM *) mod_loc);
2223 sym = *((SCM *) sym_loc);
2224
2225 /* If the toplevel scope was captured before modules were
2226 booted, use the root module. */
2227 if (scm_is_false (mod))
2228 mod = scm_the_root_module ();
2229
2230 var = scm_module_lookup (mod, sym);
2231 if (ip[4] & 0x1)
2232 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
2233
2234 *var_loc = var;
2235 }
2236
2237 LOCAL_SET (dst, var);
2238 NEXT (5);
2239 }
2240
2241 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
2242 *
2243 * Like toplevel-box, except MOD-OFFSET points at the name of a module
2244 * instead of the module itself.
2245 */
2246 VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
2247 {
2248 scm_t_uint32 dst;
2249 scm_t_int32 var_offset;
2250 scm_t_uint32* var_loc_u32;
2251 SCM *var_loc;
2252 SCM var;
2253
2254 SCM_UNPACK_RTL_24 (op, dst);
2255 var_offset = ip[1];
2256 var_loc_u32 = ip + var_offset;
2257 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2258 var_loc = (SCM *) var_loc_u32;
2259 var = *var_loc;
2260
2261 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2262 {
2263 SCM modname, sym;
2264 scm_t_int32 modname_offset = ip[2]; /* signed */
2265 scm_t_int32 sym_offset = ip[3]; /* signed */
2266 scm_t_uint32 *modname_words = ip + modname_offset;
2267 scm_t_uint32 *sym_loc = ip + sym_offset;
2268
2269 SYNC_IP ();
2270
2271 VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
2272 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2273
2274 modname = SCM_PACK ((scm_t_bits) modname_words);
2275 sym = *((SCM *) sym_loc);
2276
2277 if (!scm_module_system_booted_p)
2278 {
2279 #ifdef VM_ENABLE_PARANOID_ASSERTIONS
2280 ASSERT
2281 (scm_is_true
2282 scm_equal_p (modname,
2283 scm_list_2 (SCM_BOOL_T,
2284 scm_from_utf8_symbol ("guile"))));
2285 #endif
2286 var = scm_lookup (sym);
2287 }
2288 else if (scm_is_true (SCM_CAR (modname)))
2289 var = scm_public_lookup (SCM_CDR (modname), sym);
2290 else
2291 var = scm_private_lookup (SCM_CDR (modname), sym);
2292
2293 if (ip[4] & 0x1)
2294 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
2295
2296 *var_loc = var;
2297 }
2298
2299 LOCAL_SET (dst, var);
2300 NEXT (5);
2301 }
2302
2303 \f
2304
2305 /*
2306 * The dynamic environment
2307 */
2308
2309 /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
2310 *
2311 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2312 * handler at HANDLER-OFFSET words from the current IP. The handler
2313 * will expect a multiple-value return as if from a call with the
2314 * procedure at PROC-SLOT.
2315 */
2316 VM_DEFINE_OP (58, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
2317 {
2318 scm_t_uint32 tag, proc_slot;
2319 scm_t_int32 offset;
2320 scm_t_uint8 escape_only_p;
2321 scm_t_dynstack_prompt_flags flags;
2322
2323 SCM_UNPACK_RTL_24 (op, tag);
2324 escape_only_p = ip[1] & 0x1;
2325 SCM_UNPACK_RTL_24 (ip[1], proc_slot);
2326 offset = ip[2];
2327 offset >>= 8; /* Sign extension */
2328
2329 /* Push the prompt onto the dynamic stack. */
2330 flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
2331 scm_dynstack_push_prompt (&current_thread->dynstack, flags,
2332 LOCAL_REF (tag),
2333 fp,
2334 &LOCAL_REF (proc_slot),
2335 (scm_t_uint8 *)(ip + offset),
2336 &registers);
2337 NEXT (3);
2338 }
2339
2340 /* wind winder:12 unwinder:12
2341 *
2342 * Push wind and unwind procedures onto the dynamic stack. Note that
2343 * neither are actually called; the compiler should emit calls to wind
2344 * and unwind for the normal dynamic-wind control flow. Also note that
2345 * the compiler should have inserted checks that they wind and unwind
2346 * procs are thunks, if it could not prove that to be the case.
2347 */
2348 VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
2349 {
2350 scm_t_uint16 winder, unwinder;
2351 SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
2352 scm_dynstack_push_dynwind (&current_thread->dynstack,
2353 LOCAL_REF (winder), LOCAL_REF (unwinder));
2354 NEXT (1);
2355 }
2356
2357 /* abort tag:24 _:8 proc:24
2358 *
2359 * Return a number of values to a prompt handler. The values are
2360 * expected in a frame pushed on at PROC.
2361 */
2362 VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
2363 #if 0
2364 {
2365 scm_t_uint32 tag, from, nvalues;
2366 SCM *base;
2367
2368 SCM_UNPACK_RTL_24 (op, tag);
2369 SCM_UNPACK_RTL_24 (ip[1], from);
2370 base = (fp - 1) + from + 3;
2371 nvalues = FRAME_LOCALS_COUNT () - from - 3;
2372
2373 SYNC_IP ();
2374 vm_abort (vm, LOCAL_REF (tag), base, nvalues, &registers);
2375
2376 /* vm_abort should not return */
2377 abort ();
2378 }
2379 #else
2380 abort();
2381 #endif
2382
2383 /* unwind _:24
2384 *
2385 * A normal exit from the dynamic extent of an expression. Pop the top
2386 * entry off of the dynamic stack.
2387 */
2388 VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
2389 {
2390 scm_dynstack_pop (&current_thread->dynstack);
2391 NEXT (1);
2392 }
2393
2394 /* push-fluid fluid:12 value:12
2395 *
2396 * Dynamically bind N fluids to values. The fluids are expected to be
2397 * allocated in a continguous range on the stack, starting from
2398 * FLUID-BASE. The values do not have this restriction.
2399 */
2400 VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
2401 {
2402 scm_t_uint32 fluid, value;
2403
2404 SCM_UNPACK_RTL_12_12 (op, fluid, value);
2405
2406 scm_dynstack_push_fluid (&current_thread->dynstack,
2407 LOCAL_REF (fluid), LOCAL_REF (value),
2408 current_thread->dynamic_state);
2409 NEXT (1);
2410 }
2411
2412 /* pop-fluid _:24
2413 *
2414 * Leave the dynamic extent of a with-fluids expression, restoring the
2415 * fluids to their previous values.
2416 */
2417 VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
2418 {
2419 /* This function must not allocate. */
2420 scm_dynstack_unwind_fluid (&current_thread->dynstack,
2421 current_thread->dynamic_state);
2422 NEXT (1);
2423 }
2424
2425 /* fluid-ref dst:12 src:12
2426 *
2427 * Reference the fluid in SRC, and place the value in DST.
2428 */
2429 VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
2430 {
2431 scm_t_uint16 dst, src;
2432 size_t num;
2433 SCM fluid, fluids;
2434
2435 SCM_UNPACK_RTL_12_12 (op, dst, src);
2436 fluid = LOCAL_REF (src);
2437 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2438 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2439 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2440 {
2441 /* Punt dynstate expansion and error handling to the C proc. */
2442 SYNC_IP ();
2443 LOCAL_SET (dst, scm_fluid_ref (fluid));
2444 }
2445 else
2446 {
2447 SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
2448 if (scm_is_eq (val, SCM_UNDEFINED))
2449 val = SCM_I_FLUID_DEFAULT (fluid);
2450 VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
2451 vm_error_unbound_fluid (program, fluid));
2452 LOCAL_SET (dst, val);
2453 }
2454
2455 NEXT (1);
2456 }
2457
2458 /* fluid-set fluid:12 val:12
2459 *
2460 * Set the value of the fluid in DST to the value in SRC.
2461 */
2462 VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
2463 {
2464 scm_t_uint16 a, b;
2465 size_t num;
2466 SCM fluid, fluids;
2467
2468 SCM_UNPACK_RTL_12_12 (op, a, b);
2469 fluid = LOCAL_REF (a);
2470 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2471 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2472 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2473 {
2474 /* Punt dynstate expansion and error handling to the C proc. */
2475 SYNC_IP ();
2476 scm_fluid_set_x (fluid, LOCAL_REF (b));
2477 }
2478 else
2479 SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b));
2480
2481 NEXT (1);
2482 }
2483
2484
2485 \f
2486
2487 /*
2488 * Strings, symbols, and keywords
2489 */
2490
2491 /* string-length dst:12 src:12
2492 *
2493 * Store the length of the string in SRC in DST.
2494 */
2495 VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
2496 {
2497 ARGS1 (str);
2498 if (SCM_LIKELY (scm_is_string (str)))
2499 RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
2500 else
2501 {
2502 SYNC_IP ();
2503 RETURN (scm_string_length (str));
2504 }
2505 }
2506
2507 /* string-ref dst:8 src:8 idx:8
2508 *
2509 * Fetch the character at position IDX in the string in SRC, and store
2510 * it in DST.
2511 */
2512 VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2513 {
2514 scm_t_signed_bits i = 0;
2515 ARGS2 (str, idx);
2516 if (SCM_LIKELY (scm_is_string (str)
2517 && SCM_I_INUMP (idx)
2518 && ((i = SCM_I_INUM (idx)) >= 0)
2519 && i < scm_i_string_length (str)))
2520 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
2521 else
2522 {
2523 SYNC_IP ();
2524 RETURN (scm_string_ref (str, idx));
2525 }
2526 }
2527
2528 /* No string-set! instruction, as there is no good fast path there. */
2529
2530 /* string-to-number dst:12 src:12
2531 *
2532 * Parse a string in SRC to a number, and store in DST.
2533 */
2534 VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
2535 {
2536 scm_t_uint16 dst, src;
2537
2538 SCM_UNPACK_RTL_12_12 (op, dst, src);
2539 SYNC_IP ();
2540 LOCAL_SET (dst,
2541 scm_string_to_number (LOCAL_REF (src),
2542 SCM_UNDEFINED /* radix = 10 */));
2543 NEXT (1);
2544 }
2545
2546 /* string-to-symbol dst:12 src:12
2547 *
2548 * Parse a string in SRC to a symbol, and store in DST.
2549 */
2550 VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
2551 {
2552 scm_t_uint16 dst, src;
2553
2554 SCM_UNPACK_RTL_12_12 (op, dst, src);
2555 SYNC_IP ();
2556 LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
2557 NEXT (1);
2558 }
2559
2560 /* symbol->keyword dst:12 src:12
2561 *
2562 * Make a keyword from the symbol in SRC, and store it in DST.
2563 */
2564 VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
2565 {
2566 scm_t_uint16 dst, src;
2567 SCM_UNPACK_RTL_12_12 (op, dst, src);
2568 SYNC_IP ();
2569 LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
2570 NEXT (1);
2571 }
2572
2573 \f
2574
2575 /*
2576 * Pairs
2577 */
2578
2579 /* cons dst:8 car:8 cdr:8
2580 *
2581 * Cons CAR and CDR, and store the result in DST.
2582 */
2583 VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
2584 {
2585 ARGS2 (x, y);
2586 RETURN (scm_cons (x, y));
2587 }
2588
2589 /* car dst:12 src:12
2590 *
2591 * Place the car of SRC in DST.
2592 */
2593 VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
2594 {
2595 ARGS1 (x);
2596 VM_VALIDATE_PAIR (x, "car");
2597 RETURN (SCM_CAR (x));
2598 }
2599
2600 /* cdr dst:12 src:12
2601 *
2602 * Place the cdr of SRC in DST.
2603 */
2604 VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
2605 {
2606 ARGS1 (x);
2607 VM_VALIDATE_PAIR (x, "cdr");
2608 RETURN (SCM_CDR (x));
2609 }
2610
2611 /* set-car! pair:12 car:12
2612 *
2613 * Set the car of DST to SRC.
2614 */
2615 VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
2616 {
2617 scm_t_uint16 a, b;
2618 SCM x, y;
2619 SCM_UNPACK_RTL_12_12 (op, a, b);
2620 x = LOCAL_REF (a);
2621 y = LOCAL_REF (b);
2622 VM_VALIDATE_PAIR (x, "set-car!");
2623 SCM_SETCAR (x, y);
2624 NEXT (1);
2625 }
2626
2627 /* set-cdr! pair:12 cdr:12
2628 *
2629 * Set the cdr of DST to SRC.
2630 */
2631 VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
2632 {
2633 scm_t_uint16 a, b;
2634 SCM x, y;
2635 SCM_UNPACK_RTL_12_12 (op, a, b);
2636 x = LOCAL_REF (a);
2637 y = LOCAL_REF (b);
2638 VM_VALIDATE_PAIR (x, "set-car!");
2639 SCM_SETCDR (x, y);
2640 NEXT (1);
2641 }
2642
2643
2644 \f
2645
2646 /*
2647 * Numeric operations
2648 */
2649
2650 /* add dst:8 a:8 b:8
2651 *
2652 * Add A to B, and place the result in DST.
2653 */
2654 VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
2655 {
2656 BINARY_INTEGER_OP (+, scm_sum);
2657 }
2658
2659 /* add1 dst:12 src:12
2660 *
2661 * Add 1 to the value in SRC, and place the result in DST.
2662 */
2663 VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
2664 {
2665 ARGS1 (x);
2666
2667 /* Check for overflow. We must avoid overflow in the signed
2668 addition below, even if X is not an inum. */
2669 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
2670 {
2671 SCM result;
2672
2673 /* Add 1 to the integer without untagging. */
2674 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
2675
2676 if (SCM_LIKELY (SCM_I_INUMP (result)))
2677 RETURN (result);
2678 }
2679
2680 SYNC_IP ();
2681 RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
2682 }
2683
2684 /* sub dst:8 a:8 b:8
2685 *
2686 * Subtract B from A, and place the result in DST.
2687 */
2688 VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
2689 {
2690 BINARY_INTEGER_OP (-, scm_difference);
2691 }
2692
2693 /* sub1 dst:12 src:12
2694 *
2695 * Subtract 1 from SRC, and place the result in DST.
2696 */
2697 VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
2698 {
2699 ARGS1 (x);
2700
2701 /* Check for overflow. We must avoid overflow in the signed
2702 subtraction below, even if X is not an inum. */
2703 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
2704 {
2705 SCM result;
2706
2707 /* Substract 1 from the integer without untagging. */
2708 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
2709
2710 if (SCM_LIKELY (SCM_I_INUMP (result)))
2711 RETURN (result);
2712 }
2713
2714 SYNC_IP ();
2715 RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
2716 }
2717
2718 /* mul dst:8 a:8 b:8
2719 *
2720 * Multiply A and B, and place the result in DST.
2721 */
2722 VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
2723 {
2724 ARGS2 (x, y);
2725 SYNC_IP ();
2726 RETURN (scm_product (x, y));
2727 }
2728
2729 /* div dst:8 a:8 b:8
2730 *
2731 * Divide A by B, and place the result in DST.
2732 */
2733 VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
2734 {
2735 ARGS2 (x, y);
2736 SYNC_IP ();
2737 RETURN (scm_divide (x, y));
2738 }
2739
2740 /* quo dst:8 a:8 b:8
2741 *
2742 * Divide A by B, and place the quotient in DST.
2743 */
2744 VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
2745 {
2746 ARGS2 (x, y);
2747 SYNC_IP ();
2748 RETURN (scm_quotient (x, y));
2749 }
2750
2751 /* rem dst:8 a:8 b:8
2752 *
2753 * Divide A by B, and place the remainder in DST.
2754 */
2755 VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
2756 {
2757 ARGS2 (x, y);
2758 SYNC_IP ();
2759 RETURN (scm_remainder (x, y));
2760 }
2761
2762 /* mod dst:8 a:8 b:8
2763 *
2764 * Place the modulo of A by B in DST.
2765 */
2766 VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
2767 {
2768 ARGS2 (x, y);
2769 SYNC_IP ();
2770 RETURN (scm_modulo (x, y));
2771 }
2772
2773 /* ash dst:8 a:8 b:8
2774 *
2775 * Shift A arithmetically by B bits, and place the result in DST.
2776 */
2777 VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
2778 {
2779 ARGS2 (x, y);
2780 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2781 {
2782 if (SCM_I_INUM (y) < 0)
2783 /* Right shift, will be a fixnum. */
2784 RETURN (SCM_I_MAKINUM
2785 (SCM_SRS (SCM_I_INUM (x),
2786 (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
2787 ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
2788 else
2789 /* Left shift. See comments in scm_ash. */
2790 {
2791 scm_t_signed_bits nn, bits_to_shift;
2792
2793 nn = SCM_I_INUM (x);
2794 bits_to_shift = SCM_I_INUM (y);
2795
2796 if (bits_to_shift < SCM_I_FIXNUM_BIT-1
2797 && ((scm_t_bits)
2798 (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
2799 <= 1))
2800 RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
2801 /* fall through */
2802 }
2803 /* fall through */
2804 }
2805 SYNC_IP ();
2806 RETURN (scm_ash (x, y));
2807 }
2808
2809 /* logand dst:8 a:8 b:8
2810 *
2811 * Place the bitwise AND of A and B into DST.
2812 */
2813 VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
2814 {
2815 ARGS2 (x, y);
2816 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2817 /* Compute bitwise AND without untagging */
2818 RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
2819 SYNC_IP ();
2820 RETURN (scm_logand (x, y));
2821 }
2822
2823 /* logior dst:8 a:8 b:8
2824 *
2825 * Place the bitwise inclusive OR of A with B in DST.
2826 */
2827 VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
2828 {
2829 ARGS2 (x, y);
2830 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2831 /* Compute bitwise OR without untagging */
2832 RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
2833 SYNC_IP ();
2834 RETURN (scm_logior (x, y));
2835 }
2836
2837 /* logxor dst:8 a:8 b:8
2838 *
2839 * Place the bitwise exclusive OR of A with B in DST.
2840 */
2841 VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
2842 {
2843 ARGS2 (x, y);
2844 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2845 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
2846 SYNC_IP ();
2847 RETURN (scm_logxor (x, y));
2848 }
2849
2850 /* make-vector dst:8 length:8 init:8
2851 *
2852 * Make a vector and write it to DST. The vector will have space for
2853 * LENGTH slots. They will be filled with the value in slot INIT.
2854 */
2855 VM_DEFINE_OP (89, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
2856 {
2857 scm_t_uint8 dst, length, init;
2858
2859 SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
2860
2861 LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init)));
2862
2863 NEXT (1);
2864 }
2865
2866 /* constant-make-vector dst:8 length:8 init:8
2867 *
2868 * Make a short vector of known size and write it to DST. The vector
2869 * will have space for LENGTH slots, an immediate value. They will be
2870 * filled with the value in slot INIT.
2871 */
2872 VM_DEFINE_OP (90, constant_make_vector, "constant-make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
2873 {
2874 scm_t_uint8 dst, init;
2875 scm_t_int32 length, n;
2876 SCM val, vector;
2877
2878 SCM_UNPACK_RTL_8_8_8 (op, dst, length, init);
2879
2880 val = LOCAL_REF (init);
2881 vector = scm_words (scm_tc7_vector | (length << 8), length + 1);
2882 for (n = 0; n < length; n++)
2883 SCM_SIMPLE_VECTOR_SET (vector, n, val);
2884 LOCAL_SET (dst, vector);
2885 NEXT (1);
2886 }
2887
2888 /* vector-length dst:12 src:12
2889 *
2890 * Store the length of the vector in SRC in DST.
2891 */
2892 VM_DEFINE_OP (91, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
2893 {
2894 ARGS1 (vect);
2895 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
2896 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
2897 else
2898 {
2899 SYNC_IP ();
2900 RETURN (scm_vector_length (vect));
2901 }
2902 }
2903
2904 /* vector-ref dst:8 src:8 idx:8
2905 *
2906 * Fetch the item at position IDX in the vector in SRC, and store it
2907 * in DST.
2908 */
2909 VM_DEFINE_OP (92, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2910 {
2911 scm_t_signed_bits i = 0;
2912 ARGS2 (vect, idx);
2913 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2914 && SCM_I_INUMP (idx)
2915 && ((i = SCM_I_INUM (idx)) >= 0)
2916 && i < SCM_I_VECTOR_LENGTH (vect)))
2917 RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
2918 else
2919 {
2920 SYNC_IP ();
2921 RETURN (scm_vector_ref (vect, idx));
2922 }
2923 }
2924
2925 /* constant-vector-ref dst:8 src:8 idx:8
2926 *
2927 * Fill DST with the item IDX elements into the vector at SRC. Useful
2928 * for building data types using vectors.
2929 */
2930 VM_DEFINE_OP (93, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
2931 {
2932 scm_t_uint8 dst, src, idx;
2933 SCM v;
2934
2935 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
2936 v = LOCAL_REF (src);
2937 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v)
2938 && idx < SCM_I_VECTOR_LENGTH (v)))
2939 LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
2940 else
2941 LOCAL_SET (dst, scm_c_vector_ref (v, idx));
2942 NEXT (1);
2943 }
2944
2945 /* vector-set! dst:8 idx:8 src:8
2946 *
2947 * Store SRC into the vector DST at index IDX.
2948 */
2949 VM_DEFINE_OP (94, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
2950 {
2951 scm_t_uint8 dst, idx_var, src;
2952 SCM vect, idx, val;
2953 scm_t_signed_bits i = 0;
2954
2955 SCM_UNPACK_RTL_8_8_8 (op, dst, idx_var, src);
2956 vect = LOCAL_REF (dst);
2957 idx = LOCAL_REF (idx_var);
2958 val = LOCAL_REF (src);
2959
2960 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2961 && SCM_I_INUMP (idx)
2962 && ((i = SCM_I_INUM (idx)) >= 0)
2963 && i < SCM_I_VECTOR_LENGTH (vect)))
2964 SCM_I_VECTOR_WELTS (vect)[i] = val;
2965 else
2966 {
2967 SYNC_IP ();
2968 scm_vector_set_x (vect, idx, val);
2969 }
2970 NEXT (1);
2971 }
2972
2973 /* constant-vector-set! dst:8 idx:8 src:8
2974 *
2975 * Store SRC into the vector DST at index IDX. Here IDX is an
2976 * immediate value.
2977 */
2978 VM_DEFINE_OP (95, constant_vector_set, "constant-vector-set!", OP1 (U8_U8_U8_U8))
2979 {
2980 scm_t_uint8 dst, idx, src;
2981 SCM vect, val;
2982
2983 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
2984 vect = LOCAL_REF (dst);
2985 val = LOCAL_REF (src);
2986
2987 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2988 && idx < SCM_I_VECTOR_LENGTH (vect)))
2989 SCM_I_VECTOR_WELTS (vect)[idx] = val;
2990 else
2991 {
2992 SYNC_IP ();
2993 scm_vector_set_x (vect, scm_from_uint8 (idx), val);
2994 }
2995 NEXT (1);
2996 }
2997
2998
2999 \f
3000
3001 /*
3002 * Structs and GOOPS
3003 */
3004
3005 /* struct-vtable dst:12 src:12
3006 *
3007 * Store the vtable of SRC into DST.
3008 */
3009 VM_DEFINE_OP (96, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
3010 {
3011 ARGS1 (obj);
3012 VM_VALIDATE_STRUCT (obj, "struct_vtable");
3013 RETURN (SCM_STRUCT_VTABLE (obj));
3014 }
3015
3016 /* allocate-struct dst:8 vtable:8 nfields:8
3017 *
3018 * Allocate a new struct with VTABLE, and place it in DST. The struct
3019 * will be constructed with space for NFIELDS fields, which should
3020 * correspond to the field count of the VTABLE.
3021 */
3022 VM_DEFINE_OP (97, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
3023 {
3024 scm_t_uint8 dst, vtable, nfields;
3025 SCM ret;
3026
3027 SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
3028
3029 SYNC_IP ();
3030 ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
3031 LOCAL_SET (dst, ret);
3032
3033 NEXT (1);
3034 }
3035
3036 /* struct-ref dst:8 src:8 idx:8
3037 *
3038 * Fetch the item at slot IDX in the struct in SRC, and store it
3039 * in DST.
3040 */
3041 VM_DEFINE_OP (98, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3042 {
3043 ARGS2 (obj, pos);
3044
3045 if (SCM_LIKELY (SCM_STRUCTP (obj)
3046 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
3047 SCM_VTABLE_FLAG_SIMPLE)
3048 && SCM_I_INUMP (pos)))
3049 {
3050 SCM vtable;
3051 scm_t_bits index, len;
3052
3053 /* True, an inum is a signed value, but cast to unsigned it will
3054 certainly be more than the length, so we will fall through if
3055 index is negative. */
3056 index = SCM_I_INUM (pos);
3057 vtable = SCM_STRUCT_VTABLE (obj);
3058 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
3059
3060 if (SCM_LIKELY (index < len))
3061 {
3062 scm_t_bits *data = SCM_STRUCT_DATA (obj);
3063 RETURN (SCM_PACK (data[index]));
3064 }
3065 }
3066
3067 SYNC_IP ();
3068 RETURN (scm_struct_ref (obj, pos));
3069 }
3070
3071 /* struct-set! dst:8 idx:8 src:8
3072 *
3073 * Store SRC into the struct DST at slot IDX.
3074 */
3075 VM_DEFINE_OP (99, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
3076 {
3077 scm_t_uint8 dst, idx, src;
3078 SCM obj, pos, val;
3079
3080 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
3081 obj = LOCAL_REF (dst);
3082 pos = LOCAL_REF (idx);
3083 val = LOCAL_REF (src);
3084
3085 if (SCM_LIKELY (SCM_STRUCTP (obj)
3086 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
3087 SCM_VTABLE_FLAG_SIMPLE)
3088 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
3089 SCM_VTABLE_FLAG_SIMPLE_RW)
3090 && SCM_I_INUMP (pos)))
3091 {
3092 SCM vtable;
3093 scm_t_bits index, len;
3094
3095 /* See above regarding index being >= 0. */
3096 index = SCM_I_INUM (pos);
3097 vtable = SCM_STRUCT_VTABLE (obj);
3098 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
3099 if (SCM_LIKELY (index < len))
3100 {
3101 scm_t_bits *data = SCM_STRUCT_DATA (obj);
3102 data[index] = SCM_UNPACK (val);
3103 NEXT (1);
3104 }
3105 }
3106
3107 SYNC_IP ();
3108 scm_struct_set_x (obj, pos, val);
3109 NEXT (1);
3110 }
3111
3112 /* class-of dst:12 type:12
3113 *
3114 * Store the vtable of SRC into DST.
3115 */
3116 VM_DEFINE_OP (100, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
3117 {
3118 ARGS1 (obj);
3119 if (SCM_INSTANCEP (obj))
3120 RETURN (SCM_CLASS_OF (obj));
3121 SYNC_IP ();
3122 RETURN (scm_class_of (obj));
3123 }
3124
3125 /* slot-ref dst:8 src:8 idx:8
3126 *
3127 * Fetch the item at slot IDX in the struct in SRC, and store it in
3128 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3129 * index into the stack.
3130 */
3131 VM_DEFINE_OP (101, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3132 {
3133 scm_t_uint8 dst, src, idx;
3134 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
3135 LOCAL_SET (dst,
3136 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
3137 NEXT (1);
3138 }
3139
3140 /* slot-set! dst:8 idx:8 src:8
3141 *
3142 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3143 * IDX is an 8-bit immediate value, not an index into the stack.
3144 */
3145 VM_DEFINE_OP (102, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
3146 {
3147 scm_t_uint8 dst, idx, src;
3148 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
3149 SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
3150 NEXT (1);
3151 }
3152
3153
3154 \f
3155
3156 /*
3157 * Arrays, packed uniform arrays, and bytevectors.
3158 */
3159
3160 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3161 *
3162 * Load the contiguous typed array located at OFFSET 32-bit words away
3163 * from the instruction pointer, and store into DST. LEN is a byte
3164 * length. OFFSET is signed.
3165 */
3166 VM_DEFINE_OP (103, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
3167 {
3168 scm_t_uint8 dst, type, shape;
3169 scm_t_int32 offset;
3170 scm_t_uint32 len;
3171
3172 SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape);
3173 offset = ip[1];
3174 len = ip[2];
3175 SYNC_IP ();
3176 LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type),
3177 LOCAL_REF (shape),
3178 ip + offset, len));
3179 NEXT (3);
3180 }
3181
3182 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3183 *
3184 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3185 */
3186 VM_DEFINE_OP (104, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
3187 {
3188 scm_t_uint16 dst, type, fill, bounds;
3189 SCM_UNPACK_RTL_12_12 (op, dst, type);
3190 SCM_UNPACK_RTL_12_12 (ip[1], fill, bounds);
3191 SYNC_IP ();
3192 LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
3193 LOCAL_REF (bounds)));
3194 NEXT (2);
3195 }
3196
3197 /* bv-u8-ref dst:8 src:8 idx:8
3198 * bv-s8-ref dst:8 src:8 idx:8
3199 * bv-u16-ref dst:8 src:8 idx:8
3200 * bv-s16-ref dst:8 src:8 idx:8
3201 * bv-u32-ref dst:8 src:8 idx:8
3202 * bv-s32-ref dst:8 src:8 idx:8
3203 * bv-u64-ref dst:8 src:8 idx:8
3204 * bv-s64-ref dst:8 src:8 idx:8
3205 * bv-f32-ref dst:8 src:8 idx:8
3206 * bv-f64-ref dst:8 src:8 idx:8
3207 *
3208 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3209 * it in DST. All accesses use native endianness.
3210 */
3211 #define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3212 do { \
3213 scm_t_signed_bits i; \
3214 const scm_t_ ## type *int_ptr; \
3215 ARGS2 (bv, idx); \
3216 \
3217 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3218 i = SCM_I_INUM (idx); \
3219 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3220 \
3221 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3222 && (i >= 0) \
3223 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3224 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3225 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3226 else \
3227 { \
3228 SYNC_IP (); \
3229 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3230 } \
3231 } while (0)
3232
3233 #define BV_INT_REF(stem, type, size) \
3234 do { \
3235 scm_t_signed_bits i; \
3236 const scm_t_ ## type *int_ptr; \
3237 ARGS2 (bv, idx); \
3238 \
3239 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3240 i = SCM_I_INUM (idx); \
3241 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3242 \
3243 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3244 && (i >= 0) \
3245 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3246 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3247 { \
3248 scm_t_ ## type x = *int_ptr; \
3249 if (SCM_FIXABLE (x)) \
3250 RETURN (SCM_I_MAKINUM (x)); \
3251 else \
3252 { \
3253 SYNC_IP (); \
3254 RETURN (scm_from_ ## type (x)); \
3255 } \
3256 } \
3257 else \
3258 { \
3259 SYNC_IP (); \
3260 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3261 } \
3262 } while (0)
3263
3264 #define BV_FLOAT_REF(stem, fn_stem, type, size) \
3265 do { \
3266 scm_t_signed_bits i; \
3267 const type *float_ptr; \
3268 ARGS2 (bv, idx); \
3269 \
3270 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3271 i = SCM_I_INUM (idx); \
3272 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3273 \
3274 SYNC_IP (); \
3275 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3276 && (i >= 0) \
3277 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3278 && (ALIGNED_P (float_ptr, type)))) \
3279 RETURN (scm_from_double (*float_ptr)); \
3280 else \
3281 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3282 } while (0)
3283
3284 VM_DEFINE_OP (105, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3285 BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
3286
3287 VM_DEFINE_OP (106, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3288 BV_FIXABLE_INT_REF (s8, s8, int8, 1);
3289
3290 VM_DEFINE_OP (107, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3291 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
3292
3293 VM_DEFINE_OP (108, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3294 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
3295
3296 VM_DEFINE_OP (109, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3297 #if SIZEOF_VOID_P > 4
3298 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
3299 #else
3300 BV_INT_REF (u32, uint32, 4);
3301 #endif
3302
3303 VM_DEFINE_OP (110, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3304 #if SIZEOF_VOID_P > 4
3305 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
3306 #else
3307 BV_INT_REF (s32, int32, 4);
3308 #endif
3309
3310 VM_DEFINE_OP (111, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3311 BV_INT_REF (u64, uint64, 8);
3312
3313 VM_DEFINE_OP (112, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3314 BV_INT_REF (s64, int64, 8);
3315
3316 VM_DEFINE_OP (113, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3317 BV_FLOAT_REF (f32, ieee_single, float, 4);
3318
3319 VM_DEFINE_OP (114, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
3320 BV_FLOAT_REF (f64, ieee_double, double, 8);
3321
3322 /* bv-u8-set! dst:8 idx:8 src:8
3323 * bv-s8-set! dst:8 idx:8 src:8
3324 * bv-u16-set! dst:8 idx:8 src:8
3325 * bv-s16-set! dst:8 idx:8 src:8
3326 * bv-u32-set! dst:8 idx:8 src:8
3327 * bv-s32-set! dst:8 idx:8 src:8
3328 * bv-u64-set! dst:8 idx:8 src:8
3329 * bv-s64-set! dst:8 idx:8 src:8
3330 * bv-f32-set! dst:8 idx:8 src:8
3331 * bv-f64-set! dst:8 idx:8 src:8
3332 *
3333 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3334 * values are written using native endianness.
3335 */
3336 #define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3337 do { \
3338 scm_t_uint8 dst, idx, src; \
3339 scm_t_signed_bits i, j = 0; \
3340 SCM bv, scm_idx, val; \
3341 scm_t_ ## type *int_ptr; \
3342 \
3343 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3344 bv = LOCAL_REF (dst); \
3345 scm_idx = LOCAL_REF (idx); \
3346 val = LOCAL_REF (src); \
3347 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3348 i = SCM_I_INUM (scm_idx); \
3349 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3350 \
3351 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3352 && (i >= 0) \
3353 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3354 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3355 && (SCM_I_INUMP (val)) \
3356 && ((j = SCM_I_INUM (val)) >= min) \
3357 && (j <= max))) \
3358 *int_ptr = (scm_t_ ## type) j; \
3359 else \
3360 { \
3361 SYNC_IP (); \
3362 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3363 } \
3364 NEXT (1); \
3365 } while (0)
3366
3367 #define BV_INT_SET(stem, type, size) \
3368 do { \
3369 scm_t_uint8 dst, idx, src; \
3370 scm_t_signed_bits i; \
3371 SCM bv, scm_idx, val; \
3372 scm_t_ ## type *int_ptr; \
3373 \
3374 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3375 bv = LOCAL_REF (dst); \
3376 scm_idx = LOCAL_REF (idx); \
3377 val = LOCAL_REF (src); \
3378 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3379 i = SCM_I_INUM (scm_idx); \
3380 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3381 \
3382 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3383 && (i >= 0) \
3384 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3385 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3386 *int_ptr = scm_to_ ## type (val); \
3387 else \
3388 { \
3389 SYNC_IP (); \
3390 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3391 } \
3392 NEXT (1); \
3393 } while (0)
3394
3395 #define BV_FLOAT_SET(stem, fn_stem, type, size) \
3396 do { \
3397 scm_t_uint8 dst, idx, src; \
3398 scm_t_signed_bits i; \
3399 SCM bv, scm_idx, val; \
3400 type *float_ptr; \
3401 \
3402 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3403 bv = LOCAL_REF (dst); \
3404 scm_idx = LOCAL_REF (idx); \
3405 val = LOCAL_REF (src); \
3406 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3407 i = SCM_I_INUM (scm_idx); \
3408 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3409 \
3410 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3411 && (i >= 0) \
3412 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3413 && (ALIGNED_P (float_ptr, type)))) \
3414 *float_ptr = scm_to_double (val); \
3415 else \
3416 { \
3417 SYNC_IP (); \
3418 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3419 } \
3420 NEXT (1); \
3421 } while (0)
3422
3423 VM_DEFINE_OP (115, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
3424 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
3425
3426 VM_DEFINE_OP (116, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
3427 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
3428
3429 VM_DEFINE_OP (117, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
3430 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
3431
3432 VM_DEFINE_OP (118, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
3433 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
3434
3435 VM_DEFINE_OP (119, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
3436 #if SIZEOF_VOID_P > 4
3437 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
3438 #else
3439 BV_INT_SET (u32, uint32, 4);
3440 #endif
3441
3442 VM_DEFINE_OP (120, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
3443 #if SIZEOF_VOID_P > 4
3444 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
3445 #else
3446 BV_INT_SET (s32, int32, 4);
3447 #endif
3448
3449 VM_DEFINE_OP (121, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
3450 BV_INT_SET (u64, uint64, 8);
3451
3452 VM_DEFINE_OP (122, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
3453 BV_INT_SET (s64, int64, 8);
3454
3455 VM_DEFINE_OP (123, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
3456 BV_FLOAT_SET (f32, ieee_single, float, 4);
3457
3458 VM_DEFINE_OP (124, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
3459 BV_FLOAT_SET (f64, ieee_double, double, 8);
3460
3461 END_DISPATCH_SWITCH;
3462
3463 vm_error_bad_instruction:
3464 vm_error_bad_instruction (op);
3465
3466 abort (); /* never reached */
3467 }
3468
3469
3470 #undef ABORT_CONTINUATION_HOOK
3471 #undef ALIGNED_P
3472 #undef APPLY_HOOK
3473 #undef ARGS1
3474 #undef ARGS2
3475 #undef BEGIN_DISPATCH_SWITCH
3476 #undef BINARY_INTEGER_OP
3477 #undef BR_ARITHMETIC
3478 #undef BR_BINARY
3479 #undef BR_NARGS
3480 #undef BR_UNARY
3481 #undef BV_FIXABLE_INT_REF
3482 #undef BV_FIXABLE_INT_SET
3483 #undef BV_FLOAT_REF
3484 #undef BV_FLOAT_SET
3485 #undef BV_INT_REF
3486 #undef BV_INT_SET
3487 #undef CACHE_REGISTER
3488 #undef CHECK_OVERFLOW
3489 #undef END_DISPATCH_SWITCH
3490 #undef FREE_VARIABLE_REF
3491 #undef INIT
3492 #undef INUM_MAX
3493 #undef INUM_MIN
3494 #undef LOCAL_REF
3495 #undef LOCAL_SET
3496 #undef NEXT
3497 #undef NEXT_HOOK
3498 #undef NEXT_JUMP
3499 #undef POP_CONTINUATION_HOOK
3500 #undef PUSH_CONTINUATION_HOOK
3501 #undef RESTORE_CONTINUATION_HOOK
3502 #undef RETURN
3503 #undef RETURN_ONE_VALUE
3504 #undef RETURN_VALUE_LIST
3505 #undef RUN_HOOK
3506 #undef RUN_HOOK0
3507 #undef SYNC_ALL
3508 #undef SYNC_BEFORE_GC
3509 #undef SYNC_IP
3510 #undef SYNC_REGISTER
3511 #undef VARIABLE_BOUNDP
3512 #undef VARIABLE_REF
3513 #undef VARIABLE_SET
3514 #undef VM_CHECK_FREE_VARIABLE
3515 #undef VM_CHECK_OBJECT
3516 #undef VM_CHECK_UNDERFLOW
3517 #undef VM_DEFINE_OP
3518 #undef VM_INSTRUCTION_TO_LABEL
3519 #undef VM_USE_HOOKS
3520 #undef VM_VALIDATE_BYTEVECTOR
3521 #undef VM_VALIDATE_PAIR
3522 #undef VM_VALIDATE_STRUCT
3523
3524 /*
3525 (defun renumber-ops ()
3526 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3527 (interactive "")
3528 (save-excursion
3529 (let ((counter -1)) (goto-char (point-min))
3530 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3531 (replace-match
3532 (number-to-string (setq counter (1+ counter)))
3533 t t nil 1)))))
3534 (renumber-ops)
3535 */
3536 /*
3537 Local Variables:
3538 c-file-style: "gnu"
3539 End:
3540 */
Unnamed repository; edit this file 'description' to name the repository.