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