RTL VM: fix multiple value returns.
[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
AW
666 ip = (scm_t_uint32 *) rtl_apply_code; \
667 goto op_apply; \
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
1090 /* return-values nvalues:24
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.
510ca126 1096 */
af95414f 1097 VM_DEFINE_OP (6, return_values, "return-values", OP1 (U8_U24))
510ca126 1098 {
af95414f
AW
1099 scm_t_uint32 nvalues;
1100 SCM *base = fp;
1101
1102 SCM_UNPACK_RTL_24 (op, nvalues);
1103
1104 RESET_FRAME (nvalues + 1);
1105
1106 VM_HANDLE_INTERRUPTS;
1107 ip = SCM_FRAME_RTL_MV_RETURN_ADDRESS (fp);
1108 fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
1109
1110 /* Clear stack frame. */
1111 base[-2] = SCM_BOOL_F;
1112 base[-3] = SCM_BOOL_F;
1113 base[-4] = SCM_BOOL_F;
1114
1115 POP_CONTINUATION_HOOK (base, nvalues);
1116
1117 NEXT (0);
510ca126
AW
1118 }
1119
1120
1121 \f
1122
1123 /*
1124 * Specialized call stubs
1125 */
1126
1127 /* subr-call ptr-idx:24
1128 *
1129 * Call a subr, passing all locals in this frame as arguments. Fetch
1130 * the foreign pointer from PTR-IDX, a free variable. Return from the
1131 * calling frame. This instruction is part of the trampolines
1132 * created in gsubr.c, and is not generated by the compiler.
1133 */
af95414f 1134 VM_DEFINE_OP (7, subr_call, "subr-call", OP1 (U8_U24))
510ca126
AW
1135 {
1136 scm_t_uint32 ptr_idx;
1137 SCM pointer, ret;
1138 SCM (*subr)();
1139
1140 SCM_UNPACK_RTL_24 (op, ptr_idx);
1141
7396d216 1142 pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
510ca126
AW
1143 subr = SCM_POINTER_VALUE (pointer);
1144
1145 VM_HANDLE_INTERRUPTS;
1146 SYNC_IP ();
1147
1148 switch (FRAME_LOCALS_COUNT ())
1149 {
1150 case 0:
1151 ret = subr ();
1152 break;
1153 case 1:
1154 ret = subr (fp[0]);
1155 break;
1156 case 2:
1157 ret = subr (fp[0], fp[1]);
1158 break;
1159 case 3:
1160 ret = subr (fp[0], fp[1], fp[2]);
1161 break;
1162 case 4:
1163 ret = subr (fp[0], fp[1], fp[2], fp[3]);
1164 break;
1165 case 5:
1166 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4]);
1167 break;
1168 case 6:
1169 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5]);
1170 break;
1171 case 7:
1172 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
1173 break;
1174 case 8:
1175 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
1176 break;
1177 case 9:
1178 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
1179 break;
1180 case 10:
1181 ret = subr (fp[0], fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
1182 break;
1183 default:
1184 abort ();
1185 }
1186
1187 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1188
1189 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1190 /* multiple values returned to continuation */
1191 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1192 else
1193 RETURN_ONE_VALUE (ret);
1194 }
1195
1196 /* foreign-call cif-idx:12 ptr-idx:12
1197 *
1198 * Call a foreign function. Fetch the CIF and foreign pointer from
1199 * CIF-IDX and PTR-IDX, both free variables. Return from the calling
1200 * frame. Arguments are taken from the stack. This instruction is
1201 * part of the trampolines created by the FFI, and is not generated by
1202 * the compiler.
1203 */
af95414f 1204 VM_DEFINE_OP (8, foreign_call, "foreign-call", OP1 (U8_U12_U12))
510ca126
AW
1205 {
1206 scm_t_uint16 cif_idx, ptr_idx;
7396d216 1207 SCM closure, cif, pointer, ret;
510ca126
AW
1208
1209 SCM_UNPACK_RTL_12_12 (op, cif_idx, ptr_idx);
1210
7396d216
AW
1211 closure = LOCAL_REF (0);
1212 cif = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
1213 pointer = SCM_RTL_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
510ca126
AW
1214
1215 SYNC_IP ();
1216 VM_HANDLE_INTERRUPTS;
1217
1218 // FIXME: separate args
1219 ret = scm_i_foreign_call (scm_cons (cif, pointer), fp);
1220
1221 // NULLSTACK_FOR_NONLOCAL_EXIT ();
1222
1223 if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1224 /* multiple values returned to continuation */
1225 RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
1226 else
1227 RETURN_ONE_VALUE (ret);
1228 }
1229
1230 /* continuation-call contregs:24
1231 *
1232 * Return to a continuation, nonlocally. The arguments to the
1233 * continuation are taken from the stack. CONTREGS is a free variable
1234 * containing the reified continuation. This instruction is part of
1235 * the implementation of undelimited continuations, and is not
1236 * generated by the compiler.
1237 */
af95414f 1238 VM_DEFINE_OP (9, continuation_call, "continuation-call", OP1 (U8_U24))
510ca126
AW
1239 {
1240 SCM contregs;
1241 scm_t_uint32 contregs_idx;
1242
1243 SCM_UNPACK_RTL_24 (op, contregs_idx);
1244
7396d216
AW
1245 contregs =
1246 SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
510ca126
AW
1247
1248 SYNC_IP ();
1249 scm_i_check_continuation (contregs);
1250 vm_return_to_continuation (scm_i_contregs_vm (contregs),
1251 scm_i_contregs_vm_cont (contregs),
1252 FRAME_LOCALS_COUNT (), fp);
1253 scm_i_reinstate_continuation (contregs);
1254
1255 /* no NEXT */
1256 abort ();
1257 }
1258
1259 /* compose-continuation cont:24
1260 *
1261 * Compose a partial continution with the current continuation. The
1262 * arguments to the continuation are taken from the stack. CONT is a
1263 * free variable containing the reified continuation. This
1264 * instruction is part of the implementation of partial continuations,
1265 * and is not generated by the compiler.
1266 */
af95414f 1267 VM_DEFINE_OP (10, compose_continuation, "compose-continuation", OP1 (U8_U24))
510ca126
AW
1268 {
1269 SCM vmcont;
1270 scm_t_uint32 cont_idx;
1271
1272 SCM_UNPACK_RTL_24 (op, cont_idx);
1273 vmcont = LOCAL_REF (cont_idx);
1274
1275 SYNC_IP ();
1276 VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
1277 vm_error_continuation_not_rewindable (vmcont));
1278 vm_reinstate_partial_continuation (vm, vmcont, FRAME_LOCALS_COUNT (), fp,
1279 &current_thread->dynstack,
1280 &registers);
1281 CACHE_REGISTER ();
1282 NEXT (0);
1283 }
1284
1285 /* apply _:24
1286 *
1287 * Tail-apply the procedure in local slot 0 to the rest of the
1288 * arguments. This instruction is part of the implementation of
1289 * `apply', and is not generated by the compiler.
1290 */
af95414f 1291 VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24))
510ca126
AW
1292 {
1293 int i, list_idx, list_len, nargs;
1294 SCM list;
1295
1296 VM_HANDLE_INTERRUPTS;
1297
1298 VM_ASSERT (FRAME_LOCALS_COUNT () >= 2, abort ());
1299 nargs = FRAME_LOCALS_COUNT ();
1300 list_idx = nargs - 1;
1301 list = LOCAL_REF (list_idx);
1302 list_len = scm_ilength (list);
1303
1304 VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
1305
1306 nargs = nargs - 2 + list_len;
1307 ALLOC_FRAME (nargs);
1308
1309 for (i = 0; i < list_idx; i++)
7396d216 1310 LOCAL_SET(i - 1, LOCAL_REF (i));
510ca126
AW
1311
1312 /* Null out these slots, just in case there are less than 2 elements
1313 in the list. */
7396d216
AW
1314 LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
1315 LOCAL_SET (list_idx, SCM_UNDEFINED);
510ca126
AW
1316
1317 for (i = 0; i < list_len; i++, list = SCM_CDR (list))
7396d216 1318 LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
510ca126
AW
1319
1320 APPLY_HOOK ();
1321
1322 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1323 goto apply;
1324
1325 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1326 NEXT (0);
1327 }
1328
1329 /* call/cc _:24
1330 *
1331 * Capture the current continuation, and tail-apply the procedure in
1332 * local slot 0 to it. This instruction is part of the implementation
1333 * of `call/cc', and is not generated by the compiler.
1334 */
af95414f 1335 VM_DEFINE_OP (12, call_cc, "call/cc", OP1 (U8_X24))
510ca126
AW
1336#if 0
1337 {
1338 SCM vm_cont, cont;
1339 scm_t_dynstack *dynstack;
1340
1341 VM_HANDLE_INTERRUPTS;
1342
1343 SYNC_IP ();
1344 dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
1345 vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1346 SCM_FRAME_DYNAMIC_LINK (fp),
1347 SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1348 SCM_FRAME_RETURN_ADDRESS (fp),
1349 SCM_FRAME_MV_RETURN_ADDRESS (fp),
1350 dynstack,
1351 0);
1352 cont = scm_i_make_continuation (&registers, vm, vm_cont);
1353
1354 fp[-1] = fp[0];
1355 fp[0] = cont;
7396d216 1356 RESET_FRAME (2);
510ca126
AW
1357
1358 APPLY_HOOK ();
1359
1360 if (SCM_UNLIKELY (!SCM_RTL_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
1361 goto apply;
1362
1363 ip = SCM_RTL_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
1364 NEXT (0);
1365 }
1366#else
1367 abort();
1368#endif
1369
510ca126
AW
1370
1371 \f
1372
1373 /*
1374 * Function prologues
1375 */
1376
1377 /* br-if-nargs-ne expected:24 _:8 offset:24
1378 * br-if-nargs-lt expected:24 _:8 offset:24
1379 * br-if-nargs-gt expected:24 _:8 offset:24
1380 *
1381 * If the number of actual arguments is not equal, less than, or greater
1382 * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
1383 * the current instruction pointer.
1384 */
af95414f 1385 VM_DEFINE_OP (13, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
510ca126
AW
1386 {
1387 BR_NARGS (!=);
1388 }
af95414f 1389 VM_DEFINE_OP (14, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
510ca126
AW
1390 {
1391 BR_NARGS (<);
1392 }
af95414f 1393 VM_DEFINE_OP (15, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
510ca126
AW
1394 {
1395 BR_NARGS (>);
1396 }
1397
1398 /* assert-nargs-ee expected:24
1399 * assert-nargs-ge expected:24
1400 * assert-nargs-le expected:24
1401 *
1402 * If the number of actual arguments is not ==, >=, or <= EXPECTED,
1403 * respectively, signal an error.
1404 */
af95414f 1405 VM_DEFINE_OP (16, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
510ca126
AW
1406 {
1407 scm_t_uint32 expected;
1408 SCM_UNPACK_RTL_24 (op, expected);
1409 VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
1410 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1411 NEXT (1);
1412 }
af95414f 1413 VM_DEFINE_OP (17, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
510ca126
AW
1414 {
1415 scm_t_uint32 expected;
1416 SCM_UNPACK_RTL_24 (op, expected);
1417 VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
1418 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1419 NEXT (1);
1420 }
af95414f 1421 VM_DEFINE_OP (18, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
510ca126
AW
1422 {
1423 scm_t_uint32 expected;
1424 SCM_UNPACK_RTL_24 (op, expected);
1425 VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
1426 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1427 NEXT (1);
1428 }
1429
af95414f 1430 /* alloc-frame nlocals:24
510ca126
AW
1431 *
1432 * Ensure that there is space on the stack for NLOCALS local variables,
1433 * setting them all to SCM_UNDEFINED, except those nargs values that
7396d216 1434 * were passed as arguments and procedure.
510ca126 1435 */
af95414f 1436 VM_DEFINE_OP (19, alloc_frame, "alloc-frame", OP1 (U8_U24))
510ca126
AW
1437 {
1438 scm_t_uint32 nlocals, nargs;
1439 SCM_UNPACK_RTL_24 (op, nlocals);
1440
1441 nargs = FRAME_LOCALS_COUNT ();
1442 ALLOC_FRAME (nlocals);
1443 while (nlocals-- > nargs)
1444 LOCAL_SET (nlocals, SCM_UNDEFINED);
1445
1446 NEXT (1);
1447 }
1448
af95414f
AW
1449 /* reset-frame nlocals:24
1450 *
1451 * Like alloc-frame, but doesn't check that the stack is big enough.
1452 * Used to reset the frame size to something less than the size that
1453 * was previously set via alloc-frame.
1454 */
1455 VM_DEFINE_OP (20, reset_frame, "reset-frame", OP1 (U8_U24))
1456 {
1457 scm_t_uint32 nlocals;
1458 SCM_UNPACK_RTL_24 (op, nlocals);
1459 RESET_FRAME (nlocals);
1460 NEXT (1);
1461 }
1462
510ca126
AW
1463 /* assert-nargs-ee/locals expected:12 nlocals:12
1464 *
1465 * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
1466 * number of locals reserved is EXPECTED + NLOCALS.
1467 */
af95414f 1468 VM_DEFINE_OP (21, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
510ca126
AW
1469 {
1470 scm_t_uint16 expected, nlocals;
1471 SCM_UNPACK_RTL_12_12 (op, expected, nlocals);
1472 VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
1473 vm_error_wrong_num_args (SCM_FRAME_PROGRAM (fp)));
1474 ALLOC_FRAME (expected + nlocals);
1475 while (nlocals--)
1476 LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
1477
1478 NEXT (1);
1479 }
1480
1481 /* bind-kwargs nreq:24 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
1482 * _:8 ntotal:24 kw-offset:32
1483 *
1484 * Find the last positional argument, and shuffle all the rest above
1485 * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
1486 * load the constant at KW-OFFSET words from the current IP, and use it
1487 * to bind keyword arguments. If HAS-REST, collect all shuffled
1488 * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
1489 * the arguments that we shuffled up.
1490 *
1491 * A macro-mega-instruction.
1492 */
af95414f 1493 VM_DEFINE_OP (22, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
510ca126
AW
1494 {
1495 scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
1496 scm_t_int32 kw_offset;
1497 scm_t_bits kw_bits;
1498 SCM kw;
1499 char allow_other_keys, has_rest;
1500
1501 SCM_UNPACK_RTL_24 (op, nreq);
1502 allow_other_keys = ip[1] & 0x1;
1503 has_rest = ip[1] & 0x2;
1504 SCM_UNPACK_RTL_24 (ip[1], nreq_and_opt);
1505 SCM_UNPACK_RTL_24 (ip[2], ntotal);
1506 kw_offset = ip[3];
1507 kw_bits = (scm_t_bits) (ip + kw_offset);
1508 VM_ASSERT (!(kw_bits & 0x7), abort());
1509 kw = SCM_PACK (kw_bits);
1510
1511 nargs = FRAME_LOCALS_COUNT ();
1512
1513 /* look in optionals for first keyword or last positional */
1514 /* starting after the last required positional arg */
1515 npositional = nreq;
1516 while (/* while we have args */
1517 npositional < nargs
1518 /* and we still have positionals to fill */
1519 && npositional < nreq_and_opt
1520 /* and we haven't reached a keyword yet */
1521 && !scm_is_keyword (LOCAL_REF (npositional)))
1522 /* bind this optional arg (by leaving it in place) */
1523 npositional++;
1524 nkw = nargs - npositional;
1525 /* shuffle non-positional arguments above ntotal */
1526 ALLOC_FRAME (ntotal + nkw);
1527 n = nkw;
1528 while (n--)
1529 LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n));
1530 /* and fill optionals & keyword args with SCM_UNDEFINED */
1531 n = npositional;
1532 while (n < ntotal)
1533 LOCAL_SET (n++, SCM_UNDEFINED);
1534
1535 VM_ASSERT (has_rest || (nkw % 2) == 0,
1536 vm_error_kwargs_length_not_even (SCM_FRAME_PROGRAM (fp)));
1537
1538 /* Now bind keywords, in the order given. */
1539 for (n = 0; n < nkw; n++)
1540 if (scm_is_keyword (LOCAL_REF (ntotal + n)))
1541 {
1542 SCM walk;
1543 for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
1544 if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n)))
1545 {
1546 SCM si = SCM_CDAR (walk);
1547 LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si),
1548 LOCAL_REF (ntotal + n + 1));
1549 break;
1550 }
1551 VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
28d5d253
MW
1552 vm_error_kwargs_unrecognized_keyword (SCM_FRAME_PROGRAM (fp),
1553 LOCAL_REF (ntotal + n)));
510ca126
AW
1554 n++;
1555 }
1556 else
28d5d253
MW
1557 VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
1558 LOCAL_REF (ntotal + n)));
510ca126
AW
1559
1560 if (has_rest)
1561 {
1562 SCM rest = SCM_EOL;
1563 n = nkw;
1564 while (n--)
1565 rest = scm_cons (LOCAL_REF (ntotal + n), rest);
1566 LOCAL_SET (nreq_and_opt, rest);
1567 }
1568
1569 RESET_FRAME (ntotal);
1570
1571 NEXT (4);
1572 }
1573
1574 /* bind-rest dst:24
1575 *
1576 * Collect any arguments at or above DST into a list, and store that
1577 * list at DST.
1578 */
af95414f 1579 VM_DEFINE_OP (23, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
510ca126
AW
1580 {
1581 scm_t_uint32 dst, nargs;
1582 SCM rest = SCM_EOL;
1583
1584 SCM_UNPACK_RTL_24 (op, dst);
1585 nargs = FRAME_LOCALS_COUNT ();
1586
1587 while (nargs-- > dst)
1588 {
1589 rest = scm_cons (LOCAL_REF (nargs), rest);
1590 LOCAL_SET (nargs, SCM_UNDEFINED);
1591 }
1592
1593 LOCAL_SET (dst, rest);
1594
1595 RESET_FRAME (dst + 1);
1596
1597 NEXT (1);
1598 }
1599
510ca126
AW
1600
1601 \f
1602
1603 /*
1604 * Branching instructions
1605 */
1606
1607 /* br offset:24
1608 *
1609 * Add OFFSET, a signed 24-bit number, to the current instruction
1610 * pointer.
1611 */
af95414f 1612 VM_DEFINE_OP (24, br, "br", OP1 (U8_L24))
510ca126
AW
1613 {
1614 scm_t_int32 offset = op;
1615 offset >>= 8; /* Sign-extending shift. */
1616 NEXT (offset);
1617 }
1618
1619 /* br-if-true test:24 invert:1 _:7 offset:24
1620 *
1621 * If the value in TEST is true for the purposes of Scheme, add
1622 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1623 */
af95414f 1624 VM_DEFINE_OP (25, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1625 {
1626 BR_UNARY (x, scm_is_true (x));
1627 }
1628
1629 /* br-if-null test:24 invert:1 _:7 offset:24
1630 *
1631 * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
1632 * signed 24-bit number, to the current instruction pointer.
1633 */
af95414f 1634 VM_DEFINE_OP (26, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1635 {
1636 BR_UNARY (x, scm_is_null (x));
1637 }
1638
1639 /* br-if-nil test:24 invert:1 _:7 offset:24
1640 *
1641 * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
1642 * number, to the current instruction pointer.
1643 */
af95414f 1644 VM_DEFINE_OP (27, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1645 {
1646 BR_UNARY (x, scm_is_lisp_false (x));
1647 }
1648
1649 /* br-if-pair test:24 invert:1 _:7 offset:24
1650 *
1651 * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
1652 * to the current instruction pointer.
1653 */
af95414f 1654 VM_DEFINE_OP (28, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1655 {
1656 BR_UNARY (x, scm_is_pair (x));
1657 }
1658
1659 /* br-if-struct test:24 invert:1 _:7 offset:24
1660 *
1661 * If the value in TEST is a struct, add OFFSET, a signed 24-bit
1662 * number, to the current instruction pointer.
1663 */
af95414f 1664 VM_DEFINE_OP (29, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1665 {
1666 BR_UNARY (x, SCM_STRUCTP (x));
1667 }
1668
1669 /* br-if-char test:24 invert:1 _:7 offset:24
1670 *
1671 * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
1672 * to the current instruction pointer.
1673 */
af95414f 1674 VM_DEFINE_OP (30, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
510ca126
AW
1675 {
1676 BR_UNARY (x, SCM_CHARP (x));
1677 }
1678
1679 /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
1680 *
1681 * If the value in TEST has the TC7 given in the second word, add
1682 * OFFSET, a signed 24-bit number, to the current instruction pointer.
1683 */
af95414f 1684 VM_DEFINE_OP (31, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
510ca126
AW
1685 {
1686 BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
1687 }
1688
1689 /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
1690 *
1691 * If the value in A is eq? to the value in B, add OFFSET, a signed
1692 * 24-bit number, to the current instruction pointer.
1693 */
af95414f 1694 VM_DEFINE_OP (32, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1695 {
1696 BR_BINARY (x, y, scm_is_eq (x, y));
1697 }
1698
1699 /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
1700 *
1701 * If the value in A is eqv? to the value in B, add OFFSET, a signed
1702 * 24-bit number, to the current instruction pointer.
1703 */
af95414f 1704 VM_DEFINE_OP (33, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1705 {
1706 BR_BINARY (x, y,
1707 scm_is_eq (x, y)
1708 || (SCM_NIMP (x) && SCM_NIMP (y)
1709 && scm_is_true (scm_eqv_p (x, y))));
1710 }
1711
af95414f 1712 // FIXME: remove, have compiler inline eqv test instead
510ca126
AW
1713 /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
1714 *
1715 * If the value in A is equal? to the value in B, add OFFSET, a signed
1716 * 24-bit number, to the current instruction pointer.
1717 */
1718 // FIXME: should sync_ip before calling out?
af95414f 1719 VM_DEFINE_OP (34, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1720 {
1721 BR_BINARY (x, y,
1722 scm_is_eq (x, y)
1723 || (SCM_NIMP (x) && SCM_NIMP (y)
1724 && scm_is_true (scm_equal_p (x, y))));
1725 }
1726
af95414f 1727 /* br-if-= a:12 b:12 invert:1 _:7 offset:24
510ca126
AW
1728 *
1729 * If the value in A is = to the value in B, add OFFSET, a signed
1730 * 24-bit number, to the current instruction pointer.
1731 */
af95414f 1732 VM_DEFINE_OP (35, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1733 {
1734 BR_ARITHMETIC (==, scm_num_eq_p);
1735 }
1736
1737 /* br-if-< a:12 b:12 _:8 offset:24
1738 *
1739 * If the value in A is < to the value in B, add OFFSET, a signed
1740 * 24-bit number, to the current instruction pointer.
1741 */
af95414f 1742 VM_DEFINE_OP (36, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1743 {
1744 BR_ARITHMETIC (<, scm_less_p);
1745 }
1746
1747 /* br-if-<= a:12 b:12 _:8 offset:24
1748 *
1749 * If the value in A is <= to the value in B, add OFFSET, a signed
1750 * 24-bit number, to the current instruction pointer.
1751 */
af95414f 1752 VM_DEFINE_OP (37, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
510ca126
AW
1753 {
1754 BR_ARITHMETIC (<=, scm_leq_p);
1755 }
1756
510ca126
AW
1757
1758 \f
1759
1760 /*
1761 * Lexical binding instructions
1762 */
1763
1764 /* mov dst:12 src:12
1765 *
1766 * Copy a value from one local slot to another.
1767 */
af95414f 1768 VM_DEFINE_OP (38, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
1769 {
1770 scm_t_uint16 dst;
1771 scm_t_uint16 src;
1772
1773 SCM_UNPACK_RTL_12_12 (op, dst, src);
1774 LOCAL_SET (dst, LOCAL_REF (src));
1775
1776 NEXT (1);
1777 }
1778
1779 /* long-mov dst:24 _:8 src:24
1780 *
1781 * Copy a value from one local slot to another.
1782 */
af95414f 1783 VM_DEFINE_OP (39, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
510ca126
AW
1784 {
1785 scm_t_uint32 dst;
1786 scm_t_uint32 src;
1787
1788 SCM_UNPACK_RTL_24 (op, dst);
1789 SCM_UNPACK_RTL_24 (ip[1], src);
1790 LOCAL_SET (dst, LOCAL_REF (src));
1791
1792 NEXT (2);
1793 }
1794
1795 /* box dst:12 src:12
1796 *
1797 * Create a new variable holding SRC, and place it in DST.
1798 */
af95414f 1799 VM_DEFINE_OP (40, box, "box", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
1800 {
1801 scm_t_uint16 dst, src;
1802 SCM_UNPACK_RTL_12_12 (op, dst, src);
1803 LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src))));
1804 NEXT (1);
1805 }
1806
510ca126
AW
1807 /* box-ref dst:12 src:12
1808 *
1809 * Unpack the variable at SRC into DST, asserting that the variable is
1810 * actually bound.
1811 */
af95414f 1812 VM_DEFINE_OP (41, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
1813 {
1814 scm_t_uint16 dst, src;
1815 SCM var;
1816 SCM_UNPACK_RTL_12_12 (op, dst, src);
1817 var = LOCAL_REF (src);
1818 VM_ASSERT (SCM_VARIABLEP (var), abort ());
af95414f
AW
1819 VM_ASSERT (VARIABLE_BOUNDP (var),
1820 vm_error_unbound (SCM_FRAME_PROGRAM (fp), var));
510ca126
AW
1821 LOCAL_SET (dst, VARIABLE_REF (var));
1822 NEXT (1);
1823 }
1824
1825 /* box-set! dst:12 src:12
1826 *
1827 * Set the contents of the variable at DST to SET.
1828 */
af95414f 1829 VM_DEFINE_OP (42, box_set, "box-set!", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
1830 {
1831 scm_t_uint16 dst, src;
1832 SCM var;
1833 SCM_UNPACK_RTL_12_12 (op, dst, src);
1834 var = LOCAL_REF (dst);
1835 VM_ASSERT (SCM_VARIABLEP (var), abort ());
1836 VARIABLE_SET (var, LOCAL_REF (src));
1837 NEXT (1);
1838 }
1839
7396d216 1840 /* make-closure dst:24 offset:32 _:8 nfree:24
510ca126
AW
1841 *
1842 * Make a new closure, and write it to DST. The code for the closure
1843 * will be found at OFFSET words from the current IP. OFFSET is a
7396d216
AW
1844 * signed 32-bit integer. Space for NFREE free variables will be
1845 * allocated.
510ca126 1846 */
af95414f 1847 VM_DEFINE_OP (43, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
510ca126
AW
1848 {
1849 scm_t_uint32 dst, nfree, n;
1850 scm_t_int32 offset;
1851 SCM closure;
1852
1853 SCM_UNPACK_RTL_24 (op, dst);
1854 offset = ip[1];
1855 SCM_UNPACK_RTL_24 (ip[2], nfree);
1856
1857 // FIXME: Assert range of nfree?
1858 closure = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2);
1859 SCM_SET_CELL_WORD_1 (closure, ip + offset);
7396d216 1860 // FIXME: Elide these initializations?
510ca126 1861 for (n = 0; n < nfree; n++)
7396d216 1862 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
510ca126 1863 LOCAL_SET (dst, closure);
7396d216 1864 NEXT (3);
510ca126
AW
1865 }
1866
7396d216 1867 /* free-ref dst:12 src:12 _:8 idx:24
510ca126 1868 *
7396d216 1869 * Load free variable IDX from the closure SRC into local slot DST.
510ca126 1870 */
af95414f 1871 VM_DEFINE_OP (44, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
510ca126 1872 {
7396d216
AW
1873 scm_t_uint16 dst, src;
1874 scm_t_uint32 idx;
1875 SCM_UNPACK_RTL_12_12 (op, dst, src);
1876 SCM_UNPACK_RTL_24 (ip[1], idx);
1877 /* CHECK_FREE_VARIABLE (src); */
1878 LOCAL_SET (dst, SCM_RTL_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
1879 NEXT (2);
1880 }
510ca126 1881
7396d216
AW
1882 /* free-set! dst:12 src:12 _8 idx:24
1883 *
1884 * Set free variable IDX from the closure DST to SRC.
1885 */
af95414f 1886 VM_DEFINE_OP (45, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
7396d216
AW
1887 {
1888 scm_t_uint16 dst, src;
1889 scm_t_uint32 idx;
1890 SCM_UNPACK_RTL_12_12 (op, dst, src);
1891 SCM_UNPACK_RTL_24 (ip[1], idx);
1892 /* CHECK_FREE_VARIABLE (src); */
1893 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
1894 NEXT (2);
510ca126
AW
1895 }
1896
1897
1898 \f
1899
1900 /*
1901 * Immediates and statically allocated non-immediates
1902 */
1903
1904 /* make-short-immediate dst:8 low-bits:16
1905 *
1906 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1907 * 0.
1908 */
af95414f 1909 VM_DEFINE_OP (46, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
510ca126
AW
1910 {
1911 scm_t_uint8 dst;
1912 scm_t_bits val;
1913
1914 SCM_UNPACK_RTL_8_16 (op, dst, val);
1915 LOCAL_SET (dst, SCM_PACK (val));
1916 NEXT (1);
1917 }
1918
1919 /* make-long-immediate dst:24 low-bits:32
1920 *
1921 * Make an immediate whose low bits are LOW-BITS, and whose top bits are
1922 * 0.
1923 */
af95414f 1924 VM_DEFINE_OP (47, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
510ca126
AW
1925 {
1926 scm_t_uint8 dst;
1927 scm_t_bits val;
1928
1929 SCM_UNPACK_RTL_24 (op, dst);
1930 val = ip[1];
1931 LOCAL_SET (dst, SCM_PACK (val));
1932 NEXT (2);
1933 }
1934
1935 /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
1936 *
1937 * Make an immediate with HIGH-BITS and LOW-BITS.
1938 */
af95414f 1939 VM_DEFINE_OP (48, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
510ca126
AW
1940 {
1941 scm_t_uint8 dst;
1942 scm_t_bits val;
1943
1944 SCM_UNPACK_RTL_24 (op, dst);
1945#if SIZEOF_SCM_T_BITS > 4
1946 val = ip[1];
1947 val <<= 32;
1948 val |= ip[2];
1949#else
1950 ASSERT (ip[1] == 0);
1951 val = ip[2];
1952#endif
1953 LOCAL_SET (dst, SCM_PACK (val));
1954 NEXT (3);
1955 }
1956
1957 /* make-non-immediate dst:24 offset:32
1958 *
1959 * Load a pointer to statically allocated memory into DST. The
1960 * object's memory is will be found OFFSET 32-bit words away from the
1961 * current instruction pointer. OFFSET is a signed value. The
1962 * intention here is that the compiler would produce an object file
1963 * containing the words of a non-immediate object, and this
1964 * instruction creates a pointer to that memory, effectively
1965 * resurrecting that object.
1966 *
1967 * Whether the object is mutable or immutable depends on where it was
1968 * allocated by the compiler, and loaded by the loader.
1969 */
af95414f 1970 VM_DEFINE_OP (49, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
510ca126
AW
1971 {
1972 scm_t_uint32 dst;
1973 scm_t_int32 offset;
1974 scm_t_uint32* loc;
1975 scm_t_bits unpacked;
1976
1977 SCM_UNPACK_RTL_24 (op, dst);
1978 offset = ip[1];
1979 loc = ip + offset;
1980 unpacked = (scm_t_bits) loc;
1981
1982 VM_ASSERT (!(unpacked & 0x7), abort());
1983
1984 LOCAL_SET (dst, SCM_PACK (unpacked));
1985
1986 NEXT (2);
1987 }
1988
1989 /* static-ref dst:24 offset:32
1990 *
1991 * Load a SCM value into DST. The SCM value will be fetched from
1992 * memory, OFFSET 32-bit words away from the current instruction
1993 * pointer. OFFSET is a signed value.
1994 *
1995 * The intention is for this instruction to be used to load constants
1996 * that the compiler is unable to statically allocate, like symbols.
1997 * These values would be initialized when the object file loads.
1998 */
af95414f 1999 VM_DEFINE_OP (50, static_ref, "static-ref", OP2 (U8_U24, S32))
510ca126
AW
2000 {
2001 scm_t_uint32 dst;
2002 scm_t_int32 offset;
2003 scm_t_uint32* loc;
2004 scm_t_uintptr loc_bits;
2005
2006 SCM_UNPACK_RTL_24 (op, dst);
2007 offset = ip[1];
2008 loc = ip + offset;
2009 loc_bits = (scm_t_uintptr) loc;
2010 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2011
2012 LOCAL_SET (dst, *((SCM *) loc_bits));
2013
2014 NEXT (2);
2015 }
2016
2017 /* static-set! src:24 offset:32
2018 *
2019 * Store a SCM value into memory, OFFSET 32-bit words away from the
2020 * current instruction pointer. OFFSET is a signed value.
2021 */
af95414f 2022 VM_DEFINE_OP (51, static_set, "static-set!", OP2 (U8_U24, LO32))
510ca126
AW
2023 {
2024 scm_t_uint32 src;
2025 scm_t_int32 offset;
2026 scm_t_uint32* loc;
2027
2028 SCM_UNPACK_RTL_24 (op, src);
2029 offset = ip[1];
2030 loc = ip + offset;
2031 VM_ASSERT (ALIGNED_P (loc, SCM), abort());
2032
2033 *((SCM *) loc) = LOCAL_REF (src);
2034
2035 NEXT (2);
2036 }
2037
2038 /* link-procedure! src:24 offset:32
2039 *
2040 * Set the code pointer of the procedure in SRC to point OFFSET 32-bit
2041 * words away from the current instruction pointer. OFFSET is a
2042 * signed value.
2043 */
af95414f 2044 VM_DEFINE_OP (52, link_procedure, "link-procedure!", OP2 (U8_U24, L32))
510ca126
AW
2045 {
2046 scm_t_uint32 src;
2047 scm_t_int32 offset;
2048 scm_t_uint32* loc;
2049
2050 SCM_UNPACK_RTL_24 (op, src);
2051 offset = ip[1];
2052 loc = ip + offset;
2053
2054 SCM_SET_CELL_WORD_1 (LOCAL_REF (src), (scm_t_bits) loc);
2055
2056 NEXT (2);
2057 }
2058
2059 \f
2060
2061 /*
2062 * Mutable top-level bindings
2063 */
2064
2065 /* There are three slightly different ways to resolve toplevel
2066 variables.
2067
2068 1. A toplevel reference outside of a function. These need to be
2069 looked up when the expression is evaluated -- no later, and no
2070 before. They are looked up relative to the module that is
2071 current when the expression is evaluated. For example:
2072
2073 (if (foo) a b)
2074
2075 The "resolve" instruction resolves the variable (box), and then
2076 access is via box-ref or box-set!.
2077
2078 2. A toplevel reference inside a function. These are looked up
2079 relative to the module that was current when the function was
2080 defined. Unlike code at the toplevel, which is usually run only
2081 once, these bindings benefit from memoized lookup, in which the
2082 variable resulting from the lookup is cached in the function.
2083
2084 (lambda () (if (foo) a b))
2085
af95414f
AW
2086 The toplevel-box instruction is equivalent to "resolve", but
2087 caches the resulting variable in statically allocated memory.
510ca126
AW
2088
2089 3. A reference to an identifier with respect to a particular
2090 module. This can happen for primitive references, and
af95414f
AW
2091 references residualized by macro expansions. These can always
2092 be cached. Use module-box for these.
510ca126
AW
2093 */
2094
2095 /* current-module dst:24
2096 *
2097 * Store the current module in DST.
2098 */
af95414f 2099 VM_DEFINE_OP (53, current_module, "current-module", OP1 (U8_U24) | OP_DST)
510ca126
AW
2100 {
2101 scm_t_uint32 dst;
2102
2103 SCM_UNPACK_RTL_24 (op, dst);
2104
2105 SYNC_IP ();
2106 LOCAL_SET (dst, scm_current_module ());
2107
2108 NEXT (1);
2109 }
2110
af95414f 2111 /* resolve dst:24 bound?:1 _:7 sym:24
510ca126 2112 *
af95414f
AW
2113 * Resolve SYM in the current module, and place the resulting variable
2114 * in DST.
510ca126 2115 */
af95414f 2116 VM_DEFINE_OP (54, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
510ca126 2117 {
af95414f
AW
2118 scm_t_uint32 dst;
2119 scm_t_uint32 sym;
2120 SCM var;
510ca126 2121
af95414f
AW
2122 SCM_UNPACK_RTL_24 (op, dst);
2123 SCM_UNPACK_RTL_24 (ip[1], sym);
510ca126
AW
2124
2125 SYNC_IP ();
af95414f
AW
2126 var = scm_lookup (LOCAL_REF (sym));
2127 if (ip[1] & 0x1)
2128 VM_ASSERT (VARIABLE_BOUNDP (var),
2129 vm_error_unbound (fp[-1], LOCAL_REF (sym)));
2130 LOCAL_SET (dst, var);
510ca126 2131
af95414f 2132 NEXT (2);
510ca126
AW
2133 }
2134
2135 /* define sym:12 val:12
2136 *
2137 * Look up a binding for SYM in the current module, creating it if
2138 * necessary. Set its value to VAL.
2139 */
af95414f 2140 VM_DEFINE_OP (55, define, "define", OP1 (U8_U12_U12))
510ca126
AW
2141 {
2142 scm_t_uint16 sym, val;
2143 SCM_UNPACK_RTL_12_12 (op, sym, val);
2144 SYNC_IP ();
2145 scm_define (LOCAL_REF (sym), LOCAL_REF (val));
2146 NEXT (1);
2147 }
2148
af95414f 2149 /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
510ca126
AW
2150 *
2151 * Load a SCM value. The SCM value will be fetched from memory,
2152 * VAR-OFFSET 32-bit words away from the current instruction pointer.
af95414f 2153 * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
510ca126
AW
2154 * static-ref.
2155 *
af95414f
AW
2156 * Then, if the loaded value is a variable, it is placed in DST, and control
2157 * flow continues.
510ca126
AW
2158 *
2159 * Otherwise, we have to resolve the variable. In that case we load
2160 * the module from MOD-OFFSET, just as we loaded the variable.
2161 * Usually the module gets set when the closure is created. The name
2162 * is an offset to a symbol.
2163 *
af95414f
AW
2164 * We use the module and the symbol to resolve the variable, placing it in
2165 * DST, and caching the resolved variable so that we will hit the cache next
2166 * time.
510ca126 2167 */
af95414f 2168 VM_DEFINE_OP (56, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
510ca126
AW
2169 {
2170 scm_t_uint32 dst;
2171 scm_t_int32 var_offset;
2172 scm_t_uint32* var_loc_u32;
2173 SCM *var_loc;
2174 SCM var;
2175
2176 SCM_UNPACK_RTL_24 (op, dst);
2177 var_offset = ip[1];
2178 var_loc_u32 = ip + var_offset;
2179 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2180 var_loc = (SCM *) var_loc_u32;
2181 var = *var_loc;
2182
2183 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2184 {
2185 SCM mod, sym;
2186 scm_t_int32 mod_offset = ip[2]; /* signed */
2187 scm_t_int32 sym_offset = ip[3]; /* signed */
2188 scm_t_uint32 *mod_loc = ip + mod_offset;
2189 scm_t_uint32 *sym_loc = ip + sym_offset;
2190
2191 SYNC_IP ();
2192
2193 VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
2194 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2195
2196 mod = *((SCM *) mod_loc);
2197 sym = *((SCM *) sym_loc);
2198
2199 var = scm_module_lookup (mod, sym);
af95414f
AW
2200 if (ip[4] & 0x1)
2201 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
510ca126
AW
2202
2203 *var_loc = var;
2204 }
2205
af95414f
AW
2206 LOCAL_SET (dst, var);
2207 NEXT (5);
510ca126
AW
2208 }
2209
af95414f 2210 /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
510ca126 2211 *
af95414f 2212 * Like toplevel-box, except MOD-OFFSET points at the name of a module
510ca126
AW
2213 * instead of the module itself.
2214 */
af95414f 2215 VM_DEFINE_OP (57, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
510ca126
AW
2216 {
2217 scm_t_uint32 dst;
2218 scm_t_int32 var_offset;
2219 scm_t_uint32* var_loc_u32;
2220 SCM *var_loc;
2221 SCM var;
2222
2223 SCM_UNPACK_RTL_24 (op, dst);
2224 var_offset = ip[1];
2225 var_loc_u32 = ip + var_offset;
2226 VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
2227 var_loc = (SCM *) var_loc_u32;
2228 var = *var_loc;
2229
2230 if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
2231 {
2232 SCM modname, sym;
2233 scm_t_int32 modname_offset = ip[2]; /* signed */
2234 scm_t_int32 sym_offset = ip[3]; /* signed */
2235 scm_t_uint32 *modname_words = ip + modname_offset;
2236 scm_t_uint32 *sym_loc = ip + sym_offset;
2237
2238 SYNC_IP ();
2239
2240 VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
2241 VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
2242
2243 modname = SCM_PACK ((scm_t_bits) modname_words);
2244 sym = *((SCM *) sym_loc);
2245
2246 if (scm_is_true (SCM_CAR (modname)))
2247 var = scm_public_lookup (SCM_CDR (modname), sym);
2248 else
2249 var = scm_private_lookup (SCM_CDR (modname), sym);
2250
af95414f
AW
2251 if (ip[4] & 0x1)
2252 VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (fp[-1], sym));
510ca126
AW
2253
2254 *var_loc = var;
2255 }
2256
af95414f
AW
2257 LOCAL_SET (dst, var);
2258 NEXT (5);
510ca126
AW
2259 }
2260
2261 \f
2262
2263 /*
2264 * The dynamic environment
2265 */
2266
2267 /* prompt tag:24 flags:8 handler-offset:24
2268 *
2269 * Push a new prompt on the dynamic stack, with a tag from TAG and a
2270 * handler at HANDLER-OFFSET words from the current IP. The handler
2271 * will expect a multiple-value return.
2272 */
af95414f 2273 VM_DEFINE_OP (58, prompt, "prompt", OP2 (U8_U24, U8_L24))
510ca126
AW
2274#if 0
2275 {
2276 scm_t_uint32 tag;
2277 scm_t_int32 offset;
2278 scm_t_uint8 escape_only_p;
2279 scm_t_dynstack_prompt_flags flags;
2280
2281 SCM_UNPACK_RTL_24 (op, tag);
2282 escape_only_p = ip[1] & 0xff;
2283 offset = ip[1];
2284 offset >>= 8; /* Sign extension */
2285
2286 /* Push the prompt onto the dynamic stack. */
2287 flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
2288 scm_dynstack_push_prompt (&current_thread->dynstack, flags,
2289 LOCAL_REF (tag),
2290 fp, vp->sp, ip + offset, &registers);
2291 NEXT (2);
2292 }
2293#else
2294 abort();
2295#endif
2296
2297 /* wind winder:12 unwinder:12
2298 *
2299 * Push wind and unwind procedures onto the dynamic stack. Note that
2300 * neither are actually called; the compiler should emit calls to wind
2301 * and unwind for the normal dynamic-wind control flow. Also note that
2302 * the compiler should have inserted checks that they wind and unwind
2303 * procs are thunks, if it could not prove that to be the case.
2304 */
af95414f 2305 VM_DEFINE_OP (59, wind, "wind", OP1 (U8_U12_U12))
510ca126
AW
2306 {
2307 scm_t_uint16 winder, unwinder;
2308 SCM_UNPACK_RTL_12_12 (op, winder, unwinder);
2309 scm_dynstack_push_dynwind (&current_thread->dynstack,
2310 LOCAL_REF (winder), LOCAL_REF (unwinder));
2311 NEXT (1);
2312 }
2313
af95414f 2314 /* abort tag:24 _:8 proc:24
510ca126 2315 *
b2171312 2316 * Return a number of values to a prompt handler. The values are
af95414f 2317 * expected in a frame pushed on at PROC.
510ca126 2318 */
af95414f 2319 VM_DEFINE_OP (60, abort, "abort", OP2 (U8_U24, X8_U24))
510ca126
AW
2320#if 0
2321 {
b2171312
AW
2322 scm_t_uint32 tag, from, nvalues;
2323 SCM *base;
510ca126
AW
2324
2325 SCM_UNPACK_RTL_24 (op, tag);
b2171312
AW
2326 SCM_UNPACK_RTL_24 (ip[1], from);
2327 base = (fp - 1) + from + 3;
2328 nvalues = FRAME_LOCALS_COUNT () - from - 3;
510ca126
AW
2329
2330 SYNC_IP ();
b2171312 2331 vm_abort (vm, LOCAL_REF (tag), base, nvalues, &registers);
510ca126
AW
2332
2333 /* vm_abort should not return */
2334 abort ();
2335 }
2336#else
2337 abort();
2338#endif
2339
2340 /* unwind _:24
2341 *
2342 * A normal exit from the dynamic extent of an expression. Pop the top
2343 * entry off of the dynamic stack.
2344 */
af95414f 2345 VM_DEFINE_OP (61, unwind, "unwind", OP1 (U8_X24))
510ca126
AW
2346 {
2347 scm_dynstack_pop (&current_thread->dynstack);
2348 NEXT (1);
2349 }
2350
98eaef1b 2351 /* push-fluid fluid:12 value:12
510ca126
AW
2352 *
2353 * Dynamically bind N fluids to values. The fluids are expected to be
2354 * allocated in a continguous range on the stack, starting from
2355 * FLUID-BASE. The values do not have this restriction.
2356 */
af95414f 2357 VM_DEFINE_OP (62, push_fluid, "push-fluid", OP1 (U8_U12_U12))
510ca126 2358 {
98eaef1b 2359 scm_t_uint32 fluid, value;
510ca126 2360
98eaef1b 2361 SCM_UNPACK_RTL_12_12 (op, fluid, value);
510ca126 2362
98eaef1b
AW
2363 scm_dynstack_push_fluid (&current_thread->dynstack,
2364 fp[fluid], fp[value],
2365 current_thread->dynamic_state);
2366 NEXT (1);
510ca126 2367 }
510ca126 2368
98eaef1b 2369 /* pop-fluid _:24
510ca126
AW
2370 *
2371 * Leave the dynamic extent of a with-fluids expression, restoring the
2372 * fluids to their previous values.
2373 */
af95414f 2374 VM_DEFINE_OP (63, pop_fluid, "pop-fluid", OP1 (U8_X24))
510ca126
AW
2375 {
2376 /* This function must not allocate. */
98eaef1b
AW
2377 scm_dynstack_unwind_fluid (&current_thread->dynstack,
2378 current_thread->dynamic_state);
510ca126
AW
2379 NEXT (1);
2380 }
2381
2382 /* fluid-ref dst:12 src:12
2383 *
2384 * Reference the fluid in SRC, and place the value in DST.
2385 */
af95414f 2386 VM_DEFINE_OP (64, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2387 {
2388 scm_t_uint16 dst, src;
2389 size_t num;
2390 SCM fluid, fluids;
2391
2392 SCM_UNPACK_RTL_12_12 (op, dst, src);
2393 fluid = LOCAL_REF (src);
2394 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2395 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2396 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2397 {
2398 /* Punt dynstate expansion and error handling to the C proc. */
2399 SYNC_IP ();
2400 LOCAL_SET (dst, scm_fluid_ref (fluid));
2401 }
2402 else
2403 {
2404 SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
2405 if (scm_is_eq (val, SCM_UNDEFINED))
2406 val = SCM_I_FLUID_DEFAULT (fluid);
2407 VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
2408 vm_error_unbound_fluid (program, fluid));
2409 LOCAL_SET (dst, val);
2410 }
2411
2412 NEXT (1);
2413 }
2414
2415 /* fluid-set fluid:12 val:12
2416 *
2417 * Set the value of the fluid in DST to the value in SRC.
2418 */
af95414f 2419 VM_DEFINE_OP (65, fluid_set, "fluid-set", OP1 (U8_U12_U12))
510ca126
AW
2420 {
2421 scm_t_uint16 a, b;
2422 size_t num;
2423 SCM fluid, fluids;
2424
2425 SCM_UNPACK_RTL_12_12 (op, a, b);
2426 fluid = LOCAL_REF (a);
2427 fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
2428 if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
2429 || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
2430 {
2431 /* Punt dynstate expansion and error handling to the C proc. */
2432 SYNC_IP ();
2433 scm_fluid_set_x (fluid, LOCAL_REF (b));
2434 }
2435 else
2436 SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b));
2437
2438 NEXT (1);
2439 }
2440
2441
2442 \f
2443
2444 /*
2445 * Strings, symbols, and keywords
2446 */
2447
2448 /* string-length dst:12 src:12
2449 *
2450 * Store the length of the string in SRC in DST.
2451 */
af95414f 2452 VM_DEFINE_OP (66, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2453 {
2454 ARGS1 (str);
2455 if (SCM_LIKELY (scm_is_string (str)))
2456 RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
2457 else
2458 {
2459 SYNC_IP ();
2460 RETURN (scm_string_length (str));
2461 }
2462 }
2463
2464 /* string-ref dst:8 src:8 idx:8
2465 *
2466 * Fetch the character at position IDX in the string in SRC, and store
2467 * it in DST.
2468 */
af95414f 2469 VM_DEFINE_OP (67, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2470 {
2471 scm_t_signed_bits i = 0;
2472 ARGS2 (str, idx);
2473 if (SCM_LIKELY (scm_is_string (str)
2474 && SCM_I_INUMP (idx)
2475 && ((i = SCM_I_INUM (idx)) >= 0)
2476 && i < scm_i_string_length (str)))
2477 RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
2478 else
2479 {
2480 SYNC_IP ();
2481 RETURN (scm_string_ref (str, idx));
2482 }
2483 }
2484
2485 /* No string-set! instruction, as there is no good fast path there. */
2486
2487 /* string-to-number dst:12 src:12
2488 *
2489 * Parse a string in SRC to a number, and store in DST.
2490 */
af95414f 2491 VM_DEFINE_OP (68, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2492 {
2493 scm_t_uint16 dst, src;
2494
2495 SCM_UNPACK_RTL_12_12 (op, dst, src);
2496 SYNC_IP ();
2497 LOCAL_SET (dst,
2498 scm_string_to_number (LOCAL_REF (src),
2499 SCM_UNDEFINED /* radix = 10 */));
2500 NEXT (1);
2501 }
2502
2503 /* string-to-symbol dst:12 src:12
2504 *
2505 * Parse a string in SRC to a symbol, and store in DST.
2506 */
af95414f 2507 VM_DEFINE_OP (69, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2508 {
2509 scm_t_uint16 dst, src;
2510
2511 SCM_UNPACK_RTL_12_12 (op, dst, src);
2512 SYNC_IP ();
2513 LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
2514 NEXT (1);
2515 }
2516
2517 /* symbol->keyword dst:12 src:12
2518 *
2519 * Make a keyword from the symbol in SRC, and store it in DST.
2520 */
af95414f 2521 VM_DEFINE_OP (70, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2522 {
2523 scm_t_uint16 dst, src;
2524 SCM_UNPACK_RTL_12_12 (op, dst, src);
2525 SYNC_IP ();
2526 LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
2527 NEXT (1);
2528 }
2529
2530 \f
2531
2532 /*
2533 * Pairs
2534 */
2535
2536 /* cons dst:8 car:8 cdr:8
2537 *
2538 * Cons CAR and CDR, and store the result in DST.
2539 */
af95414f 2540 VM_DEFINE_OP (71, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2541 {
2542 ARGS2 (x, y);
2543 RETURN (scm_cons (x, y));
2544 }
2545
2546 /* car dst:12 src:12
2547 *
2548 * Place the car of SRC in DST.
2549 */
af95414f 2550 VM_DEFINE_OP (72, car, "car", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2551 {
2552 ARGS1 (x);
2553 VM_VALIDATE_PAIR (x, "car");
2554 RETURN (SCM_CAR (x));
2555 }
2556
2557 /* cdr dst:12 src:12
2558 *
2559 * Place the cdr of SRC in DST.
2560 */
af95414f 2561 VM_DEFINE_OP (73, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2562 {
2563 ARGS1 (x);
2564 VM_VALIDATE_PAIR (x, "cdr");
2565 RETURN (SCM_CDR (x));
2566 }
2567
2568 /* set-car! pair:12 car:12
2569 *
2570 * Set the car of DST to SRC.
2571 */
af95414f 2572 VM_DEFINE_OP (74, set_car, "set-car!", OP1 (U8_U12_U12))
510ca126
AW
2573 {
2574 scm_t_uint16 a, b;
2575 SCM x, y;
2576 SCM_UNPACK_RTL_12_12 (op, a, b);
2577 x = LOCAL_REF (a);
2578 y = LOCAL_REF (b);
2579 VM_VALIDATE_PAIR (x, "set-car!");
2580 SCM_SETCAR (x, y);
2581 NEXT (1);
2582 }
2583
2584 /* set-cdr! pair:12 cdr:12
2585 *
2586 * Set the cdr of DST to SRC.
2587 */
af95414f 2588 VM_DEFINE_OP (75, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
510ca126
AW
2589 {
2590 scm_t_uint16 a, b;
2591 SCM x, y;
2592 SCM_UNPACK_RTL_12_12 (op, a, b);
2593 x = LOCAL_REF (a);
2594 y = LOCAL_REF (b);
2595 VM_VALIDATE_PAIR (x, "set-car!");
2596 SCM_SETCDR (x, y);
2597 NEXT (1);
2598 }
2599
2600
2601 \f
2602
2603 /*
2604 * Numeric operations
2605 */
2606
2607 /* add dst:8 a:8 b:8
2608 *
2609 * Add A to B, and place the result in DST.
2610 */
af95414f 2611 VM_DEFINE_OP (76, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2612 {
2613 BINARY_INTEGER_OP (+, scm_sum);
2614 }
2615
2616 /* add1 dst:12 src:12
2617 *
2618 * Add 1 to the value in SRC, and place the result in DST.
2619 */
af95414f 2620 VM_DEFINE_OP (77, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2621 {
2622 ARGS1 (x);
2623
d2295ba5
MW
2624 /* Check for overflow. We must avoid overflow in the signed
2625 addition below, even if X is not an inum. */
2626 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
510ca126
AW
2627 {
2628 SCM result;
2629
d2295ba5
MW
2630 /* Add 1 to the integer without untagging. */
2631 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
510ca126
AW
2632
2633 if (SCM_LIKELY (SCM_I_INUMP (result)))
2634 RETURN (result);
2635 }
2636
2637 SYNC_IP ();
2638 RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
2639 }
2640
2641 /* sub dst:8 a:8 b:8
2642 *
2643 * Subtract B from A, and place the result in DST.
2644 */
af95414f 2645 VM_DEFINE_OP (78, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2646 {
2647 BINARY_INTEGER_OP (-, scm_difference);
2648 }
2649
2650 /* sub1 dst:12 src:12
2651 *
2652 * Subtract 1 from SRC, and place the result in DST.
2653 */
af95414f 2654 VM_DEFINE_OP (79, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2655 {
2656 ARGS1 (x);
2657
d2295ba5
MW
2658 /* Check for overflow. We must avoid overflow in the signed
2659 subtraction below, even if X is not an inum. */
2660 if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
510ca126
AW
2661 {
2662 SCM result;
2663
d2295ba5
MW
2664 /* Substract 1 from the integer without untagging. */
2665 result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
510ca126
AW
2666
2667 if (SCM_LIKELY (SCM_I_INUMP (result)))
2668 RETURN (result);
2669 }
2670
2671 SYNC_IP ();
2672 RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
2673 }
2674
2675 /* mul dst:8 a:8 b:8
2676 *
2677 * Multiply A and B, and place the result in DST.
2678 */
af95414f 2679 VM_DEFINE_OP (80, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2680 {
2681 ARGS2 (x, y);
2682 SYNC_IP ();
2683 RETURN (scm_product (x, y));
2684 }
2685
2686 /* div dst:8 a:8 b:8
2687 *
2688 * Divide A by B, and place the result in DST.
2689 */
af95414f 2690 VM_DEFINE_OP (81, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2691 {
2692 ARGS2 (x, y);
2693 SYNC_IP ();
2694 RETURN (scm_divide (x, y));
2695 }
2696
2697 /* quo dst:8 a:8 b:8
2698 *
2699 * Divide A by B, and place the quotient in DST.
2700 */
af95414f 2701 VM_DEFINE_OP (82, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2702 {
2703 ARGS2 (x, y);
2704 SYNC_IP ();
2705 RETURN (scm_quotient (x, y));
2706 }
2707
2708 /* rem dst:8 a:8 b:8
2709 *
2710 * Divide A by B, and place the remainder in DST.
2711 */
af95414f 2712 VM_DEFINE_OP (83, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2713 {
2714 ARGS2 (x, y);
2715 SYNC_IP ();
2716 RETURN (scm_remainder (x, y));
2717 }
2718
2719 /* mod dst:8 a:8 b:8
2720 *
2721 * Place the modulo of A by B in DST.
2722 */
af95414f 2723 VM_DEFINE_OP (84, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2724 {
2725 ARGS2 (x, y);
2726 SYNC_IP ();
2727 RETURN (scm_modulo (x, y));
2728 }
2729
2730 /* ash dst:8 a:8 b:8
2731 *
2732 * Shift A arithmetically by B bits, and place the result in DST.
2733 */
af95414f 2734 VM_DEFINE_OP (85, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2735 {
2736 ARGS2 (x, y);
2737 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2738 {
2739 if (SCM_I_INUM (y) < 0)
2740 /* Right shift, will be a fixnum. */
0bd65965
MW
2741 RETURN (SCM_I_MAKINUM
2742 (SCM_SRS (SCM_I_INUM (x),
2743 (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
2744 ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
510ca126
AW
2745 else
2746 /* Left shift. See comments in scm_ash. */
2747 {
2748 scm_t_signed_bits nn, bits_to_shift;
2749
2750 nn = SCM_I_INUM (x);
2751 bits_to_shift = SCM_I_INUM (y);
2752
2753 if (bits_to_shift < SCM_I_FIXNUM_BIT-1
2754 && ((scm_t_bits)
2755 (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
2756 <= 1))
2757 RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
2758 /* fall through */
2759 }
2760 /* fall through */
2761 }
2762 SYNC_IP ();
2763 RETURN (scm_ash (x, y));
2764 }
2765
2766 /* logand dst:8 a:8 b:8
2767 *
2768 * Place the bitwise AND of A and B into DST.
2769 */
af95414f 2770 VM_DEFINE_OP (86, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2771 {
2772 ARGS2 (x, y);
2773 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
e7f64971
MW
2774 /* Compute bitwise AND without untagging */
2775 RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
510ca126
AW
2776 SYNC_IP ();
2777 RETURN (scm_logand (x, y));
2778 }
2779
2780 /* logior dst:8 a:8 b:8
2781 *
2782 * Place the bitwise inclusive OR of A with B in DST.
2783 */
af95414f 2784 VM_DEFINE_OP (87, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2785 {
2786 ARGS2 (x, y);
2787 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
e7f64971
MW
2788 /* Compute bitwise OR without untagging */
2789 RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
510ca126
AW
2790 SYNC_IP ();
2791 RETURN (scm_logior (x, y));
2792 }
2793
2794 /* logxor dst:8 a:8 b:8
2795 *
2796 * Place the bitwise exclusive OR of A with B in DST.
2797 */
af95414f 2798 VM_DEFINE_OP (88, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2799 {
2800 ARGS2 (x, y);
2801 if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
2802 RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
2803 SYNC_IP ();
2804 RETURN (scm_logxor (x, y));
2805 }
2806
2807 /* vector-length dst:12 src:12
2808 *
2809 * Store the length of the vector in SRC in DST.
2810 */
af95414f 2811 VM_DEFINE_OP (89, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2812 {
2813 ARGS1 (vect);
2814 if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
2815 RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
2816 else
2817 {
2818 SYNC_IP ();
2819 RETURN (scm_vector_length (vect));
2820 }
2821 }
2822
2823 /* vector-ref dst:8 src:8 idx:8
2824 *
2825 * Fetch the item at position IDX in the vector in SRC, and store it
2826 * in DST.
2827 */
af95414f 2828 VM_DEFINE_OP (90, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2829 {
2830 scm_t_signed_bits i = 0;
2831 ARGS2 (vect, idx);
2832 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2833 && SCM_I_INUMP (idx)
2834 && ((i = SCM_I_INUM (idx)) >= 0)
2835 && i < SCM_I_VECTOR_LENGTH (vect)))
2836 RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
2837 else
2838 {
2839 SYNC_IP ();
2840 RETURN (scm_vector_ref (vect, idx));
2841 }
2842 }
2843
2844 /* constant-vector-ref dst:8 src:8 idx:8
2845 *
2846 * Fill DST with the item IDX elements into the vector at SRC. Useful
2847 * for building data types using vectors.
2848 */
af95414f 2849 VM_DEFINE_OP (91, constant_vector_ref, "constant-vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2850 {
2851 scm_t_uint8 dst, src, idx;
2852 SCM v;
2853
2854 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
2855 v = LOCAL_REF (src);
2856 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v)
2857 && idx < SCM_I_VECTOR_LENGTH (v)))
2858 LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
2859 else
2860 LOCAL_SET (dst, scm_c_vector_ref (v, idx));
2861 NEXT (1);
2862 }
2863
2864 /* vector-set! dst:8 idx:8 src:8
2865 *
2866 * Store SRC into the vector DST at index IDX.
2867 */
af95414f 2868 VM_DEFINE_OP (92, vector_set, "vector-set", OP1 (U8_U8_U8_U8))
510ca126
AW
2869 {
2870 scm_t_uint8 dst, idx_var, src;
2871 SCM vect, idx, val;
2872 scm_t_signed_bits i = 0;
2873
2874 SCM_UNPACK_RTL_8_8_8 (op, dst, idx_var, src);
2875 vect = LOCAL_REF (dst);
2876 idx = LOCAL_REF (idx_var);
2877 val = LOCAL_REF (src);
2878
2879 if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
2880 && SCM_I_INUMP (idx)
2881 && ((i = SCM_I_INUM (idx)) >= 0)
2882 && i < SCM_I_VECTOR_LENGTH (vect)))
2883 SCM_I_VECTOR_WELTS (vect)[i] = val;
2884 else
2885 {
2886 SYNC_IP ();
2887 scm_vector_set_x (vect, idx, val);
2888 }
2889 NEXT (1);
2890 }
2891
2892
2893 \f
2894
2895 /*
2896 * Structs and GOOPS
2897 */
2898
2899 /* struct-vtable dst:12 src:12
2900 *
2901 * Store the vtable of SRC into DST.
2902 */
af95414f 2903 VM_DEFINE_OP (93, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
2904 {
2905 ARGS1 (obj);
2906 VM_VALIDATE_STRUCT (obj, "struct_vtable");
2907 RETURN (SCM_STRUCT_VTABLE (obj));
2908 }
2909
14d10292 2910 /* allocate-struct dst:8 vtable:8 nfields:8
510ca126 2911 *
14d10292
AW
2912 * Allocate a new struct with VTABLE, and place it in DST. The struct
2913 * will be constructed with space for NFIELDS fields, which should
2914 * correspond to the field count of the VTABLE.
510ca126 2915 */
af95414f 2916 VM_DEFINE_OP (94, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126 2917 {
14d10292
AW
2918 scm_t_uint8 dst, vtable, nfields;
2919 SCM ret;
510ca126 2920
14d10292 2921 SCM_UNPACK_RTL_8_8_8 (op, dst, vtable, nfields);
510ca126
AW
2922
2923 SYNC_IP ();
14d10292 2924 ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
510ca126 2925 LOCAL_SET (dst, ret);
14d10292
AW
2926
2927 NEXT (1);
510ca126 2928 }
510ca126
AW
2929
2930 /* struct-ref dst:8 src:8 idx:8
2931 *
2932 * Fetch the item at slot IDX in the struct in SRC, and store it
2933 * in DST.
2934 */
af95414f 2935 VM_DEFINE_OP (95, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
2936 {
2937 ARGS2 (obj, pos);
2938
2939 if (SCM_LIKELY (SCM_STRUCTP (obj)
2940 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2941 SCM_VTABLE_FLAG_SIMPLE)
2942 && SCM_I_INUMP (pos)))
2943 {
2944 SCM vtable;
2945 scm_t_bits index, len;
2946
2947 /* True, an inum is a signed value, but cast to unsigned it will
2948 certainly be more than the length, so we will fall through if
2949 index is negative. */
2950 index = SCM_I_INUM (pos);
2951 vtable = SCM_STRUCT_VTABLE (obj);
2952 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
2953
2954 if (SCM_LIKELY (index < len))
2955 {
2956 scm_t_bits *data = SCM_STRUCT_DATA (obj);
2957 RETURN (SCM_PACK (data[index]));
2958 }
2959 }
2960
2961 SYNC_IP ();
2962 RETURN (scm_struct_ref (obj, pos));
2963 }
2964
2965 /* struct-set! dst:8 idx:8 src:8
2966 *
2967 * Store SRC into the struct DST at slot IDX.
2968 */
af95414f 2969 VM_DEFINE_OP (96, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
2970 {
2971 scm_t_uint8 dst, idx, src;
2972 SCM obj, pos, val;
2973
2974 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
2975 obj = LOCAL_REF (dst);
2976 pos = LOCAL_REF (idx);
2977 val = LOCAL_REF (src);
2978
2979 if (SCM_LIKELY (SCM_STRUCTP (obj)
2980 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2981 SCM_VTABLE_FLAG_SIMPLE)
2982 && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
2983 SCM_VTABLE_FLAG_SIMPLE_RW)
2984 && SCM_I_INUMP (pos)))
2985 {
2986 SCM vtable;
2987 scm_t_bits index, len;
2988
2989 /* See above regarding index being >= 0. */
2990 index = SCM_I_INUM (pos);
2991 vtable = SCM_STRUCT_VTABLE (obj);
2992 len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
2993 if (SCM_LIKELY (index < len))
2994 {
2995 scm_t_bits *data = SCM_STRUCT_DATA (obj);
2996 data[index] = SCM_UNPACK (val);
2997 NEXT (1);
2998 }
2999 }
3000
3001 SYNC_IP ();
3002 scm_struct_set_x (obj, pos, val);
3003 NEXT (1);
3004 }
3005
3006 /* class-of dst:12 type:12
3007 *
3008 * Store the vtable of SRC into DST.
3009 */
af95414f 3010 VM_DEFINE_OP (97, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
510ca126
AW
3011 {
3012 ARGS1 (obj);
3013 if (SCM_INSTANCEP (obj))
3014 RETURN (SCM_CLASS_OF (obj));
3015 SYNC_IP ();
3016 RETURN (scm_class_of (obj));
3017 }
3018
3019 /* slot-ref dst:8 src:8 idx:8
3020 *
3021 * Fetch the item at slot IDX in the struct in SRC, and store it in
3022 * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
3023 * index into the stack.
3024 */
af95414f 3025 VM_DEFINE_OP (98, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3026 {
3027 scm_t_uint8 dst, src, idx;
3028 SCM_UNPACK_RTL_8_8_8 (op, dst, src, idx);
3029 LOCAL_SET (dst,
3030 SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
3031 NEXT (1);
3032 }
3033
3034 /* slot-set! dst:8 idx:8 src:8
3035 *
3036 * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
3037 * IDX is an 8-bit immediate value, not an index into the stack.
3038 */
af95414f 3039 VM_DEFINE_OP (99, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3040 {
3041 scm_t_uint8 dst, idx, src;
3042 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src);
3043 SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
3044 NEXT (1);
3045 }
3046
3047
3048 \f
3049
3050 /*
3051 * Arrays, packed uniform arrays, and bytevectors.
3052 */
3053
3054 /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
3055 *
3056 * Load the contiguous typed array located at OFFSET 32-bit words away
3057 * from the instruction pointer, and store into DST. LEN is a byte
3058 * length. OFFSET is signed.
3059 */
af95414f 3060 VM_DEFINE_OP (100, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
510ca126
AW
3061 {
3062 scm_t_uint8 dst, type, shape;
3063 scm_t_int32 offset;
3064 scm_t_uint32 len;
3065
3066 SCM_UNPACK_RTL_8_8_8 (op, dst, type, shape);
3067 offset = ip[1];
3068 len = ip[2];
3069 SYNC_IP ();
3070 LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type),
3071 LOCAL_REF (shape),
3072 ip + offset, len));
3073 NEXT (3);
3074 }
3075
3076 /* make-array dst:12 type:12 _:8 fill:12 bounds:12
3077 *
3078 * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
3079 */
af95414f 3080 VM_DEFINE_OP (101, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
510ca126
AW
3081 {
3082 scm_t_uint16 dst, type, fill, bounds;
3083 SCM_UNPACK_RTL_12_12 (op, dst, type);
3084 SCM_UNPACK_RTL_12_12 (ip[1], fill, bounds);
3085 SYNC_IP ();
3086 LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
3087 LOCAL_REF (bounds)));
3088 NEXT (2);
3089 }
3090
3091 /* bv-u8-ref dst:8 src:8 idx:8
3092 * bv-s8-ref dst:8 src:8 idx:8
3093 * bv-u16-ref dst:8 src:8 idx:8
3094 * bv-s16-ref dst:8 src:8 idx:8
3095 * bv-u32-ref dst:8 src:8 idx:8
3096 * bv-s32-ref dst:8 src:8 idx:8
3097 * bv-u64-ref dst:8 src:8 idx:8
3098 * bv-s64-ref dst:8 src:8 idx:8
3099 * bv-f32-ref dst:8 src:8 idx:8
3100 * bv-f64-ref dst:8 src:8 idx:8
3101 *
3102 * Fetch the item at byte offset IDX in the bytevector SRC, and store
3103 * it in DST. All accesses use native endianness.
3104 */
3105#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
3106 do { \
3107 scm_t_signed_bits i; \
3108 const scm_t_ ## type *int_ptr; \
3109 ARGS2 (bv, idx); \
3110 \
3111 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3112 i = SCM_I_INUM (idx); \
3113 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3114 \
3115 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3116 && (i >= 0) \
3117 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3118 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3119 RETURN (SCM_I_MAKINUM (*int_ptr)); \
3120 else \
3121 { \
3122 SYNC_IP (); \
3123 RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
3124 } \
3125 } while (0)
3126
3127#define BV_INT_REF(stem, type, size) \
3128 do { \
3129 scm_t_signed_bits i; \
3130 const scm_t_ ## type *int_ptr; \
3131 ARGS2 (bv, idx); \
3132 \
3133 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3134 i = SCM_I_INUM (idx); \
3135 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3136 \
3137 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3138 && (i >= 0) \
3139 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3140 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3141 { \
3142 scm_t_ ## type x = *int_ptr; \
3143 if (SCM_FIXABLE (x)) \
3144 RETURN (SCM_I_MAKINUM (x)); \
3145 else \
3146 { \
3147 SYNC_IP (); \
3148 RETURN (scm_from_ ## type (x)); \
3149 } \
3150 } \
3151 else \
3152 { \
3153 SYNC_IP (); \
3154 RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
3155 } \
3156 } while (0)
3157
3158#define BV_FLOAT_REF(stem, fn_stem, type, size) \
3159 do { \
3160 scm_t_signed_bits i; \
3161 const type *float_ptr; \
3162 ARGS2 (bv, idx); \
3163 \
3164 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
3165 i = SCM_I_INUM (idx); \
3166 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3167 \
3168 SYNC_IP (); \
3169 if (SCM_LIKELY (SCM_I_INUMP (idx) \
3170 && (i >= 0) \
3171 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3172 && (ALIGNED_P (float_ptr, type)))) \
3173 RETURN (scm_from_double (*float_ptr)); \
3174 else \
3175 RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
3176 } while (0)
3177
af95414f 3178 VM_DEFINE_OP (102, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3179 BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
3180
af95414f 3181 VM_DEFINE_OP (103, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3182 BV_FIXABLE_INT_REF (s8, s8, int8, 1);
3183
af95414f 3184 VM_DEFINE_OP (104, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3185 BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
3186
af95414f 3187 VM_DEFINE_OP (105, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3188 BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
3189
af95414f 3190 VM_DEFINE_OP (106, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3191#if SIZEOF_VOID_P > 4
3192 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
3193#else
3194 BV_INT_REF (u32, uint32, 4);
3195#endif
3196
af95414f 3197 VM_DEFINE_OP (107, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3198#if SIZEOF_VOID_P > 4
3199 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
3200#else
3201 BV_INT_REF (s32, int32, 4);
3202#endif
3203
af95414f 3204 VM_DEFINE_OP (108, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3205 BV_INT_REF (u64, uint64, 8);
3206
af95414f 3207 VM_DEFINE_OP (109, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3208 BV_INT_REF (s64, int64, 8);
3209
af95414f 3210 VM_DEFINE_OP (110, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3211 BV_FLOAT_REF (f32, ieee_single, float, 4);
3212
af95414f 3213 VM_DEFINE_OP (111, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
510ca126
AW
3214 BV_FLOAT_REF (f64, ieee_double, double, 8);
3215
3216 /* bv-u8-set! dst:8 idx:8 src:8
3217 * bv-s8-set! dst:8 idx:8 src:8
3218 * bv-u16-set! dst:8 idx:8 src:8
3219 * bv-s16-set! dst:8 idx:8 src:8
3220 * bv-u32-set! dst:8 idx:8 src:8
3221 * bv-s32-set! dst:8 idx:8 src:8
3222 * bv-u64-set! dst:8 idx:8 src:8
3223 * bv-s64-set! dst:8 idx:8 src:8
3224 * bv-f32-set! dst:8 idx:8 src:8
3225 * bv-f64-set! dst:8 idx:8 src:8
3226 *
3227 * Store SRC into the bytevector DST at byte offset IDX. Multibyte
3228 * values are written using native endianness.
3229 */
3230#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
3231 do { \
3232 scm_t_uint8 dst, idx, src; \
3233 scm_t_signed_bits i, j = 0; \
3234 SCM bv, scm_idx, val; \
3235 scm_t_ ## type *int_ptr; \
3236 \
3237 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3238 bv = LOCAL_REF (dst); \
3239 scm_idx = LOCAL_REF (idx); \
3240 val = LOCAL_REF (src); \
3241 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3242 i = SCM_I_INUM (scm_idx); \
3243 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3244 \
3245 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3246 && (i >= 0) \
3247 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3248 && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
3249 && (SCM_I_INUMP (val)) \
3250 && ((j = SCM_I_INUM (val)) >= min) \
3251 && (j <= max))) \
3252 *int_ptr = (scm_t_ ## type) j; \
3253 else \
3254 { \
3255 SYNC_IP (); \
3256 scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
3257 } \
3258 NEXT (1); \
3259 } while (0)
3260
3261#define BV_INT_SET(stem, type, size) \
3262 do { \
3263 scm_t_uint8 dst, idx, src; \
3264 scm_t_signed_bits i; \
3265 SCM bv, scm_idx, val; \
3266 scm_t_ ## type *int_ptr; \
3267 \
3268 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3269 bv = LOCAL_REF (dst); \
3270 scm_idx = LOCAL_REF (idx); \
3271 val = LOCAL_REF (src); \
3272 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3273 i = SCM_I_INUM (scm_idx); \
3274 int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3275 \
3276 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3277 && (i >= 0) \
3278 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3279 && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
3280 *int_ptr = scm_to_ ## type (val); \
3281 else \
3282 { \
3283 SYNC_IP (); \
3284 scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
3285 } \
3286 NEXT (1); \
3287 } while (0)
3288
3289#define BV_FLOAT_SET(stem, fn_stem, type, size) \
3290 do { \
3291 scm_t_uint8 dst, idx, src; \
3292 scm_t_signed_bits i; \
3293 SCM bv, scm_idx, val; \
3294 type *float_ptr; \
3295 \
3296 SCM_UNPACK_RTL_8_8_8 (op, dst, idx, src); \
3297 bv = LOCAL_REF (dst); \
3298 scm_idx = LOCAL_REF (idx); \
3299 val = LOCAL_REF (src); \
3300 VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
3301 i = SCM_I_INUM (scm_idx); \
3302 float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
3303 \
3304 if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
3305 && (i >= 0) \
3306 && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
3307 && (ALIGNED_P (float_ptr, type)))) \
3308 *float_ptr = scm_to_double (val); \
3309 else \
3310 { \
3311 SYNC_IP (); \
3312 scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
3313 } \
3314 NEXT (1); \
3315 } while (0)
3316
af95414f 3317 VM_DEFINE_OP (112, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3318 BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
3319
af95414f 3320 VM_DEFINE_OP (113, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3321 BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
3322
af95414f 3323 VM_DEFINE_OP (114, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3324 BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
3325
af95414f 3326 VM_DEFINE_OP (115, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3327 BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
3328
af95414f 3329 VM_DEFINE_OP (116, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3330#if SIZEOF_VOID_P > 4
3331 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4);
3332#else
3333 BV_INT_SET (u32, uint32, 4);
3334#endif
3335
af95414f 3336 VM_DEFINE_OP (117, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3337#if SIZEOF_VOID_P > 4
3338 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4);
3339#else
3340 BV_INT_SET (s32, int32, 4);
3341#endif
3342
af95414f 3343 VM_DEFINE_OP (118, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3344 BV_INT_SET (u64, uint64, 8);
3345
af95414f 3346 VM_DEFINE_OP (119, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3347 BV_INT_SET (s64, int64, 8);
3348
af95414f 3349 VM_DEFINE_OP (120, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3350 BV_FLOAT_SET (f32, ieee_single, float, 4);
3351
af95414f 3352 VM_DEFINE_OP (121, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
510ca126
AW
3353 BV_FLOAT_SET (f64, ieee_double, double, 8);
3354
3355 END_DISPATCH_SWITCH;
3356
3357 vm_error_bad_instruction:
3358 vm_error_bad_instruction (op);
3359
3360 abort (); /* never reached */
3361}
3362
3363
3364#undef ABORT_CONTINUATION_HOOK
3365#undef ALIGNED_P
3366#undef APPLY_HOOK
3367#undef ARGS1
3368#undef ARGS2
3369#undef BEGIN_DISPATCH_SWITCH
3370#undef BINARY_INTEGER_OP
3371#undef BR_ARITHMETIC
3372#undef BR_BINARY
3373#undef BR_NARGS
3374#undef BR_UNARY
3375#undef BV_FIXABLE_INT_REF
3376#undef BV_FIXABLE_INT_SET
3377#undef BV_FLOAT_REF
3378#undef BV_FLOAT_SET
3379#undef BV_INT_REF
3380#undef BV_INT_SET
3381#undef CACHE_REGISTER
3382#undef CHECK_OVERFLOW
3383#undef END_DISPATCH_SWITCH
3384#undef FREE_VARIABLE_REF
3385#undef INIT
3386#undef INUM_MAX
3387#undef INUM_MIN
3388#undef LOCAL_REF
3389#undef LOCAL_SET
3390#undef NEXT
3391#undef NEXT_HOOK
3392#undef NEXT_JUMP
3393#undef POP_CONTINUATION_HOOK
3394#undef PUSH_CONTINUATION_HOOK
3395#undef RESTORE_CONTINUATION_HOOK
3396#undef RETURN
3397#undef RETURN_ONE_VALUE
3398#undef RETURN_VALUE_LIST
3399#undef RUN_HOOK
3400#undef RUN_HOOK0
3401#undef SYNC_ALL
3402#undef SYNC_BEFORE_GC
3403#undef SYNC_IP
3404#undef SYNC_REGISTER
3405#undef VARIABLE_BOUNDP
3406#undef VARIABLE_REF
3407#undef VARIABLE_SET
3408#undef VM_CHECK_FREE_VARIABLE
3409#undef VM_CHECK_OBJECT
3410#undef VM_CHECK_UNDERFLOW
3411#undef VM_DEFINE_OP
3412#undef VM_INSTRUCTION_TO_LABEL
3413#undef VM_USE_HOOKS
3414#undef VM_VALIDATE_BYTEVECTOR
3415#undef VM_VALIDATE_PAIR
3416#undef VM_VALIDATE_STRUCT
3417
3418/*
3419(defun renumber-ops ()
3420 "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
3421 (interactive "")
3422 (save-excursion
3423 (let ((counter -1)) (goto-char (point-min))
3424 (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
3425 (replace-match
3426 (number-to-string (setq counter (1+ counter)))
3427 t t nil 1)))))
3428(renumber-ops)
3429*/
17e90c5e
KN
3430/*
3431 Local Variables:
3432 c-file-style: "gnu"
3433 End:
3434*/