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