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