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