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