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