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