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