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