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