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