vm.c 62.3 KB
Newer Older
eg's avatar
eg committed
1
/*
2
 * v m . c                              -- The STklos Virtual Machine
3
 *
4
 * Copyright © 2000-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
5 6
 *
 *
eg's avatar
eg committed
7 8 9 10
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
11
 *
eg's avatar
eg committed
12 13 14 15
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
16
 *
eg's avatar
eg committed
17 18
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
19
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
 * USA.
21
 *
eg's avatar
eg committed
22 23
 *           Author: Erick Gallesio [eg@unice.fr]
 *    Creation date:  1-Mar-2000 19:51 (eg)
24
 * Last file update: 29-Jun-2018 17:09 (eg)
eg's avatar
eg committed
25
 */
eg's avatar
eg committed
26 27 28

// INLINER values
// Voir FIX:
eg's avatar
eg committed
29 30


eg's avatar
eg committed
31 32 33 34 35
#include "stklos.h"
#include "object.h"
#include "vm.h"
#include "vm-instr.h"
#include "struct.h"
eg's avatar
eg committed
36

37
// #define DEBUG_VM
eg's avatar
eg committed
38 39
/* #define STAT_VM  */

40
#ifdef STAT_VM
eg's avatar
eg committed
41 42 43 44 45 46
#  define DEBUG_VM
static int couple_instr[NB_VM_INSTR][NB_VM_INSTR];
static int cpt_inst[NB_VM_INSTR];
#endif

#ifdef DEBUG_VM
47
static int debug_level = 0;     /* 0 is quiet, 1, 2, ... are more verbose */
eg's avatar
eg committed
48 49 50 51 52 53
#endif


#if defined(__GNUC__) && !defined(DEBUG_VM)
   /* Use computed gotos to have better performances */
#  define USE_COMPUTED_GOTO
54 55
#  define CASE(x)       lab_##x:
#  define NEXT          goto *jump_table[fetch_next()]
56
#else
eg's avatar
eg committed
57
   /* Standard C compiler. Use the classic switch statement */
58 59
#  define CASE(x)       case x:
#  define NEXT          continue;/* Be sure to not use continue elsewhere */
eg's avatar
eg committed
60 61
#endif

62 63
#define NEXT0           {vm->val = STk_void; vm->valc = 0; NEXT;}
#define NEXT1           {vm->valc = 1; NEXT;}
eg's avatar
eg committed
64 65 66


#ifdef sparc
67
#  define FLUSH_REGISTERS_WINDOW()      asm("t 0x3") /* Stolen in Elk 2.0 source */
eg's avatar
eg committed
68 69 70 71 72
#else
#  define FLUSH_REGISTERS_WINDOW()
#endif


73
#define MY_SETJMP(jb)           (jb.blocked = get_signal_mask(), setjmp(jb.j))
74
#define MY_LONGJMP(jb, val)     (longjmp((jb).j, val))
75

eg's avatar
eg committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90

static Inline sigset_t get_signal_mask(void)
{
  sigset_t new, old;

  sigemptyset(&new);
  sigprocmask(SIG_BLOCK, &new, &old);
  return old;
}

static Inline void set_signal_mask(sigset_t mask)
{
  sigprocmask(SIG_SETMASK, &mask, NULL);
}

91 92 93 94
static void error_unbound_variable(SCM symbol)
{
  STk_error("variable ~S unbound", symbol);
}
95

eg's avatar
eg committed
96 97

/*===========================================================================*\
98
 *
99
 *                      V M   S T A C K   &   C O D E
eg's avatar
eg committed
100 101 102 103
 *
\*===========================================================================*/

/* ==== Stack access macros ==== */
104 105
#define push(v)         (*(--(vm->sp)) = (v))
#define pop()           (*((vm->sp)++))
eg's avatar
eg committed
106 107
//FIX: Optim de la fin
#define IS_IN_STACKP(a) ((vm->stack <= (SCM*)(a))                 &&  \
108
                         ((SCM*)(a) < &vm->stack[vm->stack_len]))
eg's avatar
eg committed
109 110

/* ==== Code access macros ==== */
111 112
#define fetch_next()    (*(vm->pc)++)
#define fetch_const()   (vm->constants[fetch_next()])
Erick Gallesio's avatar
Erick Gallesio committed
113
#define look_const()    (vm->constants[*(vm->pc)])
114
#define fetch_global()  (*(checked_globals[(unsigned) fetch_next()]))
eg's avatar
eg committed
115 116


eg's avatar
eg committed
117

eg's avatar
eg committed
118
/*===========================================================================*\
119
 *
120
 *                      V M   T H R E A D
eg's avatar
eg committed
121 122
 *
\*===========================================================================*/
eg's avatar
eg committed
123 124 125
vm_thread_t *STk_allocate_vm(int stack_size)
{
  vm_thread_t *vm = STk_must_malloc(sizeof(vm_thread_t));
eg's avatar
eg committed
126

eg's avatar
eg committed
127 128 129 130 131 132
  /* Allocate the stack */
  vm->stack_len = stack_size;
  vm->stack     = STk_must_malloc(stack_size * sizeof(SCM));
  if (!vm->stack) {
    fprintf(stderr, "cannot allocate a stack with a size of %d cells\n", stack_size);
    fflush(stderr);
133
    STk_exit(MAKE_INT(1));
eg's avatar
eg committed
134
  }
135

eg's avatar
eg committed
136
  /* Initialize the VM registers */
137 138 139
  vm->sp             = vm->stack + vm->stack_len;
  vm->fp             = vm->sp;
  vm->val            = STk_void;
140
  vm->current_module = STk_current_module();
141 142 143
  vm->env            = vm->current_module;
  vm->handlers       = NULL;
  vm->top_jmp_buf    = NULL;
144
  vm->start_stack    = 0;               /* MUST be initialized later */
145
  vm->scheme_thread  = STk_false;
eg's avatar
eg committed
146
  vm->dynwind_stack  = LIST1(STk_false);
eg's avatar
eg committed
147 148 149

  return vm;
}
eg's avatar
eg committed
150 151


eg's avatar
eg committed
152
/*
153 154
 * Activation records
 *
eg's avatar
eg committed
155 156
 */

157
#define ACT_RECORD_SIZE    7
eg's avatar
eg committed
158

159
#define ACT_VARARG(reg)    ((reg)[0]) /* place holder for &rest parameters */
eg's avatar
eg committed
160 161 162 163 164 165 166 167 168 169
#define ACT_SAVE_ENV(reg)  ((reg)[1])
#define ACT_SAVE_PC(reg)   ((reg)[2])
#define ACT_SAVE_CST(reg)  ((reg)[3])
#define ACT_SAVE_FP(reg)   ((reg)[4])
#define ACT_SAVE_PROC(reg) ((reg)[5])
#define ACT_SAVE_INFO(reg) ((reg)[6])

/*
 * VM state
 *
170
 */
eg's avatar
eg committed
171
#define VM_STATE_SIZE 5
172 173 174 175 176
#define VM_STATE_PC(reg)        ((reg)[0])
#define VM_STATE_CST(reg)       ((reg)[1])
#define VM_STATE_ENV(reg)       ((reg)[2])
#define VM_STATE_FP(reg)        ((reg)[3])
#define VM_STATE_JUMP_BUF(reg)  ((reg)[4])
eg's avatar
eg committed
177

178 179 180 181 182 183 184
#define SAVE_VM_STATE()                 {               \
  vm->sp                   -= VM_STATE_SIZE;            \
  VM_STATE_PC(vm->sp)       = (SCM) vm->pc;             \
  VM_STATE_CST(vm->sp)      = (SCM) vm->constants;      \
  VM_STATE_ENV(vm->sp)      = (SCM) vm->env;            \
  VM_STATE_FP(vm->sp)       = (SCM) vm->fp;             \
  VM_STATE_JUMP_BUF(vm->sp) = (SCM) vm->top_jmp_buf;    \
eg's avatar
eg committed
185 186
}

187 188 189
#define FULL_RESTORE_VM_STATE(p)        {                       \
  vm->pc                     = (STk_instr *) VM_STATE_PC(p);    \
  RESTORE_VM_STATE(p);                                          \
eg's avatar
eg committed
190 191
}

192 193 194 195 196 197 198
#define RESTORE_VM_STATE(p)             {                       \
  /* pc is not restored here. See FULL_RESTORE_VM_STATE */      \
  vm->constants          = (SCM *)  VM_STATE_CST(p);            \
  vm->env                = (SCM)    VM_STATE_ENV(p);            \
  vm->fp                 = (SCM *)  VM_STATE_FP(p);             \
  vm->top_jmp_buf        = (jbuf *) VM_STATE_JUMP_BUF(p);       \
  vm->sp                += VM_STATE_SIZE;                       \
eg's avatar
eg committed
199 200 201 202 203 204 205 206 207
}


/*
 * Handlers
 *
 */
#define EXCEPTION_HANDLER_SIZE 3

208 209 210
#define HANDLER_PROC(reg)       ((reg)[0])
#define HANDLER_END(reg)        ((reg)[1])
#define HANDLER_PREV(reg)       ((reg)[2])
eg's avatar
eg committed
211 212


213 214 215 216 217 218
#define SAVE_HANDLER_STATE(proc, addr)  {               \
  vm->sp                   -= EXCEPTION_HANDLER_SIZE;   \
  HANDLER_PROC(vm->sp)  =  (SCM) (proc);                \
  HANDLER_END(vm->sp)   =  (SCM) (addr);                \
  HANDLER_PREV(vm->sp)  =  (SCM) vm->handlers;          \
  vm->handlers          = vm->sp;                       \
eg's avatar
eg committed
219 220
}

221 222 223 224 225
#define UNSAVE_HANDLER_STATE()  {                       \
  SCM *old = vm->handlers;                              \
                                                        \
  vm->handlers = (SCM *) HANDLER_PREV(vm->handlers);    \
  vm->sp       = old + EXCEPTION_HANDLER_SIZE;          \
eg's avatar
eg committed
226 227 228 229
}


/*===========================================================================*\
230
 *
231
 *                      C A L L S
eg's avatar
eg committed
232 233 234
 *
\*===========================================================================*/

235 236 237 238 239 240 241 242 243 244
#define PREP_CALL() {                                   \
  SCM fp_save = (SCM)(vm->fp);                          \
                                                        \
  /* Push an activation record on the stack */          \
  vm->sp -= ACT_RECORD_SIZE;                            \
  vm->fp  = vm->sp;                                     \
  ACT_SAVE_FP(vm->fp)   = fp_save;                      \
  ACT_SAVE_PROC(vm->fp) = STk_false;                    \
  ACT_SAVE_INFO(vm->fp) = STk_false;                    \
  /* Other fields will be initialized later */          \
eg's avatar
eg committed
245 246 247
}


248 249 250 251 252 253
#define RET_CALL() {                                    \
  vm->sp        = vm->fp + ACT_RECORD_SIZE;             \
  vm->env       = ACT_SAVE_ENV(vm->fp);                 \
  vm->pc        = ACT_SAVE_PC(vm->fp);                  \
  vm->constants = ACT_SAVE_CST(vm->fp);                 \
  vm->fp        = ACT_SAVE_FP(vm->fp);                  \
eg's avatar
eg committed
254 255 256
}


257
/*
258
 *                       M i s c .
eg's avatar
eg committed
259 260
 */

261
#define CHECK_GLOBAL_INIT_SIZE  50
eg's avatar
eg committed
262 263 264
static SCM** checked_globals;
static int   checked_globals_len  = CHECK_GLOBAL_INIT_SIZE;
static int   checked_globals_used = 0;
265
MUT_DECL(global_lock);          /* the lock to access checked_globals */
Erick Gallesio's avatar
.  
Erick Gallesio committed
266

eg's avatar
eg committed
267 268 269 270 271 272 273 274


#define FIRST_BYTE(n)  ((n) >> 8)
#define SECOND_BYTE(n) ((n) & 0xff)




275 276 277 278 279
#define PUSH_ENV(nargs, func, next_env)  {      \
    BOXED_TYPE(vm->sp)   = tc_frame;            \
    FRAME_LENGTH(vm->sp) = nargs;               \
    FRAME_NEXT(vm->sp)   = next_env;            \
    FRAME_OWNER(vm->sp)  = func;                \
eg's avatar
eg committed
280 281
}

282 283 284 285
#define CALL_CLOSURE(func) {                    \
    vm->pc        = CLOSURE_BCODE(func);        \
    vm->constants = CLOSURE_CONST(func);        \
    vm->env       = (SCM) vm->sp;               \
eg's avatar
eg committed
286 287
}

288 289 290
#define CALL_PRIM(v, args) {                    \
    ACT_SAVE_PROC(vm->fp) = v;                  \
    v = PRIMITIVE_FUNC(v)args;                  \
eg's avatar
eg committed
291 292
}

293 294 295
#define REG_CALL_PRIM(name) {                           \
  extern struct primitive_obj CPP_CONCAT(STk_o_, name);         \
  ACT_SAVE_PROC(vm->fp) = &CPP_CONCAT(STk_o_, name);    \
eg's avatar
eg committed
296 297 298
}


299 300 301
#define RETURN_FROM_PRIMITIVE() {               \
    vm->sp = vm->fp + ACT_RECORD_SIZE;          \
    vm->fp = (SCM *) ACT_SAVE_FP(vm->fp);       \
eg's avatar
eg committed
302 303
}

eg's avatar
eg committed
304
static void run_vm(vm_thread_t *vm);
eg's avatar
eg committed
305 306 307


/*===========================================================================*\
308
 *
309
 *                              Utilities
310
 *
eg's avatar
eg committed
311 312 313 314 315
\*===========================================================================*/

#ifdef DEBUG_VM
void STk_print_vm_registers(char *msg, STk_instr *code)
{
eg's avatar
eg committed
316
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
317
  if (IS_IN_STACKP(vm->env))
318
    STk_fprintf(STk_stderr, "%s VAL=~S PC=%d SP=%d FP=%d CST=%x ENV=%x (%d)\n",
319
                msg, vm->val, vm->pc - code, vm->sp - vm->stack,
320
                vm->fp - vm->stack, vm->constants, vm->env,
321
                (SCM*)vm->env - vm->stack);
eg's avatar
eg committed
322
  else
323
    STk_fprintf(STk_stderr, "%s VAL=~S PC=%d SP=%d FP=%d CST=%x ENV=%x (%d)",
324
                msg, vm->val, vm->pc - code, vm->sp - vm->stack,
325
                vm->fp - vm->stack, vm->constants, vm->env,
326
                (SCM*)vm->env - vm->stack);
eg's avatar
eg committed
327 328 329 330 331
}

#endif


eg's avatar
eg committed
332
static Inline SCM listify_top(int n, vm_thread_t *vm)
eg's avatar
eg committed
333 334 335
{
  SCM *p, res = STk_nil;

eg's avatar
eg committed
336
  for (p = vm->sp, vm->sp+=n; p < vm->sp; p++)
eg's avatar
eg committed
337 338 339 340 341
    res = STk_cons(*p, res);
  return res;
}


eg's avatar
eg committed
342
static Inline SCM clone_env(SCM e, vm_thread_t *vm)
eg's avatar
eg committed
343 344 345 346
{
  /* clone environment til we find one which is in the heap */
  if (FRAMEP(e) && IS_IN_STACKP(e)) {
    e = STk_clone_frame(e);
eg's avatar
eg committed
347
    FRAME_NEXT(e) = clone_env((SCM) FRAME_NEXT(e), vm);
eg's avatar
eg committed
348 349 350 351
  }
  return e;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
352
static void verif_environment(vm_thread_t *vm)
353
{
Erick Gallesio's avatar
.  
Erick Gallesio committed
354 355
  SCM *lfp, *env;

356
  //STk_debug("<<<<<<VVVVVVVV<<<<");
Erick Gallesio's avatar
.  
Erick Gallesio committed
357 358
  for (lfp = vm->fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
    SCM self = (SCM) (ACT_SAVE_PROC(lfp));
359
    //STk_debug("self = ~S", self);
Erick Gallesio's avatar
.  
Erick Gallesio committed
360 361
    if (!self || !ACT_SAVE_ENV(lfp)) break;

362
    //STk_debug("++++ %d", ACT_SAVE_ENV(lfp));
Erick Gallesio's avatar
.  
Erick Gallesio committed
363
    for (env = ACT_SAVE_ENV(lfp); FRAMEP(env); env = FRAME_NEXT(env)){
364 365
      //STk_debug("    On a l'environment ~S (%d)", (SCM) env,
      //IS_IN_STACKP(env));
366

Erick Gallesio's avatar
.  
Erick Gallesio committed
367
    }
368
    //STk_debug("---");
Erick Gallesio's avatar
.  
Erick Gallesio committed
369
  }
370
  //STk_debug(">>>VVV>>>>>>>");
Erick Gallesio's avatar
.  
Erick Gallesio committed
371 372 373
}

static void patch_environment(vm_thread_t *vm)
374
{
Erick Gallesio's avatar
.  
Erick Gallesio committed
375 376
  SCM *lfp;

377
  //STk_debug("<<<<<<<<<<");
Erick Gallesio's avatar
.  
Erick Gallesio committed
378 379 380
  for (lfp = vm->fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
    if (!ACT_SAVE_ENV(lfp)) break;

381
    //STk_debug("++++ %d", ACT_SAVE_ENV(lfp));
Erick Gallesio's avatar
.  
Erick Gallesio committed
382
    ACT_SAVE_ENV(lfp) = clone_env(ACT_SAVE_ENV(lfp), vm);
383
    //STk_debug("---");
Erick Gallesio's avatar
.  
Erick Gallesio committed
384
  }
385
  //STk_debug(">>>>>>>>>>");
Erick Gallesio's avatar
.  
Erick Gallesio committed
386 387 388 389
  verif_environment(vm);
}


eg's avatar
eg committed
390

eg's avatar
eg committed
391
static void error_bad_arity(SCM func, int arity, short given_args, vm_thread_t *vm)
eg's avatar
eg committed
392
{
eg's avatar
eg committed
393
   ACT_SAVE_PROC(vm->fp) = func;
eg's avatar
eg committed
394 395
  if (arity >= 0)
    STk_error("%d argument%s required in call to ~S (%d provided)",
396
              arity, ((arity>1)? "s": ""), func, given_args);
eg's avatar
eg committed
397 398
  else
    STk_error("~S requires at least %d argument%s (%d provided)",
399
              func, -arity-1, ((arity>1)? "s" : ""), given_args);
eg's avatar
eg committed
400 401 402
}


eg's avatar
eg committed
403
static Inline short adjust_arity(SCM func, short nargs, vm_thread_t *vm)
eg's avatar
eg committed
404 405 406 407
{
  short arity = CLOSURE_ARITY(func);

  if (arity != nargs) {
408
    if (arity >= 0)
eg's avatar
eg committed
409
      error_bad_arity(func, arity, nargs, vm);
410
    else {                                              /* nary procedure call */
eg's avatar
eg committed
411 412 413
      short min_arity = -arity-1;

      if (nargs < min_arity)
414
        error_bad_arity(func, arity, nargs, vm);
eg's avatar
eg committed
415
      else { /* Make a list from the arguments which are on the stack. */
416
        SCM res = STk_nil;
417

418 419
        while (nargs-- > min_arity) res = STk_cons(pop(), res);
        push(res);
eg's avatar
eg committed
420 421 422 423 424 425 426 427 428
      }
      return -arity;
    }
  }
  return arity;
}


/* Add a new global reference to the table of checked references */
429
static int add_global(SCM ref)
eg's avatar
eg committed
430
{
431 432 433 434
  SCM addr = &(BOX_VALUE(ref));
  int i;

  /* Search this global in the already accessed globals */
435
  for (i = 0; i <  checked_globals_used; i++) {
436 437
    if (checked_globals[i] == addr) return i;
  }
438

439 440
  /* Not present yet */
  if (checked_globals_used >= checked_globals_len) { /* resize the checked  array */
eg's avatar
eg committed
441
    checked_globals_len += checked_globals_len / 2;
442
    checked_globals      = STk_must_realloc(checked_globals,
443
                                            checked_globals_len * sizeof(SCM*));
eg's avatar
eg committed
444
  }
445
  checked_globals[checked_globals_used] = addr;
eg's avatar
eg committed
446 447 448 449 450
  return checked_globals_used++;
}


/*===========================================================================*\
451
 *
452
 *                                    C A L L S
eg's avatar
eg committed
453 454 455 456 457 458 459 460
 *
\*===========================================================================*/

/*
<doc  apply
 * (apply proc arg1 ... args)
 *
 * |Proc| must be a procedure and |args| must be a list. Calls |proc| with the
461
 * elements of the list
eg's avatar
eg committed
462 463
 * @lisp
 * (append (list arg1 ...) args)
464
 * @end lisp
eg's avatar
eg committed
465 466 467 468 469 470 471 472
 * as the actual arguments.
 * @lisp
 * (apply + (list 3 4))              =>  7
 *
 * (define compose
 *   (lambda (f g)
 *      (lambda args
 *        (f (apply g args)))))
473
 *
eg's avatar
eg committed
474 475 476 477
 * ((compose sqrt *) 12 75)          =>  30
 * @end lisp
doc>
 */
eg's avatar
eg committed
478
DEFINE_PRIMITIVE("apply", scheme_apply, apply, (void))
eg's avatar
eg committed
479
{
480
  /* This function is never called. It is just here to declare the primitive
eg's avatar
eg committed
481 482
   * apply, as a primitive of type tc_apply
   */
Erick Gallesio's avatar
Erick Gallesio committed
483
  STk_panic("Inside apply. Should not occur");
eg's avatar
eg committed
484
  return STk_void;
eg's avatar
eg committed
485 486 487 488 489
}


/*===========================================================================*\
 *
490
 *                              S T k _ C _ a p p l y
eg's avatar
eg committed
491 492
 *
 *
493 494 495
 * Execute a Scheme function from C. This function can be used as a
 * an "excv" or an "execl" function. If nargs is > 0 it is as a Unix "execl"
 * function:
eg's avatar
eg committed
496
 *    STk_C_apply(STk_cons, 2, MAKE_INT(1), MAKE_INT(2)) => (1 . 2)
497
 * If nargs is < 0, we have something similar to an "execv" function
eg's avatar
eg committed
498 499 500 501
 *    STk_C_apply(...STk_intern("cons")..., -2, Argv)
 * where Argv[0] == MAKE_INT(1) and Argv[1] == MAKE_INT(2) ==> (1 . 2)
 *
\*===========================================================================*/
502
SCM STk_C_apply(SCM func, int nargs, ...)
eg's avatar
eg committed
503
{
504
  STk_instr code[]= {INVOKE, 0, END_OF_CODE};
eg's avatar
eg committed
505
  va_list ap;
eg's avatar
eg committed
506
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
507 508 509 510
  int i;

  va_start(ap, nargs);
  //  sp -= VM_STATE_SIZE;
511 512
  SAVE_VM_STATE();                                  /* Save the VM regs */
  PREP_CALL();                                      /* PREPARE_CALL */
eg's avatar
eg committed
513

514
  if (nargs < 0) {                                  /* Push the arguments */
eg's avatar
eg committed
515 516 517 518
    /* args are in argc/argv form */
    SCM *argv = va_arg(ap, SCM*);

    nargs = -nargs;
519

eg's avatar
eg committed
520 521 522 523 524
    for (i = 0; i < nargs; i++) push(*argv++);
  } else {
    /* We have nargs SCM parameters to read */
    for (i = 0; i < nargs; i++) push(va_arg(ap, SCM));
  }
separdau's avatar
separdau committed
525
  va_end(ap);
eg's avatar
eg committed
526

527 528
  code[1] = (short) nargs;                          /* Patch # of args  */
  vm->val     = func;                               /* Store fun in VAL */
eg's avatar
eg committed
529 530
  vm->pc      = code;
  run_vm(vm);
eg's avatar
eg committed
531

eg's avatar
eg committed
532
  FULL_RESTORE_VM_STATE(vm->sp);
533

534 535 536 537 538 539 540 541
  return (vm->valc) ? vm->val : STk_void;
}

/* Another way to call apply from C. This time with a Scheme list */
SCM STk_C_apply_list(SCM func, SCM l)
{
  int i, argc = STk_int_length(l);
  SCM *argv = NULL;
542

543 544 545 546 547 548 549 550
  if (argc > 0) {
    argv = STk_must_malloc(argc * sizeof (SCM *));
    for (i = 0; i < argc; i++) {
      argv[i] = CAR(l);
      l = CDR(l);
    }
  }
  return STk_C_apply(func, -argc, argv);
eg's avatar
eg committed
551 552 553 554 555 556 557
}


DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
{
  int i, len;
  STk_instr *vinstr, *p;
eg's avatar
eg committed
558
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
559

560
  if (!envt) envt = vm->current_module;
561

562
  if (!VECTORP(code))   STk_error("bad code vector ~S", code);
eg's avatar
eg committed
563 564
  if (!VECTORP(consts)) STk_error("bad constant list ~S", consts);
  if (!MODULEP(envt))   STk_error("bad module for evaluation ~S", envt);
565

eg's avatar
eg committed
566 567 568 569 570 571 572 573
  /* convert code to a vector of instructions */
  len = VECTOR_SIZE(code);
  vinstr = p = STk_must_malloc(len * sizeof(STk_instr));

  for (i = 0; i < len; i++)
    *p++ = (STk_instr) STk_integer_value(VECTOR_DATA(code)[i]);

  SAVE_VM_STATE();
eg's avatar
eg committed
574 575 576 577
  vm->pc        = vinstr;
  vm->constants = VECTOR_DATA(consts);
  vm->env       = envt;
  run_vm(vm);
eg's avatar
eg committed
578
  FULL_RESTORE_VM_STATE(vm->sp);
eg's avatar
eg committed
579

eg's avatar
eg committed
580
  return vm->val;
eg's avatar
eg committed
581 582 583 584
}


/*===========================================================================*\
585
 *
586
 *                              V A L U E S
eg's avatar
eg committed
587 588 589 590 591 592
 *
\*===========================================================================*/
/*
<doc values
 * (values obj ...)
 *
593 594 595 596
 * Delivers all of its arguments to its continuation.
 * ,(bold "Note:") R5RS imposes to use multiple values in the context of
 * of a |call-with-values|. In STklos, if |values| is not used with
 * |call-with-values|, only the first value is used (i.e. others values are
eg's avatar
eg committed
597 598 599 600 601 602
 * ,(emph "ignored")).
 *
doc>
*/
DEFINE_PRIMITIVE("values", values, vsubr, (int argc, SCM *argv))
{
eg's avatar
eg committed
603
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
604 605 606
  int i;

  if (argc == 0)
eg's avatar
eg committed
607
    vm->val = STk_void;
eg's avatar
eg committed
608
  else {
eg's avatar
eg committed
609
    vm->val = argv[0];
eg's avatar
eg committed
610 611
    if (argc <= MAX_VALS) {
      for (i = 1; i < argc; i++)
612
        vm->vals[i] = argv[-i];
eg's avatar
eg committed
613 614 615
    } else {
      /* More than MAX_VALS values. Use a vector and store it in vals[0] */
      SCM tmp = STk_makevect(argc, (SCM) NULL);
616

eg's avatar
eg committed
617
      for (i = 0; i < argc; i++) VECTOR_DATA(tmp)[i] = *argv--;
eg's avatar
eg committed
618
      vm->vals[0] = tmp;
eg's avatar
eg committed
619 620
    }
  }
621

eg's avatar
eg committed
622
  /* Retain in valc the number of values */
eg's avatar
eg committed
623 624
  vm->valc = argc;
  return vm->val;
eg's avatar
eg committed
625 626 627 628 629 630
}

/*
<doc call-with-values
 * (call-with-values producer consumer)
 *
631 632 633 634
 * Calls its producer argument with no values and a continuation that,
 * when passed some values, calls the consumer procedure with those values
 * as arguments. The continuation for the call to consumer is the
 * continuation of the call to call-with-values.
eg's avatar
eg committed
635 636 637 638 639 640 641 642 643 644
 * @lisp
 * (call-with-values (lambda () (values 4 5))
 *                   (lambda (a b) b))                =>  5
 *
 * (call-with-values * -)                             =>  -1
 * @end lisp
doc>
 */
DEFINE_PRIMITIVE("call-with-values", call_with_values, subr2, (SCM prod, SCM con))
{
eg's avatar
eg committed
645
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
646 647
  int tmp;

648
  /* Test on prod and con being good procedure is useless, apply will evtly fail */
eg's avatar
eg committed
649 650
  vm->val  = STk_C_apply(prod, 0);
  tmp      = vm->valc;
651
  vm->valc = 1;
eg's avatar
eg committed
652 653 654 655

  if (tmp == 0)
    return STk_C_apply(con, 0);
  else if (tmp == 1)
eg's avatar
eg committed
656
    return STk_C_apply(con, 1, vm->val);
eg's avatar
eg committed
657
  else if (tmp <= MAX_VALS) {
eg's avatar
eg committed
658 659
    vm->vals[0] = vm->val;
    return STk_C_apply(con , -tmp, vm->vals);
eg's avatar
eg committed
660
  } else {
eg's avatar
eg committed
661
    return STk_C_apply(con, -tmp, VECTOR_DATA(vm->vals[0]));
eg's avatar
eg committed
662 663 664 665 666 667
  }
}


SCM STk_n_values(int n, ...)
{
eg's avatar
eg committed
668
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
669 670

  vm->valc = n;
671

eg's avatar
eg committed
672
  if (!n)
eg's avatar
eg committed
673
    vm->val = STk_void;
eg's avatar
eg committed
674 675 676 677 678
  else {
    va_list ap;
    int i;

    va_start(ap, n);
eg's avatar
eg committed
679
    vm->val = va_arg(ap, SCM);
eg's avatar
eg committed
680 681 682

    if (n <= MAX_VALS) {
      for (i = 1; i < n; i++)
683
        vm->vals[i] = va_arg(ap, SCM);
eg's avatar
eg committed
684 685 686
    } else {
      /* More than MAX_VALS values. Use a vector and store it in vals[0] */
      SCM tmp = STk_makevect(n, (SCM) NULL);
687

eg's avatar
eg committed
688
      for (i = 0; i < n; i++) VECTOR_DATA(tmp)[i] = va_arg(ap, SCM);
eg's avatar
eg committed
689
      vm->vals[0] = tmp;
eg's avatar
eg committed
690 691
    }
  }
eg's avatar
eg committed
692
  return vm->val;
eg's avatar
eg committed
693 694
}

695 696 697


SCM STk_values2vector(SCM obj, SCM vect)
698
{
699 700 701 702 703 704
  vm_thread_t *vm = STk_get_current_vm();
  SCM src, retval;
  int len = vm->valc;

  if (vect) {
    /* User has provided a vector for storing result */
705
    if (!VECTORP(vect) || VECTOR_SIZE(vect) != len)
706 707 708 709 710 711 712 713 714 715
      STk_error("bad vector ~S", vect);
    retval = vect;
  } else {
    /* Allocate a new vector for result */
    retval = STk_makevect(len, STk_void);
  }

  vm->val  = obj;
  vm->valc = 1;

716
  if (len > 1) {                    /* multiple values */
717 718 719
    if (len <= MAX_VALS)  {
      vm->vals[0] = obj;
      src = vm->vals;
720
    } else {                        /* mono value */
721 722 723 724 725 726 727 728 729 730 731 732
      src = VECTOR_DATA(vm->vals[0]);
    }

    memcpy(VECTOR_DATA(retval), src, len * sizeof(SCM));
  } else if (len == 1) {
    *VECTOR_DATA(retval) = vm->val;
  }

  return retval;
}


eg's avatar
eg committed
733
/*===========================================================================*\
734
 *
735
 *                              V M _ D E B U G
eg's avatar
eg committed
736 737 738
 *
\*===========================================================================*/

739 740
/* Add support for debugging
 * vm_debug is called with the kind of desired support and sp. It returns
eg's avatar
eg committed
741 742 743
 * the number of elements used on the stack
 */

eg's avatar
eg committed
744
static void vm_debug(int kind, vm_thread_t *vm)
eg's avatar
eg committed
745 746 747 748
{
  switch (kind) {
  case 0: /* old trace code position. Don't use it anymode */
    {
eg's avatar
eg committed
749
      SCM line = vm->val;
eg's avatar
eg committed
750 751
      SCM file = pop();
      STk_panic("Recompile code in file ~S (contains obsolete line informations)",
752
                file, line);
eg's avatar
eg committed
753 754 755 756
      break;
    }
  case 1: /* Embed line information in a procedure call */
    {
eg's avatar
eg committed
757
      SCM line = vm->val;
758

eg's avatar
eg committed
759
      ACT_SAVE_INFO(vm->fp) = STk_cons(pop(), line);
760
      break;
eg's avatar
eg committed
761 762 763 764 765
    }
  }
}

DEFINE_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void))
766
{
eg's avatar
eg committed
767
  SCM res, *lfp;
eg's avatar
eg committed
768
  vm_thread_t *vm = STk_get_current_vm();
eg's avatar
eg committed
769

eg's avatar
eg committed
770
  res = STk_nil;
eg's avatar
eg committed
771
  for (lfp = vm->fp; lfp; lfp = ACT_SAVE_FP(lfp)) {
eg's avatar
eg committed
772
    SCM self = (SCM) (ACT_SAVE_PROC(lfp));
773

eg's avatar
eg committed
774 775
    if (!self) break;

776
    res = STk_cons(STk_cons(self, ACT_SAVE_INFO(lfp)),
777
                   res);
eg's avatar
eg committed
778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805
  }
  return STk_dreverse(res);
}



#ifdef DEBUG_VM
#  ifdef STAT_VM
#    define DEFINE_NAME_TABLE
#    include "vm-instr.h"

static void dump_couple_instr(void)
{
  int i, j;
  FILE *dump;

  dump = fopen("/tmp/dump.out", "w");
  fprintf(dump, "[\n");

  for (i = NOP; i < NB_VM_INSTR; i++) {
    fprintf(dump, "((%s %d) ", name_table[i], cpt_inst[i]);
    for (j = NOP; j < NB_VM_INSTR; j++)
      fprintf(dump, "(%s %4d) ", name_table[j], couple_instr[i][j]);
    fprintf(dump, ")\n");
  }
  fprintf(dump, "\n]\n");
}
# endif
Erick Gallesio's avatar
.  
Erick Gallesio committed
806 807
#endif

eg's avatar
eg committed
808

Erick Gallesio's avatar
.  
Erick Gallesio committed
809 810
#ifdef STK_DEBUG
static void patch_environment(vm_thread_t *vm);
eg's avatar
eg committed
811 812
DEFINE_PRIMITIVE("%vm", set_vm_debug, vsubr, (int argc, SCM *argv))
{
813 814 815
  /*
   * This function is just a placeholder for debugging the VM. It's body is
   * changed depending of the current bug to track
eg's avatar
eg committed
816
   */
eg's avatar
eg committed
817

Erick Gallesio's avatar
.  
Erick Gallesio committed
818
  patch_environment(STk_get_current_vm());
eg's avatar
eg committed
819
  return STk_void;
eg's avatar
eg committed
820
}
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842

//#define VM_OFFSET(x) ((SCM) x - (SCM) vm->sp)
//
//static void show_stack_content(void)
//{
//  int i = 0;
//  vm_thread_t *vm = STk_get_current_vm();
//  char buff[10];
//
//  /* Show the registers */
//  STk_debug("=====================");
//  STk_debug("FP = %d", VM_OFFSET(vm->fp));
//  for (i=0; ;i++) {
//    STk_debug("offset %d value %d (0x%x)", i, vm->sp[i], vm->sp[i]);
//    fgets(buff, 10, stdin);
//    switch(*buff) {
//    case 's': STk_debug("Scheme value ~S",  vm->sp[i]); break;
//    case 'q': return;
//    default: /* nothing */;
//    }
//  }
//}
843
#endif
eg's avatar
eg committed
844 845 846


/*===========================================================================*\
847
 *
848
 *                     S T k l o s   V i r t u a l   M a c h i n e
eg's avatar
eg committed
849 850 851
 *
\*===========================================================================*/

852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880
/*
 * For optimization, some opcode/operand pairs get patched on the fly,
 * and replaced by another operation.  It's important that the two
 * reads (opcode and operand) happen atomically. If not, we can get this
 * situation:
 *   1) Thread A reads opcode at [n]
 *   2) Thread B suspends thread A, changes opcode at [n] and operand
 *      at [n+1]
 *   3) Thread A resumes, reads new operand at [n+1], which does not
 *      match the old opcode.
 *
 * To avoid this situation, and avoid a global lock around each
 * operation, we can do this:
 *    1) When we jump into one of the to-be-optimized opcodes, obtain
 *       the global lock.
 *    2) In case we hit the race condition (2, above), re-fetch and
 *       dispatch the current operand. We will either:
 *   3a) Re-dispatch to the same (to-be-optimized) opcode. Go ahead
 *       and optimize, then release lock.
 *   3b) We hit the race condition, and are dispatched to the new
 *       operand. Release the global lock and process the operation.
 *
 * We need to patch the opcode last, otherwise:
 *   1) Thread A obtains lock
 *   2) Modifies opcode at [n]
 *   3) Thread B interrupts thread A. Reads new opcode at [n], old
 *      operand at [n+1]
 *   4) Thread A resumes, updates operand at [n+1], releases lock
 */
881 882 883 884 885 886
#define LOCK_AND_RESTART                        \
  if (!have_global_lock) {                      \
    MUT_LOCK(global_lock);                      \
    have_global_lock=1;                         \
    (vm->pc)--;                                 \
    NEXT;                                       \
887
  }
888

889 890 891 892
#define RELEASE_LOCK                            \
   {                                            \
    MUT_UNLOCK(global_lock);                    \
    have_global_lock=0;                         \
893
   }
894

895 896 897 898
#define RELEASE_POSSIBLE_LOCK                   \
  if (have_global_lock) {                       \
    MUT_UNLOCK(global_lock);                    \
    have_global_lock=0;                         \
899
  }
900

eg's avatar
eg committed
901
static void run_vm(vm_thread_t *vm)
eg's avatar
eg committed
902
{
903
  jbuf jb;
904
  jbuf *old_jb = NULL;          /* to make Gcc happy */
905
  int offset, nargs=0;
eg's avatar
eg committed
906
  short tailp;
907
  int have_global_lock = 0;     /* if true, we're patching the code */
908
#if defined(USE_COMPUTED_GOTO)
eg's avatar
eg committed
909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925
#  define DEFINE_JUMP_TABLE
#  include "vm-instr.h"
#else
   short byteop;
#endif
#if defined(DEBUG_VM)
#    define DEFINE_NAME_TABLE
#    include "vm-instr.h"
  static STk_instr *code_base = NULL;
#endif
#if defined(STAT_VM)
  static short previous_op = NOP;
#endif

#if defined(USE_COMPUTED_GOTO)
  NEXT;
#else
926
  for ( ; ; ) {
eg's avatar
eg committed
927 928 929 930
    /* Execution loop */
    byteop = fetch_next();
#  ifdef DEBUG_VM
    if (debug_level > 1)
931
      fprintf(stderr, "%08x [%03d]: %20s  sp=%-6d fp=%-6d env=%p\n",
932 933 934
              vm->pc - 1,
              vm->pc - code_base-1,
              name_table[(int)byteop],
935
              vm->sp - vm->stack,
936
              vm->fp - vm->stack, vm->env);
eg's avatar
eg committed
937 938 939 940 941 942 943 944 945 946 947 948 949
#    ifdef STAT_VM
    couple_instr[previous_op][byteop]++;
    cpt_inst[byteop]++;
    previous_op = byteop;
#    endif
#  endif
    switch (byteop) {
#endif /*  USE_COMPUTED_GOTO */


CASE(NOP) { NEXT; }


eg's avatar
eg committed
950 951 952 953 954 955
CASE(IM_FALSE)  { vm->val = STk_false;       NEXT1;}
CASE(IM_TRUE)   { vm->val = STk_true;        NEXT1;}
CASE(IM_NIL)    { vm->val = STk_nil;         NEXT1;}
CASE(IM_MINUS1) { vm->val = MAKE_INT(-1);    NEXT1;}
CASE(IM_ZERO)   { vm->val = MAKE_INT(0);     NEXT1;}
CASE(IM_ONE)    { vm->val = MAKE_INT(1);     NEXT1;}
956
CASE(IM_VOID)   { vm->val = STk_void;        NEXT1;}
eg's avatar
eg committed
957

958 959
CASE(SMALL_INT) { vm->val = MAKE_INT(fetch_next());             NEXT1;}
CASE(CONSTANT)  { vm->val = fetch_const();                      NEXT1;}
eg's avatar
eg committed
960

961 962 963 964 965 966 967
CASE(FALSE_PUSH)  { push(STk_false);       NEXT;}
CASE(TRUE_PUSH)   { push(STk_true);        NEXT;}
CASE(NIL_PUSH)    { push(STk_nil);         NEXT;}
CASE(MINUS1_PUSH) { push(MAKE_INT(-1));    NEXT;}
CASE(ZERO_PUSH)   { push(MAKE_INT( 0));    NEXT;}
CASE(ONE_PUSH)    { push(MAKE_INT(+1));    NEXT;}
CASE(VOID_PUSH)   { push(STk_void);        NEXT;}
eg's avatar
eg committed
968 969


970
CASE(INT_PUSH)      { push(MAKE_INT(fetch_next())) ; NEXT; }
971
CASE(CONSTANT_PUSH) { push(fetch_const());           NEXT; }
eg's avatar
eg committed
972 973


Erick Gallesio's avatar
.  
Erick Gallesio committed
974
CASE(PUSH_GLOBAL_REF)
eg's avatar
eg committed
975
CASE(GLOBAL_REF) {
976 977 978
  SCM ref = NULL;
  short orig_opcode;
  SCM orig_operand;
979

980 981 982
  LOCK_AND_RESTART;
  orig_opcode  = vm->pc[-1];
  orig_operand = fetch_const();
983

984 985
  if (orig_opcode == PUSH_GLOBAL_REF)
    push(vm->val);
986

987 988 989 990 991
  vm->val= STk_lookup(orig_operand, vm->env, &ref, FALSE);
  if (!ref) {
    RELEASE_LOCK;
    error_unbound_variable(orig_operand);
  }
eg's avatar
eg committed
992 993

  /* patch the code for optimize next accesses */
994
  vm->pc[-1]  = add_global(CDR(ref));
995 996
  vm->pc[-2]  = (orig_opcode == GLOBAL_REF) ? UGLOBAL_REF: PUSH_UGLOBAL_REF;
  RELEASE_LOCK;
eg's avatar
eg committed
997 998
  NEXT1;
}
Erick Gallesio's avatar
.  
Erick Gallesio committed
999 1000

CASE(PUSH_UGLOBAL_REF)
1001
  push(vm->val);        /* Fall through */
1002 1003 1004
CASE(UGLOBAL_REF) {     /* Never produced by compiler */
  /* Because of optimization, we may get re-dispatched to here. */
  RELEASE_POSSIBLE_LOCK;
1005

1006
  vm->val = fetch_global();
1007
  NEXT1;
eg's avatar
eg committed
1008
}
eg's avatar
eg committed
1009

1010
CASE(GLOBAL_REF_PUSH) {
1011 1012 1013
  SCM ref = NULL;
  SCM orig_operand;
  SCM res;
1014

1015 1016 1017 1018 1019 1020 1021 1022
  LOCK_AND_RESTART;
  orig_operand = fetch_const();

  res = STk_lookup(orig_operand, vm->env, &ref, FALSE);
  if (!ref) {
    RELEASE_LOCK;
    error_unbound_variable(orig_operand);
  }
1023

1024
  push(res);
1025

1026
  /* patch the code for optimize next accesses */
1027
  vm->pc[-1]  = add_global(CDR(ref));
1028 1029
  vm->pc[-2]  = UGLOBAL_REF_PUSH;
  RELEASE_LOCK;
Erick Gallesio's avatar
.  
Erick Gallesio committed
1030
  NEXT1;
1031
}
1032

1033
CASE(UGLOBAL_REF_PUSH) { /* Never produced by compiler */
1034 1035
  /* Because of optimization, we may get re-dispatched to here. */
  RELEASE_POSSIBLE_LOCK;
1036 1037

  push(fetch_global());
Erick Gallesio's avatar
.  
Erick Gallesio committed
1038
  NEXT1;
1039 1040 1041
}


Erick Gallesio's avatar
.  
Erick Gallesio committed
1042
CASE(PUSH_GREF_INVOKE)
eg's avatar
eg committed
1043
CASE(GREF_INVOKE) {
1044 1045 1046
  SCM ref = NULL;
  short orig_opcode;
  SCM orig_operand;
1047

1048 1049 1050
  LOCK_AND_RESTART;
  orig_opcode  = vm->pc[-1];
  orig_operand = fetch_const();
1051

1052 1053
  if (orig_opcode == PUSH_GREF_INVOKE)
    push(vm->val);
1054

1055 1056 1057 1058 1059
  vm->val = STk_lookup(orig_operand, vm->env, &ref, FALSE);
  if (!ref) {
    RELEASE_LOCK;
    error_unbound_variable(orig_operand);
  }
1060

1061
  nargs = fetch_next();
eg's avatar
eg committed
1062
  /* patch the code for optimize next accesses (pc[-1] is already equal to nargs)*/
1063
  vm->pc[-2]  = add_global(CDR(ref));
1064 1065
  vm->pc[-3]  = (vm->pc[-3] == GREF_INVOKE)? UGREF_INVOKE : PUSH_UGREF_INVOKE;
  RELEASE_LOCK;
eg's avatar
eg committed
1066 1067 1068 1069 1070

  /*and now invoke */
  tailp=FALSE; goto FUNCALL;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
1071
CASE(PUSH_UGREF_INVOKE)
1072
  push(vm->val);        /* Fall through */
1073 1074
CASE(UGREF_INVOKE) { /* Never produced by compiler */

1075 1076
  /* Because of optimization, we may get re-dispatched to here. */
  RELEASE_POSSIBLE_LOCK;
1077

eg's avatar
eg committed
1078 1079
  vm->val = fetch_global();
  nargs   = fetch_next();
1080

eg's avatar
eg committed
1081 1082 1083 1084
  /* invoke */
  tailp = FALSE; goto FUNCALL;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
1085
CASE(PUSH_GREF_TAIL_INV)
1086
CASE(GREF_TAIL_INVOKE) {
1087 1088 1089
  SCM ref = NULL;
  short orig_opcode;
  SCM orig_operand;
1090

1091 1092 1093
  LOCK_AND_RESTART;
  orig_opcode  = vm->pc[-1];
  orig_operand = fetch_const();
1094

1095 1096
  if (orig_opcode == PUSH_GREF_TAIL_INV)
    push(vm->val);
1097

1098 1099 1100 1101 1102
  vm->val = STk_lookup(orig_operand, vm->env, &ref, FALSE);
  if (!ref) {
    RELEASE_LOCK;
    error_unbound_variable(orig_operand);
  }
1103

1104
  nargs = fetch_next();
1105
  /* patch the code for optimize next accesses (pc[-1] is already equal to nargs)*/
1106
  vm->pc[-2]  = add_global(CDR(ref));
1107
  vm->pc[-3]  = (vm->pc[-3] == GREF_TAIL_INVOKE) ?
1108
                        UGREF_TAIL_INVOKE: PUSH_UGREF_TAIL_INV;
1109
  RELEASE_LOCK;
1110 1111 1112 1113 1114

  /* and now invoke */
  tailp=TRUE; goto FUNCALL;
}

Erick Gallesio's avatar
.  
Erick Gallesio committed
1115
CASE(PUSH_UGREF_TAIL_INV)
1116
  push(vm->val);        /* Fall through */
1117 1118 1119
CASE(UGREF_TAIL_INVOKE) { /* Never produced by compiler */
  /* Because of optimization, we may get re-dispatched to here. */
  RELEASE_POSSIBLE_LOCK;
1120

1121 1122
  vm->val = fetch_global();
  nargs   = fetch_next();
1123

1124 1125 1126 1127 1128 1129
  /* invoke */
  tailp = TRUE; goto FUNCALL;
}



1130 1131 1132 1133 1134
CASE(LOCAL_REF0) { vm->val = FRAME_LOCAL(vm->env, 0);        NEXT1;}
CASE(LOCAL_REF1) { vm->val = FRAME_LOCAL(vm->env, 1);        NEXT1;}
CASE(LOCAL_REF2) { vm->val = FRAME_LOCAL(vm->env, 2);        NEXT1;}
CASE(LOCAL_REF3) { vm->val = FRAME_LOCAL(vm->env, 3);        NEXT1;}
CASE(LOCAL_REF4) { vm->val = FRAME_LOCAL(vm->env, 4);        NEXT1;}
eg's avatar
eg committed
1135
CASE(LOCAL_REF)  { vm->val = FRAME_LOCAL(vm->env, fetch_next()); NEXT1;}
eg's avatar
eg committed
1136 1137
CASE(DEEP_LOCAL_REF) {
  int level, info = fetch_next();
eg's avatar
eg committed
1138
  SCM e = vm->env;
eg's avatar
eg committed
1139 1140 1141 1142 1143

  /* Go down in the dynamic environment */
  for (level = FIRST_BYTE(info); level; level--)
    e = (SCM) FRAME_NEXT(e);

eg's avatar
eg committed
1144
  vm->val = FRAME_LOCAL(e, SECOND_BYTE(info));
eg's avatar
eg committed
1145 1146
  NEXT1;
}
1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165

CASE(DEEP_LOC_REF_FAR) {
  /* DEEP-LOCAL-REF but FAR (arg is a cons). (This is inefficient but rare) */
  SCM info = fetch_const();
  int level;
  SCM e = vm->env;

  if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
    STk_panic("DEEP_LOCAL_REF_FAR with ~S", info);

  /* Go down in the dynamic environment */
  for (level = INT_VAL(CAR(info)); level; level--)
    e = (SCM) FRAME_NEXT(e);

  vm->val = FRAME_LOCAL(e, INT_VAL(CDR(info)));
  NEXT1;
}


Erick Gallesio's avatar
Erick Gallesio committed
1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178
CASE(DEEP_LOC_REF_PUSH) {
  int level, info = fetch_next();
  SCM e = vm->env;

  /* Go down in the dynamic environment */
  for (level = FIRST_BYTE(info); level; level--)
    e = (SCM) FRAME_NEXT(e);

  push(vm->val = FRAME_LOCAL(e, SECOND_BYTE(info)));
  NEXT1;
}


eg's avatar
eg committed
1179

Erick Gallesio's avatar
.  
Erick Gallesio committed
1180 1181 1182 1183 1184
CASE(LOCAL_REF0_PUSH) {push(FRAME_LOCAL(vm->env, 0));  NEXT1;}
CASE(LOCAL_REF1_PUSH) {push(FRAME_LOCAL(vm->env, 1));  NEXT1;}
CASE(LOCAL_REF2_PUSH) {push(FRAME_LOCAL(vm->env, 2));  NEXT1;}
CASE(LOCAL_REF3_PUSH) {push(FRAME_LOCAL(vm->env, 3));  NEXT1;}
CASE(LOCAL_REF4_PUSH) {push(FRAME_LOCAL(vm->env, 4));  NEXT1;}
eg's avatar
eg committed
1185 1186

CASE(GLOBAL_SET) {
1187 1188
  SCM ref = NULL;
  SCM orig_operand;
1189

1190 1191
  LOCK_AND_RESTART;
  orig_operand = fetch_const();
1192

1193 1194 1195 1196 1197 1198
  STk_lookup(orig_operand, vm->env, &ref, FALSE);
  if (!ref) {
    RELEASE_LOCK;
    error_unbound_variable(orig_operand);
  }

1199
  BOX_VALUE(CDR(ref)) = vm->val;
eg's avatar
eg committed
1200
  /* patch the code for optimize next accesses */
1201
  vm->pc[-1] = add_global(CDR(ref));
1202 1203
  vm->pc[-2] = UGLOBAL_SET;
  RELEASE_LOCK;
eg's avatar
eg committed
1204 1205
  NEXT0;
}
1206

eg's avatar
eg committed
1207
CASE(UGLOBAL_SET) { /* Never produced by compiler */
1208 1209
  /* Because of optimization, we may get re-dispatched to here. */
  RELEASE_POSSIBLE_LOCK;
1210

eg's avatar
eg committed
1211
  fetch_global() = vm->val; NEXT0;
eg's avatar
eg committed
1212 1213
}

eg's avatar
eg committed
1214 1215 1216
CASE(LOCAL_SET0) { FRAME_LOCAL(vm->env, 0)           = vm->val; NEXT0;}
CASE(LOCAL_SET1) { FRAME_LOCAL(vm->env, 1)           = vm->val; NEXT0;}
CASE(LOCAL_SET2) { FRAME_LOCAL(vm->env, 2)           = vm->val; NEXT0;}
1217 1218
CASE(LOCAL_SET3) { FRAME_LOCAL(vm->env, 3)           = vm->val; NEXT0;}
CASE(LOCAL_SET4) { FRAME_LOCAL(vm->env, 4)           = vm->val; NEXT0;}
1219
CASE(LOCAL_SET)  { FRAME_LOCAL(vm->env,fetch_next()) = vm->val; NEXT0;}
eg's avatar
eg committed
1220

1221

eg's avatar
eg committed
1222 1223
CASE(DEEP_LOCAL_SET) {
  int level, info = fetch_next();
eg's avatar
eg committed
1224
  SCM e = vm->env;
eg's avatar
eg committed
1225 1226 1227 1228 1229

  /* Go down in the dynamic environment */
  for (level = FIRST_BYTE(info); level; level--)
    e = (SCM) FRAME_NEXT(e);

eg's avatar
eg committed
1230
  FRAME_LOCAL(e, SECOND_BYTE(info)) = vm->val;
eg's avatar
eg committed
1231 1232 1233 1234
  NEXT0;
}


1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253
CASE(DEEP_LOC_SET_FAR) {
  /* DEEP-LOCAL-SET but FAR (arg is a cons) (This is inefficient but rare) */
  SCM info = fetch_const();
  int level;
  SCM e = vm->env;

  if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
    STk_panic("DEEP_LOCAL_SET_FAR with ~S", info);

  /* Go down in the dynamic environment */
  for (level = INT_VAL(CAR(info)); level; level--)
    e = (SCM) FRAME_NEXT(e);

  FRAME_LOCAL(e, INT_VAL(CDR(info))) = vm->val;
  NEXT0;
}



eg's avatar
eg committed
1254
CASE(GOTO) { offset = fetch_next(); vm->pc += offset; NEXT;}
1255 1256
CASE(JUMP_FALSE) {
  offset = fetch_next();
eg's avatar
eg committed
1257
  if (vm->val == STk_false) vm->pc += offset;
eg's avatar
eg committed
1258 1259 1260 1261
  NEXT;
}
CASE(JUMP_TRUE) {
  offset = fetch_next();
eg's avatar
eg committed
1262
  if (vm->val != STk_false) vm->pc += offset;
eg's avatar
eg committed
1263 1264 1265 1266
  NEXT;
}

CASE(JUMP_NUMDIFF) {
eg's avatar
eg committed
1267
  offset = fetch_next(); if (!STk_numeq2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1268 1269
}
CASE(JUMP_NUMEQ) {
eg's avatar
eg committed
1270
  offset = fetch_next(); if (STk_numeq2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1271 1272
}
CASE(JUMP_NUMLT) {
eg's avatar
eg committed
1273
  offset = fetch_next(); if (STk_numlt2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1274 1275
}
CASE(JUMP_NUMLE) {
eg's avatar
eg committed
1276
  offset = fetch_next(); if (STk_numle2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1277 1278
}
CASE(JUMP_NUMGT) {
eg's avatar
eg committed
1279
  offset = fetch_next(); if (STk_numgt2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1280 1281
}
CASE(JUMP_NUMGE) {
eg's avatar
eg committed
1282
  offset = fetch_next(); if (STk_numge2(pop(), vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1283 1284
}
CASE(JUMP_NOT_EQ) {
eg's avatar
eg committed
1285
  offset = fetch_next(); if ((pop() != vm->val)) vm->pc += offset; NEXT;
eg's avatar
eg committed
1286 1287
}
CASE(JUMP_NOT_EQV) {
1288
  offset = fetch_next();
eg's avatar
eg committed
1289 1290
  if ((STk_eqv(pop(), vm->val) == STk_false)) vm->pc += offset;
  NEXT;
eg's avatar
eg committed
1291 1292
}
CASE(JUMP_NOT_EQUAL) {
1293
  offset = fetch_next();
eg's avatar
eg committed
1294 1295
  if ((STk_equal(pop(), vm->val)==STk_false)) vm->pc += offset;
  NEXT;
eg's avatar
eg committed
1296 1297 1298 1299 1300
}


CASE(DEFINE_SYMBOL) {
  SCM var = fetch_const();
1301

eg's avatar
eg committed
1302
  STk_define_variable(var, vm->val, vm->env);