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