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