HCoop / bpt / guile.git / blob
? search:


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