root/src/vm.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. Scm_NewVM
  2. Scm_AttachVM
  3. Scm_VMGetResult
  4. Scm_VMSetResult
  5. Scm_VM
  6. Scm_VMKey
  7. run_loop
  8. save_env
  9. save_cont
  10. save_stack
  11. get_env
  12. Scm_VMApply
  13. Scm_VMApply0
  14. Scm_VMApply1
  15. Scm_VMApply2
  16. Scm_VMApply3
  17. Scm_VMApply4
  18. eval_restore_env
  19. Scm_VMEval
  20. user_eval_inner
  21. Scm_Eval
  22. Scm_EvalCString
  23. Scm_Apply
  24. Scm_VMPushCC
  25. Scm_VMDynamicWind
  26. dynwind_before_cc
  27. dynwind_body_cc
  28. dynwind_after_cc
  29. Scm_VMDynamicWindC
  30. Scm_VMDefaultExceptionHandler
  31. default_exception_handler_body
  32. Scm_VMThrowException
  33. install_ehandler
  34. discard_ehandler
  35. Scm_VMWithErrorHandler
  36. install_xhandler
  37. Scm_VMWithExceptionHandler
  38. throw_cont_calculate_handlers
  39. throw_cont_body
  40. throw_cont_cc
  41. throw_continuation
  42. Scm_VMCallCC
  43. Scm_Values
  44. Scm_Values2
  45. Scm_Values3
  46. Scm_Values4
  47. Scm_Values5
  48. process_queued_requests_cc
  49. process_queued_requests
  50. Scm_VMGetStackLite
  51. env2vec
  52. Scm_VMGetStack
  53. get_debug_info
  54. Scm_VMGetSourceInfo
  55. Scm_VMGetBindInfo
  56. dump_env
  57. Scm_VMDump
  58. vm_stack_mark
  59. Scm__InitVM

   1 /*
   2  * vm.c - evaluator
   3  *
   4  *   Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
   5  * 
   6  *   Redistribution and use in source and binary forms, with or without
   7  *   modification, are permitted provided that the following conditions
   8  *   are met:
   9  * 
  10  *   1. Redistributions of source code must retain the above copyright
  11  *      notice, this list of conditions and the following disclaimer.
  12  *
  13  *   2. Redistributions in binary form must reproduce the above copyright
  14  *      notice, this list of conditions and the following disclaimer in the
  15  *      documentation and/or other materials provided with the distribution.
  16  *
  17  *   3. Neither the name of the authors nor the names of its contributors
  18  *      may be used to endorse or promote products derived from this
  19  *      software without specific prior written permission.
  20  *
  21  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  24  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  25  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  26  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  27  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  28  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  29  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  30  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  31  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32  *
  33  *  $Id: vm.c,v 1.240 2005/10/03 20:57:45 shirok Exp $
  34  */
  35 
  36 #define LIBGAUCHE_BODY
  37 #include "gauche.h"
  38 #include "gauche/memory.h"
  39 #include "gauche/class.h"
  40 #include "gauche/exception.h"
  41 #include "gauche/builtin-syms.h"
  42 #include "gauche/code.h"
  43 #include "gauche/vminsn.h"
  44 #include "gauche/prof.h"
  45 
  46 /* Experimental code to use custom mark procedure for stack gc.
  47    Currently it doens't show any improvement, so we disable it
  48    by default. */
  49 #ifdef USE_CUSTOM_STACK_MARKER
  50 #include "gc_mark.h"
  51 
  52 static void **vm_stack_free_list;
  53 static int vm_stack_kind;
  54 static int vm_stack_mark_proc;
  55 #endif /*USE_CUSTOM_STACK_MARKER*/
  56 
  57 #include <unistd.h>
  58 #ifdef HAVE_SCHED_H
  59 #include <sched.h>
  60 #endif
  61 
  62 #ifndef EX_SOFTWARE
  63 /* SRFI-22 requires this. */
  64 #define EX_SOFTWARE 70
  65 #endif
  66 
  67 /* An object to mark the boundary frame. */
  68 static ScmWord boundaryFrameMark = SCM_VM_INSN(SCM_VM_NOP);
  69 
  70 /* return true if cont is a boundary continuation frame */
  71 #define BOUNDARY_FRAME_P(cont) ((cont)->pc == &boundaryFrameMark)
  72 
  73 /* A stub VM code to make VM return immediately */
  74 static ScmWord return_code[] = { SCM_VM_INSN(SCM_VM_RET) };
  75 #define PC_TO_RETURN  return_code
  76 
  77 /* A dummy compiled code structure used as 'fill-in', when Scm_Apply
  78    is called without any VM code running.  See Scm_Apply below. */
  79 static ScmCompiledCode internal_apply_compiled_code = 
  80     SCM_COMPILED_CODE_CONST_INITIALIZER(NULL, 0, 0, 0, 0,
  81                                         SCM_SYM_INTERNAL_APPLY,
  82                                         SCM_NIL, SCM_FALSE,
  83                                         SCM_FALSE, SCM_FALSE);
  84 
  85 
  86 
  87 /*
  88  * The VM. 
  89  *
  90  *   VM encapsulates the dynamic status of the current exection.
  91  *   In Gauche, there's always one active virtual machine per thread,
  92  *   referred by Scm_VM().   From Scheme, VM is seen as a <thread> object.
  93  *
  94  *   From Scheme, VM is viewed as <thread> object.  The class definition
  95  *   is in thrlib.stub.
  96  */
  97 
  98 static ScmVM *rootVM = NULL;         /* VM for primodial thread */
  99 
 100 #ifdef GAUCHE_USE_PTHREADS
 101 static pthread_key_t vm_key;
 102 #define theVM   ((ScmVM*)pthread_getspecific(vm_key))
 103 #else
 104 static ScmVM *theVM;
 105 #endif  /* !GAUCHE_USE_PTHREADS */
 106 
 107 static void save_stack(ScmVM *vm);
 108 
 109 static ScmSubr default_exception_handler_rec;
 110 #define DEFAULT_EXCEPTION_HANDLER  SCM_OBJ(&default_exception_handler_rec)
 111 static ScmObj throw_cont_calculate_handlers(ScmEscapePoint *, ScmVM *);
 112 static ScmObj throw_cont_body(ScmObj, ScmEscapePoint*, ScmObj);
 113 static void   process_queued_requests(ScmVM *vm);
 114 
 115 static ScmEnvFrame *get_env(ScmVM *vm);
 116 
 117 /*#define COUNT_INSN_FREQUENCY*/
 118 #ifdef COUNT_INSN_FREQUENCY
 119 #include "vmstat.c"
 120 #endif /*COUNT_INSN_FREQUENCY*/
 121 
 122 /*
 123  * Constructor
 124  *
 125  *   PROTO argument is treated as a prototype for the new VM, i.e.
 126  *   some of default values are 'inherited' from PROTO.
 127  *
 128  *   VM should be 'attached' to the running OS thread before being
 129  *   used.  The root thread is always attached to the primordial thread
 130  *   at the initialization stage (see Scm__InitVM()).   For other threads,
 131  *   it depends on whether the thread is created from Gauche side or not.
 132  *
 133  *   If the thread is created from Gauche side (i.e. by Scm_MakeThread() 
 134  *   C API or make-thread Scheme API), attaching is handled automatically
 135  *   by Gauche.
 136  *
 137  *   If the thread is created by other means, the VM should be attached
 138  *   to the thread by Scm_AttachVM() API.   The VMs attached by this are
 139  *   somewhat different than the ones attached by Gauche; such VM can't
 140  *   be passed to thread-join, for example.   This type of VM is for
 141  *   the applications that want to evaluate Gauche program in their own
 142  *   thread.
 143  *   NOTE: the thread should still be created by Boehm-GC's pthread_create,
 144  *   for it is the only way for GC to see the thread's stack.
 145  */
 146 
 147 ScmVM *Scm_NewVM(ScmVM *proto, ScmObj name)
 148 {
 149     ScmVM *v = SCM_NEW(ScmVM);
 150     int i;
 151     
 152     SCM_SET_CLASS(v, SCM_CLASS_VM);
 153     v->state = SCM_VM_NEW;
 154     (void)SCM_INTERNAL_MUTEX_INIT(v->vmlock);
 155     (void)SCM_INTERNAL_COND_INIT(v->cond);
 156     v->canceller = NULL;
 157     v->name = name;
 158     v->specific = SCM_FALSE;
 159     v->thunk = NULL;
 160     v->result = SCM_UNDEFINED;
 161     v->resultException = SCM_UNDEFINED;
 162     v->module = proto ? proto->module : Scm_SchemeModule();
 163     v->cstack = proto ? proto->cstack : NULL;
 164     
 165     v->curin  = SCM_PORT(Scm_Stdin());
 166     v->curout = SCM_PORT(Scm_Stdout());
 167     v->curerr = SCM_PORT(Scm_Stderr());
 168 
 169     Scm_ParameterTableInit(&(v->parameters), proto);
 170 
 171     v->compilerFlags = proto? proto->compilerFlags : 0;
 172     v->runtimeFlags = proto? proto->runtimeFlags : 0;
 173     v->queueNotEmpty = 0;
 174 
 175 #ifdef USE_CUSTOM_STACK_MARKER
 176     v->stack = (ScmObj*)GC_generic_malloc((SCM_VM_STACK_SIZE+1)*sizeof(ScmObj),
 177                                           vm_stack_kind);
 178     *v->stack++ = SCM_OBJ(v);
 179 #else  /*!USE_CUSTOM_STACK_MARKER*/
 180     v->stack = SCM_NEW_ARRAY(ScmObj, SCM_VM_STACK_SIZE);
 181 #endif /*!USE_CUSTOM_STACK_MARKER*/
 182     v->sp = v->stack;
 183     v->stackBase = v->stack;
 184     v->stackEnd = v->stack + SCM_VM_STACK_SIZE;
 185 
 186     v->env = NULL;
 187     v->argp = v->stack;
 188     v->cont = NULL;
 189     v->pc = PC_TO_RETURN;
 190     v->base = NULL;
 191     v->val0 = SCM_UNDEFINED;
 192     for (i=0; i<SCM_VM_MAX_VALUES; i++) v->vals[i] = SCM_UNDEFINED;
 193     v->numVals = 1;
 194     
 195     v->handlers = SCM_NIL;
 196 
 197     v->exceptionHandler = DEFAULT_EXCEPTION_HANDLER;
 198     v->escapePoint = v->escapePointFloating = NULL;
 199     v->escapeReason = SCM_VM_ESCAPE_NONE;
 200     v->escapeData[0] = NULL;
 201     v->escapeData[1] = NULL;
 202     v->defaultEscapeHandler = SCM_FALSE;
 203 
 204     v->load_history = SCM_NIL;
 205     v->load_next = SCM_NIL;
 206     v->load_port = SCM_FALSE;
 207     v->evalSituation = SCM_VM_EXECUTING;
 208 
 209     sigemptyset(&v->sigMask);
 210     Scm_SignalQueueInit(&v->sigq);
 211 
 212     /* stats */
 213     v->stat.sovCount = 0;
 214     v->stat.sovTime = 0;
 215     v->profilerRunning = FALSE;
 216     v->prof = NULL;
 217 
 218 #ifdef GAUCHE_USE_PTHREADS
 219     v->thread = (pthread_t)NULL;
 220 #endif /*GAUCHE_USE_PTHREADS*/
 221 
 222     return v;
 223 }
 224 
 225 /* Attach the thread to the current thread.
 226    See the notes of Scm_NewVM above.
 227    Returns TRUE on success, FALSE on failure. */
 228 int Scm_AttachVM(ScmVM *vm)
 229 {
 230 #ifdef GAUCHE_USE_PTHREADS
 231     if (vm->thread != (pthread_t)NULL) return FALSE;
 232     if (theVM != NULL) return FALSE;
 233 
 234     if (pthread_setspecific(Scm_VMKey(), vm) != 0) return FALSE;
 235 
 236     vm->thread = pthread_self();
 237     vm->state = SCM_VM_RUNNABLE;
 238     return TRUE;
 239 #else  /*!GAUCHE_USE_PTHREADS*/
 240     return FALSE;
 241 #endif /*!GAUCHE_USE_PTHREADS*/
 242 }
 243 
 244 
 245 ScmObj Scm_VMGetResult(ScmVM *vm)
 246 {
 247     ScmObj head = SCM_NIL, tail;
 248     int i;
 249     if (vm->numVals == 0) return SCM_NIL;
 250     SCM_APPEND1(head, tail, vm->val0);
 251     for (i=1; i<vm->numVals; i++) {
 252         SCM_APPEND1(head, tail, vm->vals[i-1]);
 253     }
 254     return head;
 255 }
 256 
 257 void Scm_VMSetResult(ScmObj obj)
 258 {
 259     ScmVM *vm = theVM;
 260     vm->val0 = obj;
 261     vm->numVals = 1;
 262 }
 263 
 264 /*
 265  * Current VM.
 266  */
 267 ScmVM *Scm_VM(void)
 268 {
 269     return theVM;
 270 }
 271 
 272 /*
 273  * Get VM key
 274  */
 275 #ifdef GAUCHE_USE_PTHREADS
 276 pthread_key_t Scm_VMKey(void)
 277 {
 278     return vm_key;
 279 }
 280 #endif /*GAUCHE_USE_PTHREADS*/
 281 
 282 /*====================================================================
 283  * VM interpreter
 284  *
 285  *  Interprets intermediate code CODE on VM.
 286  */
 287 
 288 /*
 289  * Micro-operations
 290  */
 291 
 292 /* fetching */
 293 #define INCR_PC                 (PC++)
 294 #define FETCH_LOCATION(var)     ((var) = (ScmWord*)*PC)
 295 #define FETCH_OPERAND(var)      ((var) = SCM_OBJ(*PC))
 296 #define FETCH_OPERAND_PUSH      (*SP++ = SCM_OBJ(*PC))
 297 
 298 #ifndef COUNT_INSN_FREQUENCY
 299 #define FETCH_INSN(var)         ((var) = *PC++)
 300 #else
 301 #define FETCH_INSN(var)         ((var) = fetch_insn_counting(vm, var))
 302 #endif
 303 
 304 /* For sanity check in debugging mode */
 305 #ifdef PARANOIA
 306 #define CHECK_STACK_PARANOIA(n)  CHECK_STACK(n)
 307 #else
 308 #define CHECK_STACK_PARANOIA(n)  /*empty*/
 309 #endif
 310 
 311 /* Hint for gcc -- at this moment, using __builtin_expect doesn't 
 312    do any good.  I'll try this later on. */
 313 #if 0
 314 #define MOSTLY_FALSE(expr)  __builtin_expect(expr, 0)
 315 #else
 316 #define MOSTLY_FALSE(expr)  expr
 317 #endif
 318 
 319 /* Find the stack bottom next to the continuation frame.
 320    This macro should be applied only if CONT is in stack. */
 321 #define CONT_FRAME_END(cont)                                            \
 322     ((cont)->argp?                                                      \
 323      ((ScmObj*)(cont) + CONT_FRAME_SIZE) :          /*Scheme continuation*/ \
 324      ((ScmObj*)(cont) + CONT_FRAME_SIZE + (cont)->size)) /*C continuation*/
 325 
 326 /* check if *pc is an return instruction.  if so, some
 327    shortcuts are taken. */
 328 #define TAIL_POS()         (*PC == SCM_VM_INSN(SCM_VM_RET))
 329 
 330 /* push OBJ to the top of the stack */
 331 #define PUSH_ARG(obj)      (*SP++ = (obj))
 332 
 333 /* pop the top object of the stack and store it to VAR */
 334 #define POP_ARG(var)       ((var) = *--SP)
 335 
 336 #define SMALL_REGS 0
 337 
 338 /* registers */
 339 #if SMALL_REGS == 4
 340 #define PC    pc
 341 #define SP    sp
 342 #define VAL0  val0
 343 #define ENV   env
 344 #define CONT  vm->cont
 345 #define ARGP  vm->argp
 346 #define BASE  vm->base
 347 #elif SMALL_REGS == 3
 348 #define PC    pc
 349 #define SP    sp
 350 #define VAL0  val0
 351 #define ENV   vm->env
 352 #define CONT  vm->cont
 353 #define ARGP  vm->argp
 354 #define BASE  vm->base
 355 #elif SMALL_REGS == 2
 356 #define PC    pc
 357 #define SP    sp
 358 #define VAL0  vm->val0
 359 #define ENV   vm->env
 360 #define CONT  vm->cont
 361 #define ARGP  vm->argp
 362 #define BASE  vm->base
 363 #elif SMALL_REGS == 0
 364 #define PC    vm->pc
 365 #define SP    vm->sp
 366 #define VAL0  vm->val0
 367 #define ENV   vm->env
 368 #define CONT  vm->cont
 369 #define ARGP  vm->argp
 370 #define BASE  vm->base
 371 #else  /* !SMALL_REGS */
 372 #define PC    pc
 373 #define SP    sp
 374 #define ENV   env
 375 #define VAL0  val0
 376 #define CONT  cont
 377 #define ARGP  argp
 378 #define BASE  vm->base
 379 #endif /* !SMALL_REGS */
 380 
 381 
 382 /* declare local variables for registers, and copy the current VM regs
 383    to them. */
 384 #define DECL_REGS             DECL_REGS_INT(/**/)
 385 #define DECL_REGS_VOLATILE    DECL_REGS_INT(volatile)
 386 
 387 #if SMALL_REGS == 4
 388 #define DECL_REGS_INT(VOLATILE)                 \
 389     ScmVM *VOLATILE vm = theVM;                 \
 390     SCM_PCTYPE VOLATILE pc = vm->pc;            \
 391     ScmEnvFrame *VOLATILE env = vm->env;        \
 392     ScmObj *VOLATILE sp = vm->sp;               \
 393     VOLATILE ScmObj val0 = vm->val0
 394 #elif SMALL_REGS == 3
 395 #define DECL_REGS_INT(VOLATILE)                 \
 396     ScmVM *VOLATILE vm = theVM;                 \
 397     SCM_PCTYPE VOLATILE pc = vm->pc;            \
 398     ScmObj *VOLATILE sp = vm->sp;               \
 399     VOLATILE ScmObj val0 = vm->val0
 400 #elif SMALL_REGS == 2
 401 #define DECL_REGS_INT(VOLATILE)                 \
 402     ScmVM *VOLATILE vm = theVM;                 \
 403     SCM_PCTYPE VOLATILE pc = vm->pc;            \
 404     ScmObj *VOLATILE sp = vm->sp
 405 #elif SMALL_REGS == 0
 406 #define DECL_REGS_INT(VOLATILE)                 \
 407     ScmVM *VOLATILE vm = theVM
 408 #else  /* !SMALL_REGS */
 409 #define DECL_REGS_INT(VOLATILE)                 \
 410     ScmVM *VOLATILE vm = theVM;                 \
 411     SCM_PCTYPE VOLATILE pc = vm->pc;            \
 412     ScmContFrame *VOLATILE cont = vm->cont;     \
 413     ScmEnvFrame *VOLATILE env = vm->env;        \
 414     ScmObj *VOLATILE argp = vm->argp;           \
 415     ScmObj *VOLATILE sp = vm->sp;               \
 416     VOLATILE ScmObj val0 = vm->val0
 417 #endif /* !SMALL_REGS */
 418 
 419 /* save VM regs into VM structure. */
 420 #if SMALL_REGS == 4
 421 #define SAVE_REGS()                             \
 422     do {                                        \
 423         vm->pc = pc;                            \
 424         vm->env = env;                          \
 425         vm->sp = sp;                            \
 426         vm->val0 = val0;                        \
 427     } while (0)
 428 #elif SMALL_REGS == 3
 429 #define SAVE_REGS()                             \
 430     do {                                        \
 431         vm->pc = pc;                            \
 432         vm->sp = sp;                            \
 433         vm->val0 = val0;                        \
 434     } while (0)
 435 #elif SMALL_REGS == 2
 436 #define SAVE_REGS()                             \
 437     do {                                        \
 438         vm->pc = pc;                            \
 439         vm->sp = sp;                            \
 440     } while (0)
 441 #elif SMALL_REGS == 0
 442 #define SAVE_REGS()
 443 #else  /*!SMALL_REGS*/
 444 #define SAVE_REGS()                             \
 445     do {                                        \
 446         vm->pc = pc;                            \
 447         vm->env = env;                          \
 448         vm->argp = argp;                        \
 449         vm->cont = cont;                        \
 450         vm->sp = sp;                            \
 451         vm->val0 = val0;                        \
 452     } while (0)
 453 #endif /*!SMALL_REGS*/
 454 
 455 /* return true if ptr points into the stack area */
 456 #define IN_STACK_P(ptr)                         \
 457       ((unsigned long)((ptr) - vm->stackBase) < SCM_VM_STACK_SIZE)
 458 
 459 #if SMALL_REGS == 4
 460 #define RESTORE_REGS()                          \
 461     do {                                        \
 462         pc = vm->pc;                            \
 463         env = vm->env;                          \
 464         sp = vm->sp;                            \
 465     } while (0)
 466 #elif SMALL_REGS == 3 || SMALL_REGS == 2
 467 #define RESTORE_REGS()                          \
 468     do {                                        \
 469         pc = vm->pc;                            \
 470         sp = vm->sp;                            \
 471     } while (0)
 472 #elif SMALL_REGS == 0
 473 #define RESTORE_REGS()
 474 #else  /*!SMALL_REGS*/
 475 #define RESTORE_REGS()                          \
 476     do {                                        \
 477         pc = vm->pc;                            \
 478         env = vm->env;                          \
 479         argp = vm->argp;                        \
 480         cont = vm->cont;                        \
 481         sp = vm->sp;                            \
 482     } while (0)
 483 #endif /*!SMALL_REGS*/
 484 
 485 /* Check if stack has room at least size bytes. */
 486 #define CHECK_STACK(size)                                       \
 487     do {                                                        \
 488         if (MOSTLY_FALSE(SP >= vm->stackEnd - (size))) {        \
 489             SAVE_REGS();                                        \
 490             save_stack(vm);                                     \
 491             RESTORE_REGS();                                     \
 492         }                                                       \
 493     } while (0)
 494 
 495 /* Push a continuation frame.  next_pc is the PC from where execution
 496    will be resumed.  */
 497 #define PUSH_CONT(next_pc)                              \
 498     do {                                                \
 499         ScmContFrame *newcont = (ScmContFrame*)SP;      \
 500         newcont->prev = CONT;                           \
 501         newcont->env = ENV;                             \
 502         newcont->argp = ARGP;                           \
 503         newcont->size = SP - ARGP;                      \
 504         newcont->pc = next_pc;                          \
 505         newcont->base = BASE;                           \
 506         CONT = newcont;                                 \
 507         SP += CONT_FRAME_SIZE;                          \
 508         ARGP = SP;                                      \
 509     } while (0)
 510 
 511 /* pop a continuation frame, i.e. return from a procedure. */
 512 #define POP_CONT()                                                      \
 513     do {                                                                \
 514         if (CONT->argp == NULL) {                                       \
 515             void *data__[SCM_CCONT_DATA_SIZE];                          \
 516             ScmObj (*after__)(ScmObj, void**);                          \
 517             void **d__ = data__;                                        \
 518             void **s__ = (void**)((ScmObj*)CONT + CONT_FRAME_SIZE);     \
 519             int i__ = CONT->size;                                       \
 520             while (i__-- > 0) {                                         \
 521                 *d__++ = *s__++;                                        \
 522             }                                                           \
 523             after__ = (ScmObj (*)(ScmObj, void**))CONT->pc;             \
 524             if (IN_STACK_P((ScmObj*)CONT)) SP = (ScmObj*)CONT;          \
 525             ENV = CONT->env;                                            \
 526             ARGP = SP;                                                  \
 527             PC = PC_TO_RETURN;                                          \
 528             CONT = CONT->prev;                                          \
 529             BASE = CONT->base;                                          \
 530             SAVE_REGS();                                                \
 531             VAL0 = after__(VAL0, data__);                               \
 532             RESTORE_REGS();                                             \
 533         } else if (IN_STACK_P((ScmObj*)CONT)) {                         \
 534             SP   = CONT->argp + CONT->size;                             \
 535             ENV  = CONT->env;                                           \
 536             ARGP = CONT->argp;                                          \
 537             PC   = CONT->pc;                                            \
 538             BASE = CONT->base;                                          \
 539             CONT = CONT->prev;                                          \
 540         } else {                                                        \
 541             int size__ = CONT->size;                                    \
 542             ARGP = SP = vm->stackBase;                                  \
 543             ENV = CONT->env;                                            \
 544             PC = CONT->pc;                                              \
 545             BASE = CONT->base;                                          \
 546             if (CONT->argp && size__) {                                 \
 547                 ScmObj *s__ = CONT->argp, *d__ = SP;                    \
 548                 SP += size__;                                           \
 549                 while (size__-- > 0) {                                  \
 550                     *d__++ = *s__++;                                    \
 551                 }                                                       \
 552             }                                                           \
 553             CONT = CONT->prev;                                          \
 554         }                                                               \
 555     } while (0)
 556 
 557 /* return operation. */
 558 #define RETURN_OP()                                     \
 559     do {                                                \
 560         if (CONT == NULL || BOUNDARY_FRAME_P(CONT)) {   \
 561             SAVE_REGS();                                \
 562             return; /* no more continuations */         \
 563         }                                               \
 564         POP_CONT();                                     \
 565     } while (0)
 566 
 567 /* push environment header to finish the environment frame.
 568    env, sp, argp is updated. */
 569 #define FINISH_ENV(info_, up_)                  \
 570     do {                                        \
 571         ScmEnvFrame *e__ = (ScmEnvFrame*)SP;    \
 572         e__->up = up_;                          \
 573         e__->info = info_;                      \
 574         e__->size = SP - ARGP;                  \
 575         SP += ENV_HDR_SIZE;                     \
 576         ARGP = SP;                              \
 577         ENV = e__;                              \
 578     } while (0)
 579 
 580 /* extend the current environment by SIZE words.   used for LET. */
 581 #define PUSH_LOCAL_ENV(size_, info_)            \
 582     do {                                        \
 583         int i__;                                \
 584         for (i__=0; i__<size_; i__++) {         \
 585             *SP++ = SCM_UNDEFINED;              \
 586         }                                       \
 587         FINISH_ENV(info_, ENV);                 \
 588     } while (0)
 589 
 590 /* used for the inlined instruction which is supposed to be called at
 591    tail position (e.g. SLOT-REF).  This checks whether we're at the tail
 592    position or not, and if not, push a cont frame to make the operation
 593    a tail call. */
 594 #define TAIL_CALL_INSTRUCTION()                 \
 595     do {                                        \
 596         if (!TAIL_POS()) {                      \
 597             CHECK_STACK(CONT_FRAME_SIZE);       \
 598             PUSH_CONT(PC);                      \
 599             PC = PC_TO_RETURN;                  \
 600         }                                       \
 601     } while (0)
 602 
 603 /* global reference.  this piece of code is used for a few GREF-something
 604    combined instruction. */
 605 #define GLOBAL_REF(v)                                                   \
 606     do {                                                                \
 607         ScmGloc *gloc;                                                  \
 608         FETCH_OPERAND(v);                                               \
 609         if (!SCM_GLOCP(v)) {                                            \
 610             VM_ASSERT(SCM_IDENTIFIERP(v));                              \
 611             gloc = Scm_FindBinding(SCM_IDENTIFIER(v)->module,           \
 612                                    SCM_IDENTIFIER(v)->name,             \
 613                                    FALSE);                              \
 614             if (gloc == NULL) {                                         \
 615                 VM_ERR(("unbound variable: %S",                         \
 616                         SCM_IDENTIFIER(v)->name));                      \
 617             }                                                           \
 618             /* memorize gloc */                                         \
 619             *PC = SCM_WORD(gloc);                                       \
 620         } else {                                                        \
 621             gloc = SCM_GLOC(v);                                         \
 622         }                                                               \
 623         v = SCM_GLOC_GET(gloc);                                         \
 624         if (v == SCM_UNBOUND) {                                         \
 625             VM_ERR(("unbound variable: %S", SCM_OBJ(gloc->name)));      \
 626         } else if (SCM_AUTOLOADP(v)) {                                  \
 627             SAVE_REGS();                                                \
 628             v = Scm_LoadAutoload(SCM_AUTOLOAD(v));                      \
 629             RESTORE_REGS();                                             \
 630         }                                                               \
 631         INCR_PC;                                                        \
 632     } while (0)
 633 
 634 /* for debug */
 635 #define VM_DUMP(delimiter)                      \
 636     SAVE_REGS();                                \
 637     fprintf(stderr, delimiter);                 \
 638     Scm_VMDump(vm)
 639 
 640 #define VM_ASSERT(expr)                                                 \
 641     do {                                                                \
 642         if (!(expr)) {                                                  \
 643             SAVE_REGS();                                                \
 644             fprintf(stderr, "\"%s\", line %d: Assertion failed: %s\n",  \
 645                     __FILE__, __LINE__, #expr);                         \
 646             Scm_VMDump(theVM);                                          \
 647             Scm_Panic("exitting...\n");                                 \
 648         }                                                               \
 649     } while (0)
 650 
 651 #define VM_ERR(errargs)                         \
 652    do {                                         \
 653       SAVE_REGS();                              \
 654       Scm_Error errargs;                        \
 655    } while (0)
 656 
 657 /* check the argument count is OK for call to PROC.  if PROC takes &rest
 658  * args, fold those arguments to the list.  Returns adjusted size of
 659  * the argument frame.
 660  */
 661 #define ADJUST_ARGUMENT_FRAME(proc, argc)       \
 662     do {                                        \
 663         int reqargs, restarg;                   \
 664         reqargs = SCM_PROCEDURE_REQUIRED(proc); \
 665         restarg = SCM_PROCEDURE_OPTIONAL(proc); \
 666         if (restarg) {                          \
 667             ScmObj p = SCM_NIL, a;              \
 668             if (argc < reqargs) goto wna;       \
 669             /* fold &rest args */               \
 670             while (argc > reqargs) {            \
 671                 POP_ARG(a);                     \
 672                 p = Scm_Cons(a, p);             \
 673                 argc--;                         \
 674             }                                   \
 675             PUSH_ARG(p);                        \
 676             argc++;                             \
 677         } else {                                \
 678             if (argc != reqargs) goto wna;      \
 679         }                                       \
 680     } while (0)
 681 
 682 /* inline expansion of number comparison. */
 683 #define NUM_CMP(op, r)                                          \
 684     do {                                                        \
 685         ScmObj x_, y_ = VAL0;                                   \
 686         POP_ARG(x_);                                            \
 687         if (SCM_INTP(y_) && SCM_INTP(x_)) {                     \
 688             r = ((signed long)x_ op (signed long)y_);           \
 689         } else if (SCM_FLONUMP(y_) && SCM_FLONUMP(x_)) {        \
 690             r = (SCM_FLONUM_VALUE(x_) op SCM_FLONUM_VALUE(y_)); \
 691         } else {                                                \
 692             SAVE_REGS();                                        \
 693             r = (Scm_NumCmp(x_, y_) op 0);                      \
 694             RESTORE_REGS();                                     \
 695         }                                                       \
 696     } while (0)
 697 
 698 #define NUM_CCMP(op, r)                                         \
 699     do {                                                        \
 700         ScmObj x_, y_ = VAL0;                                   \
 701         FETCH_OPERAND(x_);                                      \
 702         r = (SCM_FLONUM_VALUE(x_) op Scm_GetDouble(y_));        \
 703     } while (0)
 704 
 705 /* We take advantage of GCC's `computed goto' feature
 706    (see gcc.info, "Labels as Values"). */
 707 #ifdef __GNUC__
 708 #define SWITCH(val) goto *dispatch_table[val];
 709 #define CASE(insn)  SCM_CPP_CAT(LABEL_, insn) :
 710 #define DEFAULT     LABEL_DEFAULT :
 711 #define NEXT                                            \
 712     do {                                                \
 713         if (vm->queueNotEmpty) goto process_queue;      \
 714         FETCH_INSN(code);                               \
 715         goto *dispatch_table[SCM_VM_INSN_CODE(code)];   \
 716     } while (0)
 717 #else /* !__GNUC__ */
 718 #define SWITCH(val) switch (val)
 719 #define CASE(insn)  case insn :
 720 #define NEXT        goto dispatch
 721 #endif
 722 
 723 /* NEXT1 is a shorthand form to set the number of values to 1.
 724    The numVals should be set to 1 when (1) the instruction yields
 725    a single value, and (2) it is at the tail position.  We don't
 726    have information for each insn that it is at tail position or
 727    not (yet), but we know that _PUSH insn won't come at the tail pos.
 728 */
 729 #define NEXT1                                   \
 730     do {                                        \
 731         vm->numVals = 1;                        \
 732         NEXT;                                   \
 733     } while (0)
 734 
 735 /*===================================================================
 736  * Main loop of VM
 737  */
 738 /*static*/ void run_loop()
 739 {
 740     DECL_REGS;
 741     ScmWord code = 0;
 742     
 743 #ifdef __GNUC__
 744     static void *dispatch_table[256] = {
 745 #define DEFINSN(insn, name, nargs, type)   && SCM_CPP_CAT(LABEL_, insn),
 746 #include "vminsn.c"
 747 #undef DEFINSN
 748     };
 749 #endif /* __GNUC__ */
 750 
 751     /* The following code dumps the address of labels of each instruction
 752        handler.  Useful for tuning if used with machine instruction-level
 753        profiler. */
 754 #if 0
 755     static int init = 0;
 756     if (!init) {
 757         int i;
 758         for (i=0; i<SCM_VM_NUM_INSNS; i++) {
 759             fprintf(stderr, "%3d %-15s %p (+%04x, %5d)\n",
 760                     i, Scm_VMInsnName(i),
 761                     dispatch_table[i],
 762                     (char*)dispatch_table[i] - (char*)run_loop,
 763                     (char*)dispatch_table[i] - (char*)run_loop);
 764         }
 765         init = TRUE;
 766     }
 767 #endif
 768 
 769     for (;;) {
 770       dispatch:
 771         /*VM_DUMP("");*/
 772         if (vm->queueNotEmpty) goto process_queue;
 773         FETCH_INSN(code);
 774         SWITCH(SCM_VM_INSN_CODE(code)) {
 775 
 776             CASE(SCM_VM_CONST) {
 777                 FETCH_OPERAND(VAL0);
 778                 INCR_PC;
 779                 NEXT1;
 780             }
 781             CASE(SCM_VM_CONST_PUSH) {
 782                 CHECK_STACK_PARANOIA(1);
 783                 FETCH_OPERAND_PUSH;
 784                 INCR_PC;
 785                 NEXT;
 786             }
 787             CASE(SCM_VM_PUSH) {
 788                 CHECK_STACK_PARANOIA(1);
 789                 PUSH_ARG(VAL0);
 790                 NEXT;
 791             }
 792             CASE(SCM_VM_PUSH_PRE_CALL) {
 793                 CHECK_STACK_PARANOIA(1);
 794                 PUSH_ARG(VAL0);
 795             }
 796             /* FALLTHROUGH */
 797             CASE(SCM_VM_PRE_CALL) {
 798                 ScmWord *next;
 799                 CHECK_STACK_PARANOIA(CONT_FRAME_SIZE);
 800                 FETCH_LOCATION(next);
 801                 PUSH_CONT(next);
 802                 INCR_PC;
 803                 NEXT;
 804             }
 805             CASE(SCM_VM_CHECK_STACK) {
 806                 int reqstack = SCM_VM_INSN_ARG(code);
 807                 CHECK_STACK(reqstack);
 808                 NEXT;
 809             }
 810             CASE(SCM_VM_TAIL_CALL) {
 811                 /* discard the caller's argument frame, and shift
 812                    the callee's argument frame there.
 813                    NB: this shifting used to be done after folding
 814                    &rest arguments.  Benchmark showed this one is better.
 815                 */
 816                 ScmObj *to;
 817                 int argc;
 818               tail_call_entry:
 819                 argc = SP - ARGP;
 820 
 821                 if (IN_STACK_P((ScmObj*)CONT)) {
 822                     to = CONT_FRAME_END(CONT);
 823                 } else {
 824                     /* continuation has been saved, which means the
 825                        stack has no longer useful information. */
 826                     to = vm->stackBase;
 827                 }
 828                 if (argc) {
 829                     ScmObj *t = to, *a = ARGP;
 830                     int c;
 831                     /* The destintation and the source may overlap, but
 832                        in such case the destination is always lower than
 833                        the source, so we can safely use incremental copy. */
 834                     for (c=0; c<argc; c++) *t++ = *a++;
 835                 }
 836                 ARGP = to;
 837                 SP = to + argc;
 838                 /* We discarded the current env, so make sure we don't have
 839                    a dangling env pointer. */
 840                 ENV = NULL;
 841             }
 842             /* FALLTHROUGH */
 843             CASE(SCM_VM_CALL) {
 844                 int argc;
 845                 int proctype;
 846                 ScmObj nm, mm, *fp;
 847               call_entry:
 848                 argc = SP - ARGP;
 849                 vm->numVals = 1; /* default */
 850 
 851                 /* object-apply hook.  shift args, and insert val0 into
 852                    the fist arg slot, then call GenericObjectApply. */
 853                 if (MOSTLY_FALSE(!SCM_PROCEDUREP(VAL0))) {
 854                     int i;
 855                     CHECK_STACK_PARANOIA(1);
 856                     for (i=0; i<argc; i++) {
 857                         *(SP-i) = *(SP-i-1);
 858                     }
 859                     *(SP-argc) = VAL0;
 860                     SP++; argc++;
 861                     VAL0 = SCM_OBJ(&Scm_GenericObjectApply);
 862                     proctype = SCM_PROC_GENERIC;
 863                     nm = SCM_FALSE;
 864                     goto generic;
 865                 }
 866                 /*
 867                  * We process the common cases first
 868                  */
 869                 proctype = SCM_PROCEDURE_TYPE(VAL0);
 870                 if (proctype == SCM_PROC_SUBR) {
 871                     /* We don't need to complete environment frame.
 872                        Just need to adjust sp, so that stack-operating
 873                        procs called from subr won't be confused. */
 874                     ADJUST_ARGUMENT_FRAME(VAL0, argc);
 875                     SP = ARGP;
 876                     PC = PC_TO_RETURN;
 877 
 878                     SAVE_REGS();
 879                     SCM_PROF_COUNT_CALL(vm, VAL0);
 880                     VAL0 = SCM_SUBR(VAL0)->func(ARGP, argc,
 881                                                 SCM_SUBR(VAL0)->data);
 882                     RESTORE_REGS();
 883                     /* the subr may substituted pc, so we need to check
 884                        if we can pop the continuation immediately. */
 885                     if (TAIL_POS()) RETURN_OP();
 886                     NEXT;
 887                 }
 888                 if (proctype == SCM_PROC_CLOSURE) {
 889                     ADJUST_ARGUMENT_FRAME(VAL0, argc);
 890                     if (argc) {
 891                         FINISH_ENV(SCM_PROCEDURE_INFO(VAL0),
 892                                    SCM_CLOSURE(VAL0)->env);
 893                     } else {
 894                         ENV = SCM_CLOSURE(VAL0)->env;
 895                         ARGP = SP;
 896                     }
 897                     vm->base = SCM_COMPILED_CODE(SCM_CLOSURE(VAL0)->code);
 898                     PC = vm->base->code;
 899                     CHECK_STACK(vm->base->maxstack);
 900                     SCM_PROF_COUNT_CALL(vm, SCM_OBJ(vm->base));
 901                     NEXT;
 902                 }
 903                 /*
 904                  * Generic function application
 905                  */
 906                 /* First, compute methods */
 907                 nm = SCM_FALSE;
 908                 if (proctype == SCM_PROC_GENERIC) {
 909                     if (!SCM_GENERICP(VAL0)) {
 910                         /* use scheme-defined MOP.  we modify the stack frame
 911                            so that it is converted to an application of
 912                            pure generic fn apply-generic. */
 913                         ScmObj args = SCM_NIL, arg;
 914                         int i;
 915                         for (i=0; i<argc; i++) {
 916                             POP_ARG(arg);
 917                             args = Scm_Cons(arg, args);
 918                         }
 919                         ARGP = SP;
 920                         argc = 2;
 921                         PUSH_ARG(VAL0);
 922                         PUSH_ARG(args);
 923                         VAL0 = SCM_OBJ(&Scm_GenericApplyGeneric);
 924                     }
 925                   generic:
 926                     /* pure generic application */
 927                     mm = Scm_ComputeApplicableMethods(SCM_GENERIC(VAL0),
 928                                                       ARGP, argc);
 929                     if (!SCM_NULLP(mm)) {   
 930                         mm = Scm_SortMethods(mm, ARGP, argc);
 931                         nm = Scm_MakeNextMethod(SCM_GENERIC(VAL0),
 932                                                 SCM_CDR(mm),
 933                                                 ARGP, argc, TRUE);
 934                         VAL0 = SCM_CAR(mm);
 935                         proctype = SCM_PROC_METHOD;
 936                     }
 937                 } else if (proctype == SCM_PROC_NEXT_METHOD) {
 938                     ScmNextMethod *n = SCM_NEXT_METHOD(VAL0);
 939                     if (argc == 0) {
 940                         CHECK_STACK(n->nargs+1);
 941                         memcpy(SP, n->args, sizeof(ScmObj)*n->nargs);
 942                         SP += n->nargs;
 943                         argc = n->nargs;
 944                     }
 945                     if (SCM_NULLP(n->methods)) {
 946                         VAL0 = SCM_OBJ(n->generic);
 947                         proctype = SCM_PROC_GENERIC;
 948                     } else {
 949                         nm = Scm_MakeNextMethod(n->generic,
 950                                                 SCM_CDR(n->methods),
 951                                                 ARGP, argc, TRUE);
 952                         VAL0 = SCM_CAR(n->methods);
 953                         proctype = SCM_PROC_METHOD;
 954                     }
 955                 } else {
 956                     Scm_Panic("something wrong.");
 957                 }
 958 
 959                 fp = ARGP;
 960                 if (proctype == SCM_PROC_GENERIC) {
 961                     /* we have no applicable methods.  call fallback fn. */
 962                     FINISH_ENV(SCM_PROCEDURE_INFO(VAL0), NULL);
 963                     PC = PC_TO_RETURN;
 964                     SAVE_REGS();
 965                     SCM_PROF_COUNT_CALL(vm, VAL0);
 966                     VAL0 = SCM_GENERIC(VAL0)->fallback(fp,
 967                                                        argc,
 968                                                        SCM_GENERIC(VAL0));
 969                     RESTORE_REGS();
 970                     /* the fallback may substituted pc, so we need to check
 971                        if we can pop the continuation immediately. */
 972                     if (TAIL_POS()) RETURN_OP();
 973                     NEXT;
 974                 }
 975 
 976                 /*
 977                  * Now, apply method
 978                  */
 979                 ADJUST_ARGUMENT_FRAME(VAL0, argc);
 980                 VM_ASSERT(proctype == SCM_PROC_METHOD);
 981                 VM_ASSERT(!SCM_FALSEP(nm));
 982                 if (SCM_METHOD(VAL0)->func) {
 983                     /* C-defined method */
 984                     FINISH_ENV(SCM_PROCEDURE_INFO(VAL0), NULL);
 985                     PC = PC_TO_RETURN;
 986                     SAVE_REGS();
 987                     SCM_PROF_COUNT_CALL(vm, VAL0);
 988                     VAL0 = SCM_METHOD(VAL0)->func(SCM_NEXT_METHOD(nm),
 989                                                   fp,
 990                                                   argc,
 991                                                   SCM_METHOD(VAL0)->data);
 992                     RESTORE_REGS();
 993                     /* the func may substituted pc, so we need to check
 994                        if we can pop the continuation immediately. */
 995                     if (TAIL_POS()) RETURN_OP();
 996                 } else {
 997                     /* Scheme-defined method.  next-method arg is passed
 998                        as the last arg (note that rest arg is already
 999                        folded). */
1000                     PUSH_ARG(SCM_OBJ(nm));
1001                     FINISH_ENV(SCM_PROCEDURE_INFO(VAL0),
1002                                SCM_METHOD(VAL0)->env);
1003                     VM_ASSERT(SCM_COMPILED_CODE_P(SCM_METHOD(VAL0)->data));
1004                     vm->base = SCM_COMPILED_CODE(SCM_METHOD(VAL0)->data);
1005                     PC = vm->base->code;
1006                     CHECK_STACK(vm->base->maxstack);
1007                     SCM_PROF_COUNT_CALL(vm, SCM_OBJ(vm->base));
1008                 }
1009                 NEXT;
1010                 /*
1011                  * Error case (jumped from ADJUST_ARGUMENT_FRAME)
1012                  */
1013               wna:
1014                 VM_ERR(("wrong number of arguments for %S (required %d, got %d)",
1015                         VAL0, SCM_PROCEDURE_REQUIRED(VAL0), argc));
1016             }
1017             CASE(SCM_VM_JUMP) {
1018                 FETCH_LOCATION(PC);
1019                 NEXT;
1020             }
1021             CASE(SCM_VM_RET) {
1022                 RETURN_OP();
1023                 NEXT;
1024             }
1025             CASE(SCM_VM_RF) {
1026                 if (SCM_FALSEP(VAL0)) RETURN_OP();
1027                 NEXT;
1028             }
1029             CASE(SCM_VM_RT) {
1030                 if (!SCM_FALSEP(VAL0)) RETURN_OP();
1031                 NEXT;
1032             }
1033             CASE(SCM_VM_RNNULL) {
1034                 if (!SCM_NULLP(VAL0)) {
1035                     VAL0 = SCM_FALSE;
1036                     vm->numVals = 1;
1037                     RETURN_OP();
1038                 }
1039                 NEXT;
1040             }
1041             CASE(SCM_VM_RNEQ) {
1042                 ScmObj v;
1043                 POP_ARG(v);
1044                 if (!SCM_EQ(VAL0, v)) {
1045                     VAL0 = SCM_FALSE;
1046                     vm->numVals = 1;
1047                     RETURN_OP();
1048                 }
1049                 NEXT;
1050             }
1051             CASE(SCM_VM_RNEQV) {
1052                 ScmObj v;
1053                 POP_ARG(v);
1054                 if (!Scm_EqvP(VAL0, v)) {
1055                     VAL0 = SCM_FALSE;
1056                     vm->numVals = 1;
1057                     RETURN_OP();
1058                 }
1059                 NEXT;
1060             }
1061             CASE(SCM_VM_LREF0_PUSH_GREF) {
1062                 CHECK_STACK_PARANOIA(1);
1063                 PUSH_ARG(ENV_DATA(ENV,0));
1064                 goto gref;
1065             }
1066             CASE(SCM_VM_PUSH_GREF) {
1067                 CHECK_STACK_PARANOIA(1);
1068                 PUSH_ARG(VAL0);
1069             }
1070           gref:
1071             /*FALLTHROUGH*/
1072             CASE(SCM_VM_GREF) {
1073                 ScmObj v;
1074                 GLOBAL_REF(v);
1075                 VAL0 = v;
1076                 NEXT1;
1077             }
1078             CASE(SCM_VM_GREF_PUSH) {
1079                 ScmObj v;
1080                 GLOBAL_REF(v);
1081                 *SP++ = v;
1082                 NEXT;
1083             }
1084             CASE(SCM_VM_LREF0_PUSH_GREF_CALL) {
1085                 CHECK_STACK_PARANOIA(1);
1086                 PUSH_ARG(ENV_DATA(ENV,0));
1087                 goto gref_call;
1088             }
1089             CASE(SCM_VM_PUSH_GREF_CALL) {
1090                 CHECK_STACK_PARANOIA(1);
1091                 PUSH_ARG(VAL0);
1092             }
1093           gref_call:
1094             /*FALLTHROUGH*/
1095             CASE(SCM_VM_GREF_CALL) {
1096                 ScmObj v;
1097                 GLOBAL_REF(v);
1098                 VAL0 = v;
1099                 goto call_entry;
1100             }
1101             CASE(SCM_VM_LREF0_PUSH_GREF_TAIL_CALL) {
1102                 CHECK_STACK_PARANOIA(1);
1103                 PUSH_ARG(ENV_DATA(ENV,0));
1104                 goto gref_tail_call;
1105             }
1106             CASE(SCM_VM_PUSH_GREF_TAIL_CALL) {
1107                 CHECK_STACK_PARANOIA(1);
1108                 PUSH_ARG(VAL0);
1109             }
1110           gref_tail_call:
1111             /*FALLTHROUGH*/
1112             CASE(SCM_VM_GREF_TAIL_CALL) {
1113                 ScmObj v;
1114                 GLOBAL_REF(v);
1115                 VAL0 = v;
1116                 goto tail_call_entry;
1117             }
1118             CASE(SCM_VM_LREF0)  { VAL0 = ENV_DATA(ENV, 0); NEXT1; }
1119             CASE(SCM_VM_LREF1)  { VAL0 = ENV_DATA(ENV, 1); NEXT1; }
1120             CASE(SCM_VM_LREF2)  { VAL0 = ENV_DATA(ENV, 2); NEXT1; }
1121             CASE(SCM_VM_LREF3)  { VAL0 = ENV_DATA(ENV, 3); NEXT1; }
1122             CASE(SCM_VM_LREF10) { VAL0 = ENV_DATA(ENV->up, 0); NEXT1; }
1123             CASE(SCM_VM_LREF11) { VAL0 = ENV_DATA(ENV->up, 1); NEXT1; }
1124             CASE(SCM_VM_LREF12) { VAL0 = ENV_DATA(ENV->up, 2); NEXT1; }
1125             CASE(SCM_VM_LREF20) { VAL0 = ENV_DATA(ENV->up->up, 0);NEXT1; }
1126             CASE(SCM_VM_LREF21) { VAL0 = ENV_DATA(ENV->up->up, 1);NEXT1; }
1127             CASE(SCM_VM_LREF30) { VAL0 = ENV_DATA(ENV->up->up->up, 0);NEXT1; }
1128                 
1129             /*OB*/CASE(SCM_VM_LREF4) { VAL0 = ENV_DATA(ENV, 4); NEXT1; }
1130             /*OB*/CASE(SCM_VM_LREF13) { VAL0 = ENV_DATA(ENV->up, 3); NEXT1; }
1131             /*OB*/CASE(SCM_VM_LREF14) { VAL0 = ENV_DATA(ENV->up, 4); NEXT1; }
1132 
1133             CASE(SCM_VM_LREF) {
1134                 int dep = SCM_VM_INSN_ARG0(code);
1135                 int off = SCM_VM_INSN_ARG1(code);
1136                 ScmEnvFrame *e = ENV;
1137 
1138                 for (; dep > 0; dep--) {
1139                     VM_ASSERT(e != NULL);
1140                     e = e->up;
1141                 }
1142                 VM_ASSERT(e != NULL);
1143                 VM_ASSERT(e->size > off);
1144                 VAL0 = ENV_DATA(e, off);
1145                 NEXT1;
1146             }
1147             CASE(SCM_VM_LREF0_PUSH) {PUSH_ARG(ENV_DATA(ENV, 0)); NEXT;}
1148             CASE(SCM_VM_LREF1_PUSH) {PUSH_ARG(ENV_DATA(ENV, 1)); NEXT;}
1149             CASE(SCM_VM_LREF2_PUSH) {PUSH_ARG(ENV_DATA(ENV, 2)); NEXT;}
1150             CASE(SCM_VM_LREF3_PUSH) {PUSH_ARG(ENV_DATA(ENV, 3)); NEXT;}
1151             CASE(SCM_VM_LREF10_PUSH) {PUSH_ARG(ENV_DATA(ENV->up, 0)); NEXT;}
1152             CASE(SCM_VM_LREF11_PUSH) {PUSH_ARG(ENV_DATA(ENV->up, 1)); NEXT;}
1153             CASE(SCM_VM_LREF12_PUSH) {PUSH_ARG(ENV_DATA(ENV->up, 2)); NEXT;}
1154             CASE(SCM_VM_LREF20_PUSH) {PUSH_ARG(ENV_DATA(ENV->up->up, 0)); NEXT;}
1155             CASE(SCM_VM_LREF21_PUSH) {PUSH_ARG(ENV_DATA(ENV->up->up, 1)); NEXT;}
1156             CASE(SCM_VM_LREF30_PUSH) {PUSH_ARG(ENV_DATA(ENV->up->up->up, 0)); NEXT;}
1157 
1158             /*OB*/CASE(SCM_VM_LREF4_PUSH) {PUSH_ARG(ENV_DATA(ENV, 4)); NEXT;}
1159             /*OB*/CASE(SCM_VM_LREF13_PUSH) {
1160                 PUSH_ARG(ENV_DATA(ENV->up, 3)); NEXT;
1161             }
1162             /*OB*/CASE(SCM_VM_LREF14_PUSH) {
1163                 PUSH_ARG(ENV_DATA(ENV->up, 4)); NEXT;
1164             }
1165             CASE(SCM_VM_LREF_PUSH) {
1166                 int dep = SCM_VM_INSN_ARG0(code);
1167                 int off = SCM_VM_INSN_ARG1(code);
1168                 ScmEnvFrame *e = ENV;
1169 
1170                 for (; dep > 0; dep--) {
1171                     VM_ASSERT(e != NULL);
1172                     e = e->up;
1173                 }
1174                 VM_ASSERT(e != NULL);
1175                 VM_ASSERT(e->size > off);
1176                 PUSH_ARG(ENV_DATA(e, off));
1177                 NEXT;
1178             }
1179             CASE(SCM_VM_PUSH_LOCAL_ENV) {
1180                 CHECK_STACK_PARANOIA(1);
1181                 PUSH_ARG(VAL0);
1182             }
1183             /*FALLTHROGH*/
1184             CASE(SCM_VM_LOCAL_ENV) {
1185                 CHECK_STACK_PARANOIA(ENV_SIZE(0));
1186                 FINISH_ENV(SCM_FALSE, ENV);
1187                 NEXT;
1188             }
1189             CASE(SCM_VM_LOCAL_ENV_JUMP) {
1190                 int nargs = SP - ARGP;
1191                 int env_depth = SCM_VM_INSN_ARG(code);
1192                 ScmObj *to;
1193                 ScmEnvFrame *tenv = ENV;
1194                 /* We can discard env_depth environment frames.
1195                    There are several cases:
1196 
1197                    - if the target env frame (TENV) is in stack:
1198                    -- if the current cont frame is over TENV
1199                        => shift argframe on top of the current cont frame
1200                    -- otherwise => shift argframe on top of TENV
1201                    - if TENV is in heap:
1202                    -- if the current cont frame is in stack
1203                        => shift argframe on top of the current cont frame
1204                    -- otherwise => shift argframe at the stack base
1205                 */
1206                 while (env_depth-- > 0) {
1207                     SCM_ASSERT(tenv);
1208                     tenv = tenv->up;
1209                 }
1210                 if (IN_STACK_P((ScmObj*)tenv)) {
1211                     if (IN_STACK_P((ScmObj*)CONT)
1212                         && (ScmObj*)CONT > (ScmObj*)tenv) {
1213                         to = CONT_FRAME_END(CONT);
1214                     } else {
1215                         to = (ScmObj*)tenv + ENV_HDR_SIZE;
1216                     }
1217                 } else {
1218                     if (IN_STACK_P((ScmObj*)CONT)) {
1219                         to = CONT_FRAME_END(CONT);
1220                     } else {
1221                         /* continuation has been saved */
1222                         to = vm->stackBase;
1223                     }
1224                 }
1225                 if (nargs > 0 && to != ARGP) {
1226                     ScmObj *t = to, *a = ARGP;
1227                     int c;
1228                     for (c=0; c<nargs; c++) *t++ = *a++;                    
1229                 }
1230                 ARGP = to;
1231                 SP = to + nargs;
1232                 if (nargs > 0) {
1233                     FINISH_ENV(SCM_FALSE, tenv);
1234                 } else {
1235                     ENV = tenv;
1236                 }
1237                 FETCH_LOCATION(PC);
1238                 NEXT;
1239             }
1240             CASE(SCM_VM_LOCAL_ENV_TAIL_CALL) {
1241                 int nargs = SP - ARGP;
1242                 ScmObj *to;
1243                 VM_ASSERT(SCM_CLOSUREP(VAL0));
1244                 if (IN_STACK_P((ScmObj*)CONT)) {
1245                     to = CONT_FRAME_END(CONT);
1246                 } else {
1247                     to = vm->stackBase;
1248                 }
1249                 if (nargs > 0 && to != ARGP) {
1250                     ScmObj *t = to, *a = ARGP;
1251                     int c;
1252                     for (c=0; c<nargs; c++) *t++ = *a++;
1253                 }
1254                 ARGP = to;
1255                 SP = to + nargs;
1256             }
1257             /*FALLTHROUGH*/
1258             CASE(SCM_VM_LOCAL_ENV_CALL) {
1259                 int nargs = SP - ARGP;
1260                 VM_ASSERT(SCM_CLOSUREP(VAL0));
1261                 if (nargs > 0) {
1262                     CHECK_STACK_PARANOIA(ENV_SIZE(0));
1263                     FINISH_ENV(SCM_FALSE, SCM_CLOSURE(VAL0)->env);
1264                 } else {
1265                     ENV = SCM_CLOSURE(VAL0)->env;
1266                     ARGP = SP;
1267                 }
1268                 vm->base = SCM_COMPILED_CODE(SCM_CLOSURE(VAL0)->code);
1269                 PC = vm->base->code;
1270                 CHECK_STACK(vm->base->maxstack);
1271                 SCM_PROF_COUNT_CALL(vm, SCM_OBJ(vm->base));
1272                 NEXT;
1273             }
1274             CASE(SCM_VM_LOCAL_ENV_CLOSURES) {
1275                 int nlocals = SCM_VM_INSN_ARG(code);
1276                 ScmObj *z, cp, clo = SCM_UNDEFINED;
1277                 ScmEnvFrame *e;
1278                 
1279                 FETCH_OPERAND(cp);
1280                 INCR_PC;
1281                 CHECK_STACK_PARANOIA(ENV_SIZE(nlocals));
1282                 SP += nlocals;
1283                 FINISH_ENV(SCM_FALSE, ENV);
1284                 SAVE_REGS();
1285                 e = get_env(vm);
1286                 z = (ScmObj*)e - nlocals;
1287                 SCM_FOR_EACH(cp, cp) {
1288                     if (SCM_COMPILED_CODE_P(SCM_CAR(cp))) {
1289                         *z++ = clo = Scm_MakeClosure(SCM_CAR(cp), e);
1290                     } else {
1291                         *z++ = SCM_CAR(cp);
1292                     }
1293                 }
1294                 RESTORE_REGS();
1295                 VAL0 = clo;
1296                 NEXT1;
1297             }
1298             CASE(SCM_VM_POP_LOCAL_ENV) {
1299                 ENV = ENV->up;
1300                 NEXT;
1301             }
1302             CASE(SCM_VM_GSET) {
1303                 ScmObj loc;
1304                 FETCH_OPERAND(loc);
1305                 if (SCM_GLOCP(loc)) {
1306                     SCM_GLOC_SET(SCM_GLOC(loc), VAL0);
1307                 } else {
1308                     ScmGloc *gloc;
1309                     ScmIdentifier *id;
1310                     VM_ASSERT(SCM_IDENTIFIERP(loc));
1311                     id = SCM_IDENTIFIER(loc);
1312                     /* If runtime flag LIMIT_MODULE_MUTATION is set,
1313                        we search only for the id's module, so that set! won't
1314                        mutate bindings in the other module. */
1315                     gloc = Scm_FindBinding(id->module, id->name,
1316                                            SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_LIMIT_MODULE_MUTATION));
1317                     if (gloc == NULL) {
1318                         /* Do search again for meaningful error message */
1319                         if (SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_LIMIT_MODULE_MUTATION)) {
1320                             gloc = Scm_FindBinding(id->module, id->name, FALSE);
1321                             if (gloc != NULL) {
1322                                 VM_ERR(("can't mutate binding of %S, which is in another module",
1323                                         id->name));
1324                             }
1325                             /*FALLTHROUGH*/
1326                         }
1327                         VM_ERR(("symbol not defined: %S", loc));
1328                     }
1329                     SCM_GLOC_SET(gloc, VAL0);
1330                     /* memorize gloc */
1331                     /* TODO: make it MT safe! */
1332                     *PC = SCM_WORD(gloc);
1333                 }
1334                 INCR_PC;
1335                 NEXT1;
1336             }
1337             /*OB*/CASE(SCM_VM_LSET0) { ENV_DATA(ENV, 0) = VAL0; NEXT1; }
1338             /*OB*/CASE(SCM_VM_LSET1) { ENV_DATA(ENV, 1) = VAL0; NEXT1; }
1339             /*OB*/CASE(SCM_VM_LSET2) { ENV_DATA(ENV, 2) = VAL0; NEXT1; }
1340             /*OB*/CASE(SCM_VM_LSET3) { ENV_DATA(ENV, 3) = VAL0; NEXT1; }
1341             /*OB*/CASE(SCM_VM_LSET4) { ENV_DATA(ENV, 4) = VAL0; NEXT1; }
1342             CASE(SCM_VM_LSET) {
1343                 int dep = SCM_VM_INSN_ARG0(code);
1344                 int off = SCM_VM_INSN_ARG1(code);
1345                 ScmEnvFrame *e = ENV;
1346 
1347                 for (; dep > 0; dep--) {
1348                     VM_ASSERT(e != NULL);
1349                     e = e->up;
1350                 }
1351                 VM_ASSERT(e != NULL);
1352                 VM_ASSERT(e->size > off);
1353                 ENV_DATA(e, off) = VAL0;
1354                 NEXT1;
1355             }
1356             CASE(SCM_VM_NOP) {
1357                 NEXT;
1358             }
1359             CASE(SCM_VM_DEFINE) {
1360                 ScmObj var; ScmSymbol *name; int flags;
1361                 flags = SCM_VM_INSN_ARG(code);
1362                 FETCH_OPERAND(var);
1363                 VM_ASSERT(SCM_IDENTIFIERP(var));
1364                 INCR_PC;
1365                 if (flags == 0) {
1366                     Scm_Define(SCM_IDENTIFIER(var)->module,
1367                                (name = SCM_IDENTIFIER(var)->name), VAL0);
1368                 } else {
1369                     Scm_DefineConst(SCM_IDENTIFIER(var)->module,
1370                                     (name = SCM_IDENTIFIER(var)->name), VAL0);
1371                 }
1372                 VAL0 = SCM_OBJ(name);
1373                 NEXT1;
1374             }
1375             CASE(SCM_VM_BF) {
1376                 if (SCM_FALSEP(VAL0)) {
1377                     FETCH_LOCATION(PC);
1378                 } else {
1379                     INCR_PC;
1380                 }
1381                 NEXT;
1382             }
1383             CASE(SCM_VM_BT) {
1384                 if (!SCM_FALSEP(VAL0)) {
1385                     FETCH_LOCATION(PC);
1386                 } else {
1387                     INCR_PC;
1388                 }
1389                 NEXT;
1390             }
1391             CASE(SCM_VM_BNNULL) {
1392                 if (!SCM_NULLP(VAL0)) {
1393                     VAL0 = SCM_FALSE;
1394                     FETCH_LOCATION(PC);
1395                 } else {
1396                     VAL0 = SCM_TRUE;
1397                     INCR_PC;
1398                 }
1399                 NEXT1;
1400             }
1401             CASE(SCM_VM_BNEQ) {
1402                 ScmObj z;
1403                 POP_ARG(z);
1404                 if (!SCM_EQ(VAL0, z)) {
1405                     VAL0 = SCM_FALSE;
1406                     FETCH_LOCATION(PC);
1407                 } else {
1408                     VAL0 = SCM_TRUE;
1409                     INCR_PC;
1410                 }
1411                 NEXT1;
1412             }
1413             CASE(SCM_VM_BNEQC) {
1414                 ScmObj z;
1415                 FETCH_OPERAND(z);
1416                 INCR_PC;
1417                 if (!SCM_EQ(VAL0, z)) {
1418                     VAL0 = SCM_FALSE;
1419                     FETCH_LOCATION(PC);
1420                 } else {
1421                     VAL0 = SCM_TRUE;
1422                     INCR_PC;
1423                 }
1424                 NEXT1;
1425             }
1426             CASE(SCM_VM_BNEQV) {
1427                 ScmObj z;
1428                 POP_ARG(z);
1429                 if (!Scm_EqvP(VAL0, z)) {
1430                     VAL0 = SCM_FALSE;
1431                     FETCH_LOCATION(PC);
1432                 } else {
1433                     VAL0 = SCM_TRUE;
1434                     INCR_PC;
1435                 }
1436                 NEXT1;
1437             }
1438             CASE(SCM_VM_BNEQVC) {
1439                 ScmObj z;
1440                 FETCH_OPERAND(z);
1441                 INCR_PC;
1442                 if (!Scm_EqvP(VAL0, z)) {
1443                     VAL0 = SCM_FALSE;
1444                     FETCH_LOCATION(PC);
1445                 } else {
1446                     VAL0 = SCM_TRUE;
1447                     INCR_PC;
1448                 }
1449                 NEXT1;
1450             }
1451             CASE(SCM_VM_BNUMNE) {
1452                 ScmObj x, y = VAL0;
1453                 POP_ARG(x);
1454                 SAVE_REGS();
1455                 if (!Scm_NumEq(x, y)) {
1456                     VAL0 = SCM_FALSE;
1457                     FETCH_LOCATION(PC);
1458                 } else {
1459                     VAL0 = SCM_TRUE;
1460                     INCR_PC;
1461                 }
1462                 NEXT1;
1463             }
1464             CASE(SCM_VM_BNUMNEI) {
1465                 long imm = SCM_VM_INSN_ARG(code);
1466                 ScmObj v0 = VAL0;
1467                 if (!SCM_NUMBERP(v0)) {
1468                     VM_ERR(("Number required, but got %S", VAL0));
1469                 }
1470                 if ((SCM_INTP(v0) && SCM_INT_VALUE(v0) == imm)
1471                     || (SCM_FLONUMP(v0) && SCM_FLONUM_VALUE(v0) == imm)) {
1472                     VAL0 = SCM_TRUE;
1473                     INCR_PC;
1474                 } else {
1475                     VAL0 = SCM_FALSE;
1476                     FETCH_LOCATION(PC);
1477                 }
1478                 NEXT1;
1479             }
1480             CASE(SCM_VM_BNLT) {
1481                 int r;
1482                 NUM_CMP(<, r);
1483                 VAL0 = SCM_MAKE_BOOL(r);
1484                 if (r) INCR_PC;
1485                 else FETCH_LOCATION(PC);
1486                 NEXT1;
1487             }
1488             CASE(SCM_VM_BNLE) {
1489                 int r;
1490                 NUM_CMP(<=, r);
1491                 VAL0 = SCM_MAKE_BOOL(r);
1492                 if (r) INCR_PC;
1493                 else FETCH_LOCATION(PC);
1494                 NEXT1;
1495             }
1496             CASE(SCM_VM_BNGT) {
1497                 int r;
1498                 NUM_CMP(>, r);
1499                 VAL0 = SCM_MAKE_BOOL(r);
1500                 if (r) INCR_PC;
1501                 else FETCH_LOCATION(PC);
1502                 NEXT1;
1503             }
1504             CASE(SCM_VM_BNGE) {
1505                 int r;
1506                 NUM_CMP(>=, r);
1507                 VAL0 = SCM_MAKE_BOOL(r);
1508                 if (r) INCR_PC;
1509                 else FETCH_LOCATION(PC);
1510                 NEXT1;
1511             }
1512             CASE(SCM_VM_CLOSURE) {
1513                 ScmObj body;
1514                 FETCH_OPERAND(body);
1515                 INCR_PC;
1516 
1517                 /* preserve environment */
1518                 SAVE_REGS();
1519                 VAL0 = Scm_MakeClosure(body, get_env(vm));
1520                 RESTORE_REGS();
1521                 NEXT1;
1522             }
1523             CASE(SCM_VM_TAIL_RECEIVE) {
1524                 /*FALLTHROUGH*/
1525             }
1526             CASE(SCM_VM_RECEIVE) {
1527                 int reqargs = SCM_VM_INSN_ARG0(code);
1528                 int restarg = SCM_VM_INSN_ARG1(code);
1529                 int size, i = 0, argsize;
1530                 ScmObj rest = SCM_NIL, tail = SCM_NIL;
1531                 ScmWord *nextpc;
1532 
1533                 if (vm->numVals < reqargs) {
1534                     VM_ERR(("received fewer values than expected"));
1535                 } else if (!restarg && vm->numVals > reqargs) {
1536                     VM_ERR(("received more values than expected"));
1537                 }
1538                 argsize = reqargs + (restarg? 1 : 0);
1539 
1540                 if (SCM_VM_INSN_CODE(code) == SCM_VM_RECEIVE) {
1541                     size = CONT_FRAME_SIZE + ENV_SIZE(reqargs + restarg);
1542                     CHECK_STACK_PARANOIA(size);
1543                     FETCH_LOCATION(nextpc);
1544                     INCR_PC;
1545                     PUSH_CONT(nextpc);
1546                 } else {
1547                     size = ENV_SIZE(reqargs + restarg);
1548                 }
1549 
1550                 if (reqargs > 0) {
1551                     PUSH_ARG(VAL0);
1552                     i++;
1553                 } else if (restarg && vm->numVals > 0) {
1554                     SCM_APPEND1(rest, tail, VAL0);
1555                     i++;
1556                 }
1557                 for (; i < reqargs; i++) {
1558                     PUSH_ARG(vm->vals[i-1]);
1559                 }
1560                 if (restarg) {
1561                     for (; i < vm->numVals; i++) {
1562                         SCM_APPEND1(rest, tail, vm->vals[i-1]);
1563                     }
1564                     PUSH_ARG(rest);
1565                 }
1566                 FINISH_ENV(SCM_FALSE, ENV);
1567                 NEXT1;
1568             }
1569             /* fixed constants */
1570             CASE(SCM_VM_CONSTI) {
1571                 long imm = SCM_VM_INSN_ARG(code);
1572                 VAL0 = SCM_MAKE_INT(imm);
1573                 NEXT1;
1574             }
1575             CASE(SCM_VM_CONSTN) {
1576                 VAL0 = SCM_NIL;
1577                 NEXT1;
1578             }
1579             CASE(SCM_VM_CONSTF) {
1580                 VAL0 = SCM_FALSE;
1581                 NEXT1;
1582             }
1583             CASE(SCM_VM_CONSTU) {
1584                 VAL0 = SCM_UNDEFINED;
1585                 NEXT1;
1586             }
1587             CASE(SCM_VM_CONSTI_PUSH) {
1588                 long imm = SCM_VM_INSN_ARG(code);
1589                 PUSH_ARG(SCM_MAKE_INT(imm));
1590                 NEXT;
1591             }
1592             CASE(SCM_VM_CONSTN_PUSH) {
1593                 PUSH_ARG(SCM_NIL);
1594                 NEXT;
1595             }
1596             CASE(SCM_VM_CONSTF_PUSH) {
1597                 PUSH_ARG(SCM_FALSE);
1598                 NEXT;
1599             }
1600             CASE(SCM_VM_CONST_RET) {
1601                 FETCH_OPERAND(VAL0);
1602                 vm->numVals = 1;
1603                 RETURN_OP();
1604                 NEXT;
1605             }
1606             CASE(SCM_VM_CONSTF_RET) {
1607                 VAL0 = SCM_FALSE;
1608                 vm->numVals = 1;
1609                 RETURN_OP();
1610                 NEXT;
1611             }
1612             CASE(SCM_VM_CONSTU_RET) {
1613                 VAL0 = SCM_UNDEFINED;
1614                 vm->numVals = 1;
1615                 RETURN_OP();
1616                 NEXT;
1617             }
1618 
1619             /* Inlined procedures */
1620             CASE(SCM_VM_CONS) {
1621                 ScmObj ca;
1622                 POP_ARG(ca);
1623                 SAVE_REGS();
1624                 VAL0 = Scm_Cons(ca, VAL0);
1625                 NEXT1;
1626             }
1627             CASE(SCM_VM_CONS_PUSH) {
1628                 ScmObj ca;
1629                 POP_ARG(ca);
1630                 SAVE_REGS();
1631                 VAL0 = Scm_Cons(ca, VAL0);
1632                 PUSH_ARG(VAL0);
1633                 NEXT;
1634             }
1635             CASE(SCM_VM_CAR) {
1636                 if (!SCM_PAIRP(VAL0)) {
1637                     VM_ERR(("pair required, but got %S", VAL0));
1638                 }
1639                 VAL0 = SCM_CAR(VAL0);
1640                 NEXT1;
1641             }
1642             CASE(SCM_VM_CAR_PUSH) {
1643                 ScmObj obj = VAL0;
1644                 if (!SCM_PAIRP(obj)) {
1645                     VM_ERR(("pair required, but got %S", obj));
1646                 }
1647                 obj = SCM_CAR(obj);
1648                 PUSH_ARG(obj);
1649                 NEXT;
1650             }
1651             CASE(SCM_VM_CDR) {
1652                 if (!SCM_PAIRP(VAL0)) {
1653                     VM_ERR(("pair required, but got %S", VAL0));
1654                 }
1655                 VAL0 = SCM_CDR(VAL0);
1656                 NEXT1;
1657             }
1658             CASE(SCM_VM_CDR_PUSH) {
1659                 ScmObj obj = VAL0;
1660                 if (!SCM_PAIRP(obj)) {
1661                     VM_ERR(("pair required, but got %S", obj));
1662                 }
1663                 obj = SCM_CDR(obj);
1664                 PUSH_ARG(obj);
1665                 NEXT;
1666             }
1667             CASE(SCM_VM_CAAR) {
1668                 ScmObj obj = VAL0;
1669                 if (!SCM_PAIRP(obj)) {
1670                     VM_ERR(("pair required, but got %S", obj));
1671                 }
1672                 obj = SCM_CAR(obj);
1673                 if (!SCM_PAIRP(obj)) {
1674                     VM_ERR(("pair required, but got %S", obj));
1675                 }
1676                 VAL0 = SCM_CAR(obj);
1677                 NEXT1;
1678             }
1679             CASE(SCM_VM_CAAR_PUSH) {
1680                 ScmObj obj = VAL0;
1681                 if (!SCM_PAIRP(obj)) {
1682                     VM_ERR(("pair required, but got %S", obj));
1683                 }
1684                 obj = SCM_CAR(obj);
1685                 if (!SCM_PAIRP(obj)) {
1686                     VM_ERR(("pair required, but got %S", obj));
1687                 }
1688                 obj = SCM_CAR(obj);
1689                 PUSH_ARG(obj);
1690                 NEXT;
1691             }
1692             CASE(SCM_VM_CADR) {
1693                 ScmObj obj = VAL0;
1694                 if (!SCM_PAIRP(obj)) {
1695                     VM_ERR(("pair required, but got %S", obj));
1696                 }
1697                 obj = SCM_CDR(obj);
1698                 if (!SCM_PAIRP(obj)) {
1699                     VM_ERR(("pair required, but got %S", obj));
1700                 }
1701                 VAL0 = SCM_CAR(obj);
1702                 NEXT1;
1703             }
1704             CASE(SCM_VM_CADR_PUSH) {
1705                 ScmObj obj = VAL0;
1706                 if (!SCM_PAIRP(obj)) {
1707                     VM_ERR(("pair required, but got %S", obj));
1708                 }
1709                 obj = SCM_CDR(obj);
1710                 if (!SCM_PAIRP(obj)) {
1711                     VM_ERR(("pair required, but got %S", obj));
1712                 }
1713                 obj = SCM_CAR(obj);
1714                 PUSH_ARG(obj);
1715                 NEXT;
1716             }
1717             CASE(SCM_VM_CDAR) {
1718                 ScmObj obj = VAL0;
1719                 if (!SCM_PAIRP(obj)) {
1720                     VM_ERR(("pair required, but got %S", obj));
1721                 }
1722                 obj = SCM_CAR(obj);
1723                 if (!SCM_PAIRP(obj)) {
1724                     VM_ERR(("pair required, but got %S", obj));
1725                 }
1726                 VAL0 = SCM_CDR(obj);
1727                 NEXT1;
1728             }
1729             CASE(SCM_VM_CDAR_PUSH) {
1730                 ScmObj obj = VAL0;
1731                 if (!SCM_PAIRP(obj)) {
1732                     VM_ERR(("pair required, but got %S", obj));
1733                 }
1734                 obj = SCM_CAR(obj);
1735                 if (!SCM_PAIRP(obj)) {
1736                     VM_ERR(("pair required, but got %S", obj));
1737                 }
1738                 obj = SCM_CDR(obj);
1739                 PUSH_ARG(obj);
1740                 NEXT;
1741             }
1742             CASE(SCM_VM_CDDR) {
1743                 ScmObj obj = VAL0;
1744                 if (!SCM_PAIRP(obj)) {
1745                     VM_ERR(("pair required, but got %S", obj));
1746                 }
1747                 obj = SCM_CDR(obj);
1748                 if (!SCM_PAIRP(obj)) {
1749                     VM_ERR(("pair required, but got %S", obj));
1750                 }
1751                 VAL0 = SCM_CDR(obj);
1752                 NEXT1;
1753             }
1754             CASE(SCM_VM_CDDR_PUSH) {
1755                 ScmObj obj = VAL0;
1756                 if (!SCM_PAIRP(obj)) {
1757                     VM_ERR(("pair required, but got %S", obj));
1758                 }
1759                 obj = SCM_CDR(obj);
1760                 if (!SCM_PAIRP(obj)) {
1761                     VM_ERR(("pair required, but got %S", obj));
1762                 }
1763                 obj = SCM_CDR(obj);
1764                 PUSH_ARG(obj);
1765                 NEXT;
1766             }
1767             CASE(SCM_VM_LIST) {
1768                 int nargs = SCM_VM_INSN_ARG(code);
1769                 ScmObj cp = SCM_NIL;
1770                 if (nargs > 0) {
1771                     ScmObj arg;
1772                     SAVE_REGS();
1773                     cp = Scm_Cons(VAL0, cp);
1774                     while (--nargs > 0) {
1775                         POP_ARG(arg);
1776                         SAVE_REGS();
1777                         cp = Scm_Cons(arg, cp);
1778                     }
1779                 }
1780                 VAL0 = cp;
1781                 NEXT1;
1782             }
1783             CASE(SCM_VM_LIST_STAR) {
1784                 int nargs = SCM_VM_INSN_ARG(code);
1785                 ScmObj cp = SCM_NIL;
1786                 if (nargs > 0) {
1787                     ScmObj arg;
1788                     cp = VAL0;
1789                     while (--nargs > 0) {
1790                         POP_ARG(arg);
1791                         SAVE_REGS();
1792                         cp = Scm_Cons(arg, cp);
1793                     }
1794                 }
1795                 VAL0 = cp;
1796                 NEXT1;
1797             }
1798             CASE(SCM_VM_LIST2VEC) {
1799                 SAVE_REGS();
1800                 VAL0 = Scm_ListToVector(VAL0, 0, -1);
1801                 vm->numVals = 1;
1802                 RESTORE_REGS();
1803                 NEXT1;
1804             }
1805             CASE(SCM_VM_LENGTH) {
1806                 int len = Scm_Length(VAL0);
1807                 if (len < 0) {
1808                     VM_ERR(("proper list required, but got %S", VAL0));
1809                 }
1810                 VAL0 = SCM_MAKE_INT(len);
1811                 NEXT1;
1812             }
1813             CASE(SCM_VM_NOT) {
1814                 VAL0 = SCM_MAKE_BOOL(SCM_FALSEP(VAL0));
1815                 NEXT1;
1816             }
1817             CASE(SCM_VM_NULLP) {
1818                 VAL0 = SCM_MAKE_BOOL(SCM_NULLP(VAL0));
1819                 NEXT1;
1820             }
1821             CASE(SCM_VM_EQ) {
1822                 ScmObj item;
1823                 POP_ARG(item);
1824                 VAL0 = SCM_MAKE_BOOL(SCM_EQ(item, VAL0));
1825                 NEXT1;
1826             }
1827             CASE(SCM_VM_EQV) {
1828                 ScmObj item;
1829                 POP_ARG(item);
1830                 SAVE_REGS();
1831                 VAL0 = SCM_MAKE_BOOL(Scm_EqvP(item, VAL0));
1832                 NEXT1;
1833             }
1834             CASE(SCM_VM_MEMQ) {
1835                 ScmObj item;
1836                 POP_ARG(item);
1837                 SAVE_REGS();
1838                 VAL0 = Scm_Memq(item, VAL0);
1839                 NEXT1;
1840             }
1841             CASE(SCM_VM_MEMV) {
1842                 ScmObj item;
1843                 POP_ARG(item);
1844                 SAVE_REGS();
1845                 VAL0 = Scm_Memv(item, VAL0);
1846                 NEXT1;
1847             }
1848             CASE(SCM_VM_ASSQ) {
1849                 ScmObj item;
1850                 POP_ARG(item);
1851                 SAVE_REGS();
1852                 VAL0 = Scm_Assq(item, VAL0);
1853                 NEXT1;
1854             }
1855             CASE(SCM_VM_ASSV) {
1856                 ScmObj item;
1857                 POP_ARG(item);
1858                 SAVE_REGS();
1859                 VAL0 = Scm_Assv(item, VAL0);
1860                 NEXT1;
1861             }
1862             CASE(SCM_VM_IS_A) {
1863                 ScmObj obj;
1864                 ScmClass *c;
1865                 POP_ARG(obj);
1866                 if (!SCM_CLASSP(VAL0))
1867                     VM_ERR(("class required, but got %S\n", VAL0));
1868                 c = SCM_CLASS(VAL0);
1869                 /* be careful to handle class redifinition case */
1870                 if (!SCM_FALSEP(Scm_ClassOf(obj)->redefined)) {
1871                     CHECK_STACK(CONT_FRAME_SIZE);
1872                     PUSH_CONT(PC);
1873                     PC = PC_TO_RETURN;
1874                     SAVE_REGS();
1875                     VAL0 = Scm_VMIsA(obj, c);
1876                     RESTORE_REGS();
1877                 } else {
1878                     SAVE_REGS();
1879                     VAL0 = SCM_MAKE_BOOL(SCM_ISA(obj, c));
1880                     RESTORE_REGS();
1881                 }
1882                 NEXT1;
1883             }
1884             CASE(SCM_VM_PAIRP) {
1885                 VAL0 = SCM_MAKE_BOOL(SCM_PAIRP(VAL0));
1886                 NEXT1;
1887             }
1888             CASE(SCM_VM_CHARP) {
1889                 VAL0 = SCM_MAKE_BOOL(SCM_CHARP(VAL0));
1890                 NEXT1;
1891             }
1892             CASE(SCM_VM_EOFP) {
1893                 VAL0 = SCM_MAKE_BOOL(SCM_EOFP(VAL0));
1894                 NEXT1;
1895             }
1896             CASE(SCM_VM_STRINGP) {
1897                 VAL0 = SCM_MAKE_BOOL(SCM_STRINGP(VAL0));
1898                 NEXT1;
1899             }
1900             CASE(SCM_VM_SYMBOLP) {
1901                 VAL0 = SCM_MAKE_BOOL(SCM_SYMBOLP(VAL0));
1902                 NEXT1;
1903             }
1904             CASE(SCM_VM_VECTORP) {
1905                 VAL0 = SCM_MAKE_BOOL(SCM_VECTORP(VAL0));
1906                 NEXT1;
1907             }
1908             CASE(SCM_VM_IDENTIFIERP) {
1909                 VAL0 = SCM_MAKE_BOOL(SCM_IDENTIFIERP(VAL0));
1910                 NEXT1;
1911             }
1912             CASE(SCM_VM_APPEND) {
1913                 int nargs = SCM_VM_INSN_ARG(code);
1914                 ScmObj cp = SCM_NIL, arg;
1915                 if (nargs > 0) {
1916                     cp = VAL0;
1917                     while (--nargs > 0) {
1918                         POP_ARG(arg);
1919                         SAVE_REGS();
1920                         if (Scm_Length(arg) < 0)
1921                             VM_ERR(("list required, but got %S\n", arg));
1922                         cp = Scm_Append2(arg, cp);
1923                     }
1924                 }
1925                 VAL0 = cp;
1926                 NEXT1;
1927             }
1928             CASE(SCM_VM_REVERSE) {
1929                 SAVE_REGS();
1930                 VAL0 = Scm_Reverse(VAL0);
1931                 RESTORE_REGS();
1932                 NEXT1;
1933             }
1934             CASE(SCM_VM_TAIL_APPLY) {
1935                 /*FALLTHROUGH*/
1936             }
1937             CASE(SCM_VM_APPLY) {
1938                 int nargs = SCM_VM_INSN_ARG(code);
1939                 ScmObj cp;
1940                 while (--nargs > 1) {
1941                     POP_ARG(cp);
1942                     SAVE_REGS();
1943                     VAL0 = Scm_Cons(cp, VAL0);
1944                 }
1945                 cp = VAL0;     /* now cp has arg list */
1946                 POP_ARG(VAL0); /* get proc */
1947 
1948                 if (SCM_VM_INSN_CODE(code) == SCM_VM_APPLY) {
1949                     CHECK_STACK(CONT_FRAME_SIZE);
1950                     PUSH_CONT(PC);
1951                 }
1952                 PC = PC_TO_RETURN;
1953 
1954                 SAVE_REGS();
1955                 VAL0 = Scm_VMApply(VAL0, cp);
1956                 RESTORE_REGS();
1957                 NEXT1;
1958             }
1959             CASE(SCM_VM_CONST_APPLY) {
1960                 int nargs = SCM_VM_INSN_ARG(code);
1961                 ScmObj form, cp;
1962                 CHECK_STACK(ENV_SIZE(nargs));
1963                 FETCH_OPERAND(form);
1964                 INCR_PC;
1965 
1966                 SCM_FOR_EACH(cp, SCM_CDR(form)) {
1967                     PUSH_ARG(SCM_CAR(cp));
1968                 }
1969                 VAL0 = SCM_CAR(form); /* proc */
1970                 goto tail_call_entry;
1971             }
1972             CASE(SCM_VM_PROMISE) {
1973                 SAVE_REGS();
1974                 VAL0 = Scm_MakePromise(FALSE, VAL0);
1975                 NEXT1;
1976             }
1977             CASE(SCM_VM_SETTER) {
1978                 SAVE_REGS();
1979                 VAL0 = Scm_Setter(VAL0);
1980                 NEXT1;
1981             }
1982             CASE(SCM_VM_VALUES) {
1983                 int nargs = SCM_VM_INSN_ARG(code), i;
1984                 if (nargs >= SCM_VM_MAX_VALUES)
1985                     VM_ERR(("values got too many args"));
1986                 VM_ASSERT(nargs -1 <= SP - vm->stackBase);
1987                 if (nargs > 0) {
1988                     for (i = nargs-1; i>0; i--) {
1989                         vm->vals[i-1] = VAL0;
1990                         POP_ARG(VAL0);
1991                     }
1992                 }
1993                 vm->numVals = nargs;
1994                 NEXT;
1995             }
1996             CASE(SCM_VM_VEC) {
1997                 int nargs = SCM_VM_INSN_ARG(code), i;
1998                 ScmObj vec;
1999                 SAVE_REGS();
2000                 vec = Scm_MakeVector(nargs, SCM_UNDEFINED);
2001                 if (nargs > 0) {
2002                     ScmObj arg = VAL0;
2003                     for (i=nargs-1; i > 0; i--) {
2004                         SCM_VECTOR_ELEMENT(vec, i) = arg;
2005                         POP_ARG(arg);
2006                     }
2007                     SCM_VECTOR_ELEMENT(vec, 0) = arg;
2008                 }
2009                 VAL0 = vec;
2010                 NEXT1;
2011             }
2012             CASE(SCM_VM_APP_VEC) {
2013                 int nargs = SCM_VM_INSN_ARG(code);
2014                 ScmObj cp = SCM_NIL, arg;
2015                 if (nargs > 0) {
2016                     cp = VAL0;
2017                     while (--nargs > 0) {
2018                         POP_ARG(arg);
2019                         SAVE_REGS();
2020                         if (Scm_Length(arg) < 0)
2021                             VM_ERR(("list required, but got %S\n", arg));
2022                         cp = Scm_Append2(arg, cp);
2023                     }
2024                 }
2025                 SAVE_REGS();
2026                 VAL0 = Scm_ListToVector(cp, 0, -1);
2027                 NEXT1;
2028             }
2029             CASE(SCM_VM_VEC_LEN) {
2030                 int siz;
2031                 if (!SCM_VECTORP(VAL0))
2032                     VM_ERR(("vector expected, but got %S\n", VAL0));
2033                 siz = SCM_VECTOR_SIZE(VAL0);
2034                 VAL0 = SCM_MAKE_INT(siz);
2035                 NEXT1;
2036             }
2037             CASE(SCM_VM_VEC_REF) {
2038                 ScmObj vec;
2039                 int k;
2040                 POP_ARG(vec);
2041                 if (!SCM_VECTORP(vec))
2042                     VM_ERR(("vector expected, but got %S\n", vec));
2043                 if (!SCM_INTP(VAL0))
2044                     VM_ERR(("integer expected, but got %S\n", VAL0));
2045                 k = SCM_INT_VALUE(VAL0);
2046                 if (k < 0 || k >= SCM_VECTOR_SIZE(vec))
2047                     VM_ERR(("index out of range: %d\n", k));
2048                 VAL0 = SCM_VECTOR_ELEMENT(vec, k);
2049                 NEXT1;
2050             }
2051             CASE(SCM_VM_VEC_REFI) {
2052                 ScmObj vec = VAL0;
2053                 int k = SCM_VM_INSN_ARG(code);
2054                 if (!SCM_VECTORP(vec))
2055                     VM_ERR(("vector expected, but got %S\n", vec));
2056                 if (k < 0 || k >= SCM_VECTOR_SIZE(vec))
2057                     VM_ERR(("index out of range: %d\n", k));
2058                 VAL0 = SCM_VECTOR_ELEMENT(vec, k);
2059                 NEXT1;
2060             }
2061             CASE(SCM_VM_VEC_SET) {
2062                 ScmObj vec, ind;
2063                 int k;
2064                 POP_ARG(ind);
2065                 POP_ARG(vec);
2066                 if (!SCM_VECTORP(vec))
2067                     VM_ERR(("vector expected, but got %S\n", vec));
2068                 if (!SCM_INTP(ind))
2069                     VM_ERR(("integer expected, but got %S\n", ind));
2070                 k = SCM_INT_VALUE(ind);
2071                 if (k < 0 || k >= SCM_VECTOR_SIZE(vec))
2072                     VM_ERR(("index out of range: %d\n", k));
2073                 SCM_VECTOR_ELEMENT(vec, k) = VAL0;
2074                 VAL0 = SCM_UNDEFINED;
2075                 NEXT1;
2076             }
2077             CASE(SCM_VM_VEC_SETI) {
2078                 ScmObj vec;
2079                 int k = SCM_VM_INSN_ARG(code);
2080                 POP_ARG(vec);
2081                 if (!SCM_VECTORP(vec))
2082                     VM_ERR(("vector expected, but got %S\n", vec));
2083                 if (k < 0 || k >= SCM_VECTOR_SIZE(vec))
2084                     VM_ERR(("index out of range: %d\n", k));
2085                 SCM_VECTOR_ELEMENT(vec, k) = VAL0;
2086                 VAL0 = SCM_UNDEFINED;
2087                 NEXT1;
2088             }
2089             CASE(SCM_VM_NUMEQ2) {
2090                 ScmObj arg;
2091                 POP_ARG(arg);
2092                 if (SCM_INTP(VAL0) && SCM_INTP(arg)) {
2093                     VAL0 = SCM_MAKE_BOOL(VAL0 == arg);
2094                 } else if (SCM_FLONUMP(VAL0) && SCM_FLONUMP(arg)) {
2095                     VAL0 = SCM_MAKE_BOOL(SCM_FLONUM_VALUE(VAL0) ==
2096                                          SCM_FLONUM_VALUE(arg));
2097                 } else {
2098                     SAVE_REGS();
2099                     VAL0 = SCM_MAKE_BOOL(Scm_NumEq(arg, VAL0));
2100                     RESTORE_REGS();
2101                 }
2102                 NEXT1;
2103             }
2104             CASE(SCM_VM_NUMLT2) {
2105                 int r;
2106                 NUM_CMP(<, r);
2107                 vm->numVals = 1;
2108                 VAL0 = SCM_MAKE_BOOL(r);
2109                 NEXT1;
2110             }
2111             CASE(SCM_VM_NUMLE2) {
2112                 int r;
2113                 NUM_CMP(<=, r);
2114                 vm->numVals = 1;
2115                 VAL0 = SCM_MAKE_BOOL(r);
2116                 NEXT1;
2117             }
2118             CASE(SCM_VM_NUMGT2) {
2119                 int r;
2120                 NUM_CMP(>, r);
2121                 vm->numVals = 1;
2122                 VAL0 = SCM_MAKE_BOOL(r);
2123                 NEXT1;
2124             }
2125             CASE(SCM_VM_NUMGE2) {
2126                 int r;
2127                 NUM_CMP(>=, r);
2128                 vm->numVals = 1;
2129                 VAL0 = SCM_MAKE_BOOL(r);
2130                 NEXT1;
2131             }
2132             CASE(SCM_VM_NUMADD2) {
2133                 ScmObj arg;
2134                 POP_ARG(arg);
2135                 if (SCM_INTP(arg) && SCM_INTP(VAL0)) {
2136                     long r = SCM_INT_VALUE(arg) + SCM_INT_VALUE(VAL0);
2137                     if (SCM_SMALL_INT_FITS(r)) {
2138                         VAL0 = SCM_MAKE_INT(r);
2139                     } else {
2140                         VAL0 = Scm_MakeInteger(r);
2141                     }
2142                 } else {
2143                     SAVE_REGS();
2144                     VAL0 = Scm_Add(arg, VAL0, SCM_NIL);
2145                     RESTORE_REGS();
2146                 }
2147                 NEXT1;
2148             }
2149             CASE(SCM_VM_NUMSUB2) {
2150                 ScmObj arg;
2151                 POP_ARG(arg);
2152                 if (SCM_INTP(arg) && SCM_INTP(VAL0)) {
2153                     long r = SCM_INT_VALUE(arg) - SCM_INT_VALUE(VAL0);
2154                     if (SCM_SMALL_INT_FITS(r)) {
2155                         VAL0 = SCM_MAKE_INT(r);
2156                     } else {
2157                         VAL0 = Scm_MakeInteger(r);
2158                     }
2159                 } else {
2160                     SAVE_REGS();
2161                     VAL0 = Scm_Subtract(arg, VAL0, SCM_NIL);
2162                     RESTORE_REGS();
2163                 }
2164                 NEXT1;
2165             }
2166             CASE(SCM_VM_NUMMUL2) {
2167                 ScmObj arg;
2168                 POP_ARG(arg);
2169                 /* we take a shortcut if either one is flonum and the
2170                    other is real.  (if both are integers, the overflow check
2171                    would be cumbersome so we just call Scm_Multiply). */
2172                 if ((SCM_FLONUMP(arg) && SCM_REALP(VAL0))
2173                     ||(SCM_FLONUMP(VAL0) && SCM_REALP(arg))) {
2174                     VAL0 = Scm_MakeFlonum(Scm_GetDouble(arg)*Scm_GetDouble(VAL0));
2175                 } else {
2176                     SAVE_REGS();
2177                     VAL0 = Scm_Multiply(arg, VAL0, SCM_NIL);
2178                     RESTORE_REGS();
2179                 }
2180                 NEXT1;
2181             }
2182             CASE(SCM_VM_NUMDIV2) {
2183                 ScmObj arg;
2184                 POP_ARG(arg);
2185                 /* we take a shortcut if either one is flonum and the
2186                    other is real. */
2187                 if ((SCM_FLONUMP(arg) && SCM_REALP(VAL0))
2188                     ||(SCM_FLONUMP(VAL0) && SCM_REALP(arg))) {
2189                     VAL0 = Scm_MakeFlonum(Scm_GetDouble(arg)/Scm_GetDouble(VAL0));
2190                 } else {
2191                     SAVE_REGS();
2192                     VAL0 = Scm_Divide(arg, VAL0, SCM_NIL);
2193                     RESTORE_REGS();
2194                 }
2195                 NEXT1;
2196             }
2197             CASE(SCM_VM_NEGATE) {
2198                 ScmObj v = VAL0;
2199                 if (SCM_INTP(v)) {
2200                     long r = -SCM_INT_VALUE(v);
2201                     if (SCM_SMALL_INT_FITS(r)) {
2202                         VAL0 = SCM_MAKE_INT(r);
2203                     } else {
2204                         VAL0 = Scm_MakeInteger(r);
2205                     }
2206                 } else if (SCM_FLONUMP(v)) {
2207                     VAL0 = Scm_MakeFlonum(-Scm_GetDouble(v));
2208                 } else {
2209                     SAVE_REGS();
2210                     VAL0 = Scm_Negate(v);
2211                     RESTORE_REGS();
2212                 }
2213                 NEXT1;
2214             }
2215             CASE(SCM_VM_NUMADDI) {
2216                 long imm = SCM_VM_INSN_ARG(code);
2217                 if (SCM_INTP(VAL0)) {
2218                     imm += SCM_INT_VALUE(VAL0);
2219                     if (SCM_SMALL_INT_FITS(imm)) {
2220                         VAL0 = SCM_MAKE_INT(imm);
2221                     } else {
2222                         SAVE_REGS();
2223                         VAL0 = Scm_MakeInteger(imm);
2224                     }
2225                 } else {
2226                     SAVE_REGS();
2227                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), VAL0, SCM_NIL);
2228                     RESTORE_REGS();
2229                 }
2230                 NEXT1;
2231             }
2232 #if 0
2233             CASE(SCM_VM_LREF0_NUMADDI) {
2234                 long imm = SCM_VM_INSN_ARG(code);
2235                 ScmObj val = ENV_DATA(ENV, 0);
2236                 if (SCM_INTP(val)) {
2237                     imm += SCM_INT_VALUE(val);
2238                     if (SCM_SMALL_INT_FITS(imm)) {
2239                         VAL0 = SCM_MAKE_INT(imm);
2240                     } else {
2241                         SAVE_REGS();
2242                         VAL0 = Scm_MakeInteger(imm);
2243                     }
2244                 } else {
2245                     SAVE_REGS();
2246                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), val, SCM_NIL);
2247                     RESTORE_REGS();
2248                 }
2249                 NEXT1;
2250             }
2251             CASE(SCM_VM_LREF1_NUMADDI) {
2252                 long imm = SCM_VM_INSN_ARG(code);
2253                 ScmObj val = ENV_DATA(ENV, 1);
2254                 if (SCM_INTP(val)) {
2255                     imm += SCM_INT_VALUE(val);
2256                     if (SCM_SMALL_INT_FITS(imm)) {
2257                         VAL0 = SCM_MAKE_INT(imm);
2258                     } else {
2259                         SAVE_REGS();
2260                         VAL0 = Scm_MakeInteger(imm);
2261                     }
2262                 } else {
2263                     SAVE_REGS();
2264                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), val, SCM_NIL);
2265                     RESTORE_REGS();
2266                 }
2267                 NEXT1;
2268             }
2269             CASE(SCM_VM_LREF2_NUMADDI) {
2270                 long imm = SCM_VM_INSN_ARG(code);
2271                 ScmObj val = ENV_DATA(ENV, 2);
2272                 if (SCM_INTP(val)) {
2273                     imm += SCM_INT_VALUE(val);
2274                     if (SCM_SMALL_INT_FITS(imm)) {
2275                         VAL0 = SCM_MAKE_INT(imm);
2276                     } else {
2277                         SAVE_REGS();
2278                         VAL0 = Scm_MakeInteger(imm);
2279                     }
2280                 } else {
2281                     SAVE_REGS();
2282                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), val, SCM_NIL);
2283                     RESTORE_REGS();
2284                 }
2285                 NEXT1;
2286             }
2287             CASE(SCM_VM_LREF3_NUMADDI) {
2288                 long imm = SCM_VM_INSN_ARG(code);
2289                 ScmObj val = ENV_DATA(ENV, 3);
2290                 if (SCM_INTP(val)) {
2291                     imm += SCM_INT_VALUE(val);
2292                     if (SCM_SMALL_INT_FITS(imm)) {
2293                         VAL0 = SCM_MAKE_INT(imm);
2294                     } else {
2295                         SAVE_REGS();
2296                         VAL0 = Scm_MakeInteger(imm);
2297                     }
2298                 } else {
2299                     SAVE_REGS();
2300                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), val, SCM_NIL);
2301                     RESTORE_REGS();
2302                 }
2303                 NEXT1;
2304             }
2305             CASE(SCM_VM_LREF4_NUMADDI) {
2306                 long imm = SCM_VM_INSN_ARG(code);
2307                 ScmObj val = ENV_DATA(ENV, 4);
2308                 if (SCM_INTP(val)) {
2309                     imm += SCM_INT_VALUE(val);
2310                     if (SCM_SMALL_INT_FITS(imm)) {
2311                         VAL0 = SCM_MAKE_INT(imm);
2312                     } else {
2313                         SAVE_REGS();
2314                         VAL0 = Scm_MakeInteger(imm);
2315                     }
2316                 } else {
2317                     SAVE_REGS();
2318                     VAL0 = Scm_Add(SCM_MAKE_INT(imm), val, SCM_NIL);
2319                     RESTORE_REGS();
2320                 }
2321                 NEXT1;
2322             }
2323 #endif /* 0 */
2324             CASE(SCM_VM_NUMSUBI) {
2325                 long imm = SCM_VM_INSN_ARG(code);
2326                 if (SCM_INTP(VAL0)) {
2327                     imm -= SCM_INT_VALUE(VAL0);
2328                     if (SCM_SMALL_INT_FITS(imm)) {
2329                         VAL0 = SCM_MAKE_INT(imm);
2330                     } else {
2331                         SAVE_REGS();
2332                         VAL0 = Scm_MakeInteger(imm);
2333                     }
2334                 } else {
2335                     SAVE_REGS();
2336                     VAL0 = Scm_Subtract(SCM_MAKE_INT(imm), VAL0, SCM_NIL);
2337                     RESTORE_REGS();
2338                 }
2339                 NEXT1;
2340             }
2341             CASE(SCM_VM_READ_CHAR) {
2342                 int nargs = SCM_VM_INSN_ARG(code), ch = 0;
2343                 ScmPort *port;
2344                 if (nargs == 1) {
2345                     if (!SCM_IPORTP(VAL0))
2346                         VM_ERR(("read-char: input port required: %S", VAL0));
2347                     port = SCM_PORT(VAL0);
2348                 } else {
2349                     port = SCM_CURIN;
2350                 }
2351                 SAVE_REGS();
2352                 ch = Scm_Getc(port);
2353                 RESTORE_REGS();
2354                 VAL0 = (ch < 0)? SCM_EOF : SCM_MAKE_CHAR(ch);
2355                 NEXT1;
2356             }
2357             CASE(SCM_VM_PEEK_CHAR) {
2358                 int nargs = SCM_VM_INSN_ARG(code), ch = 0;
2359                 ScmPort *port;
2360                 if (nargs == 1) {
2361                     if (!SCM_IPORTP(VAL0))
2362                         VM_ERR(("read-char: input port required: %S", VAL0));
2363                     port = SCM_PORT(VAL0);
2364                 } else {
2365                     port = SCM_CURIN;
2366                 }
2367                 SAVE_REGS();
2368                 ch = Scm_Peekc(port);
2369                 RESTORE_REGS();
2370                 VAL0 = (ch < 0)? SCM_EOF : SCM_MAKE_CHAR(ch);
2371                 NEXT1;
2372             }
2373             CASE(SCM_VM_WRITE_CHAR) {
2374                 int nargs = SCM_VM_INSN_ARG(code);
2375                 ScmObj ch;
2376                 ScmPort *port;
2377                 if (nargs == 2) {
2378                     if (!SCM_OPORTP(VAL0))
2379                         VM_ERR(("write-char: output port required: %S", VAL0));
2380                     port = SCM_PORT(VAL0);
2381                     POP_ARG(ch);
2382                 } else {
2383                     port = SCM_CUROUT;
2384                     ch = VAL0;
2385                 }
2386                 if (!SCM_CHARP(ch))
2387                     VM_ERR(("write-char: character required: %S", ch));
2388                 SAVE_REGS();
2389                 SCM_PUTC(SCM_CHAR_VALUE(ch), port);
2390                 RESTORE_REGS();
2391                 VAL0 = SCM_UNDEFINED;
2392                 NEXT1;
2393             }
2394             CASE(SCM_VM_CURIN) {
2395                 VAL0 = SCM_OBJ(vm->curin);
2396                 NEXT1;
2397             }
2398             CASE(SCM_VM_CUROUT) {
2399                 VAL0 = SCM_OBJ(vm->curout);
2400                 NEXT1;
2401             }
2402             CASE(SCM_VM_CURERR) {
2403                 VAL0 = SCM_OBJ(vm->curerr);
2404                 NEXT1;
2405             }
2406             CASE(SCM_VM_SLOT_REF) {
2407                 ScmObj obj;
2408                 POP_ARG(obj);
2409                 TAIL_CALL_INSTRUCTION();
2410                 SAVE_REGS();
2411                 VAL0 = Scm_VMSlotRef(obj, VAL0, FALSE);
2412                 RESTORE_REGS();
2413                 NEXT1;
2414             }
2415             CASE(SCM_VM_SLOT_SET) {
2416                 ScmObj obj, slot;
2417                 POP_ARG(slot);
2418                 POP_ARG(obj);
2419                 TAIL_CALL_INSTRUCTION();
2420                 SAVE_REGS();
2421                 VAL0 = Scm_VMSlotSet(obj, slot, VAL0);
2422                 RESTORE_REGS();
2423                 NEXT1;
2424             }
2425             CASE(SCM_VM_SLOT_REFC) {
2426                 ScmObj slot;
2427                 FETCH_OPERAND(slot);
2428                 INCR_PC;
2429                 TAIL_CALL_INSTRUCTION();
2430                 SAVE_REGS();
2431                 VAL0 = Scm_VMSlotRef(VAL0, slot, FALSE);
2432                 RESTORE_REGS();
2433                 NEXT1;
2434             }
2435             CASE(SCM_VM_SLOT_SETC) {
2436                 ScmObj obj, slot;
2437                 POP_ARG(obj);
2438                 FETCH_OPERAND(slot);
2439                 INCR_PC;
2440                 TAIL_CALL_INSTRUCTION();
2441                 SAVE_REGS();
2442                 VAL0 = Scm_VMSlotSet(obj, slot, VAL0);
2443                 RESTORE_REGS();
2444                 NEXT1;
2445             }
2446 #ifndef __GNUC__
2447         default:
2448             Scm_Panic("Illegal vm instruction: %08x",
2449                       SCM_VM_INSN_CODE(code));
2450 #endif
2451         }
2452       process_queue:
2453         CHECK_STACK(CONT_FRAME_SIZE);
2454         PUSH_CONT(PC);
2455         SAVE_REGS();
2456         process_queued_requests(vm);
2457         RESTORE_REGS();
2458         POP_CONT();
2459         NEXT;
2460     }
2461 }
2462 /* End of run_loop */
2463 
2464 /*==================================================================
2465  * Stack management
2466  */
2467 
2468 /* We have 'fowarding pointer' for env and cont frames being moved.
2469    Forwarding pointers are resolved within these internal routines
2470    and should never leak out.
2471 
2472    Forwarded pointer is marked by the 'size' field be set -1.
2473    Env->up or Cont->prev field holds the relocated frame.
2474 
2475    Invariance: forwarded pointer only appear in stack.  We skip some
2476    IN_STACK_P check because of it. */
2477 
2478 #define FORWARDED_ENV_P(e)  ((e)&&((e)->size == -1))
2479 #define FORWARDED_ENV(e)    ((e)->up)
2480 
2481 #define FORWARDED_CONT_P(c) ((c)&&((c)->size == -1))
2482 #define FORWARDED_CONT(c)   ((c)->prev)
2483 
2484 /* Performance note: As of 0.8.4_pre1, each get_env call spends about
2485    1us to 4us on P4 2GHz machine with several benchmark suites.  The
2486    average env frames to be saved is less than 3.  The ratio of the pass1
2487    (env frame save) and the pass 2 (cont pointer adjustment) is somewhere
2488    around 2:1 to 1:2.  Inlining SCM_NEW call didn't help.
2489 
2490    This is a considerable amount of time, since save_env may be called
2491    the order of 10^6 times.   I'm not sure I can optimize this routine
2492    further without a radical change in stack management code.
2493 
2494    Better strategy is to put an effort in the compiler to avoid closure 
2495    creation as much as possible.  */
2496 
2497 /* Move the chain of env frames from the stack to the heap,
2498    replacing the in-stack frames for forwarding env frames.
2499    
2500    This routine just moves the env frames, but leaves pointers that
2501    point to moved frames intact (such pointers are found only in
2502    the in-stack contniuation frames, chained from vm->cont).
2503    It's the caller's responsibility to update those pointers. */
2504 static inline ScmEnvFrame *save_env(ScmVM *vm, ScmEnvFrame *env_begin)
2505 {
2506     ScmEnvFrame *e = env_begin, *prev = NULL, *next, *head = NULL, *saved;
2507 
2508     if (!IN_STACK_P((ScmObj*)e)) return e;
2509 
2510     do {
2511         int esize = e->size, i;
2512         ScmObj *d, *s;
2513 
2514         if (e->size < 0) {
2515             /* forwaded frame */
2516             if (prev) prev->up = FORWARDED_ENV(e);
2517             return head;
2518         }
2519 
2520         d = SCM_NEW2(ScmObj*, ENV_SIZE(esize) * sizeof(ScmObj));
2521         for (i=ENV_SIZE(esize), s = (ScmObj*)e - esize; i>0; i--) {
2522             *d++ = *s++;
2523         }
2524         saved = (ScmEnvFrame*)(d - ENV_HDR_SIZE);
2525         if (prev) prev->up = saved;
2526         if (head == NULL) head = saved;
2527         next = e->up;
2528         e->up = prev = saved; /* forwarding pointer */
2529         e->size = -1;         /* indicates forwarded */
2530         e->info = SCM_FALSE;
2531         e = next;
2532     } while (IN_STACK_P((ScmObj*)e));
2533     return head;
2534 }
2535 
2536 /* Copy the continuation frames to the heap.
2537    We run two passes, first replacing cont frames with the forwarding
2538    cont frames, then updates the pointers to them.
2539    After save_cont, the only thing possibly left in the stack is the argument
2540    frame pointed by vm->argp.
2541  */
2542 static void save_cont(ScmVM *vm)
2543 {
2544     ScmContFrame *c = vm->cont, *prev = NULL, *tmp;
2545     ScmCStack *cstk;
2546     ScmEscapePoint *ep;
2547     ScmObj *s, *d;
2548     int i;
2549 
2550     /* Save the environment chain first. */
2551     vm->env = save_env(vm, vm->env);
2552 
2553     if (!IN_STACK_P((ScmObj*)c)) return;
2554 
2555     /* First pass */
2556     do {
2557         int size = (CONT_FRAME_SIZE + c->size) * sizeof(ScmObj);
2558         ScmContFrame *csave = SCM_NEW2(ScmContFrame*, size);
2559 
2560         /* update env ptr if necessary */
2561         if (FORWARDED_ENV_P(c->env)) {
2562             c->env = FORWARDED_ENV(c->env);
2563         } else if (IN_STACK_P((ScmObj*)c->env)) {
2564             c->env = save_env(vm, c->env);
2565         }
2566 
2567         /* copy cont frame */
2568         if (c->argp) {
2569             *csave = *c; /* copy the frame */
2570             if (c->size) {
2571                 /* copy the args */
2572                 s = c->argp;
2573                 d = (ScmObj*)csave + CONT_FRAME_SIZE;
2574                 for (i=c->size; i>0; i--) {
2575                     *d++ = *s++;
2576                 }
2577             }
2578             csave->argp = ((ScmObj*)csave + CONT_FRAME_SIZE);
2579         } else {
2580             /* C continuation */
2581             s = (ScmObj*)c;
2582             d = (ScmObj*)csave;
2583             for (i=CONT_FRAME_SIZE + c->size; i>0; i--) {
2584                 *d++ = *s++;
2585             }
2586         }
2587 
2588         /* make the orig frame forwarded */
2589         if (prev) prev->prev = csave;
2590         prev = csave;
2591         
2592         tmp = c->prev;
2593         c->prev = csave;
2594         c->size = -1;
2595         c = tmp;
2596     } while (IN_STACK_P((ScmObj*)c));
2597     
2598     /* Second pass */
2599     if (FORWARDED_CONT_P(vm->cont)) {
2600         vm->cont = FORWARDED_CONT(vm->cont);
2601     }
2602     for (cstk = vm->cstack; cstk; cstk = cstk->prev) {
2603         if (FORWARDED_CONT_P(cstk->cont)) {
2604             cstk->cont = FORWARDED_CONT(cstk->cont);
2605         }
2606     }
2607     for (ep = vm->escapePoint; ep; ep = ep->prev) {
2608         if (FORWARDED_CONT_P(ep->cont)) {
2609             ep->cont = FORWARDED_CONT(ep->cont);
2610         }
2611     }
2612     for (ep = SCM_VM_FLOATING_EP(vm); ep; ep = ep->floating) {
2613         if (FORWARDED_CONT_P(ep->cont)) {
2614             ep->cont = FORWARDED_CONT(ep->cont);
2615         }
2616     }
2617 }
2618 
2619 static void save_stack(ScmVM *vm)
2620 {
2621     ScmObj *p;
2622     struct timeval t0, t1;
2623     int stats = SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_COLLECT_VM_STATS);
2624 
2625 #if HAVE_GETTIMEOFDAY
2626     if (stats) {
2627         gettimeofday(&t0, NULL);
2628     }
2629 #endif
2630 
2631     save_cont(vm);
2632     memmove(vm->stackBase, vm->argp,
2633             (vm->sp - (ScmObj*)vm->argp) * sizeof(ScmObj*));
2634     vm->sp -= (ScmObj*)vm->argp - vm->stackBase;
2635     vm->argp = vm->stackBase;
2636     /* Clear the stack.  This removes bogus pointers and accelerates GC */
2637     for (p = vm->sp; p < vm->stackEnd; p++) *p = NULL;
2638 
2639 #if HAVE_GETTIMEOFDAY
2640     if (stats) {
2641         gettimeofday(&t1, NULL);
2642         vm->stat.sovCount++;
2643         vm->stat.sovTime +=
2644             (t1.tv_sec - t0.tv_sec)*1000000+(t1.tv_usec - t0.tv_usec);
2645     }
2646 #endif
2647 }
2648 
2649 static ScmEnvFrame *get_env(ScmVM *vm)
2650 {
2651     ScmEnvFrame *e;
2652     ScmContFrame *c;
2653     
2654     e = save_env(vm, vm->env);
2655     if (e != vm->env) {
2656         vm->env = e;
2657         for (c = vm->cont; IN_STACK_P((ScmObj*)c); c = c->prev) {
2658             if (FORWARDED_ENV_P(c->env)) {
2659                 c->env = FORWARDED_ENV(c->env);
2660             }
2661         }
2662     }
2663     return e;
2664 }
2665 
2666 /*==================================================================
2667  * Function application from C
2668  */
2669 
2670 /* The Scm_VMApply family is supposed to be called in SUBR.  It doesn't really
2671    applies the function in it.  Instead, it modifies the VM state so that
2672    the specified function will be called immediately after this SUBR
2673    returns to the VM.   The return value of Scm_VMApply is just a PROC,
2674    but it should be returned as the return value of SUBR, which will be
2675    used by the VM.
2676    NB: we don't check proc is a procedure or not.  It can be a non-procedure
2677    object, because of the object-apply hook. */
2678 
2679 /* Static VM instruction arrays.
2680    Scm_VMApplyN modifies VM's pc to point it. */
2681 
2682 static ScmWord apply_calls[][2] = {
2683     { SCM_VM_INSN1(SCM_VM_TAIL_CALL, 0),
2684       SCM_VM_INSN(SCM_VM_RET) },
2685     { SCM_VM_INSN1(SCM_VM_TAIL_CALL, 1),
2686       SCM_VM_INSN(SCM_VM_RET) },
2687     { SCM_VM_INSN1(SCM_VM_TAIL_CALL, 2),
2688       SCM_VM_INSN(SCM_VM_RET) },
2689     { SCM_VM_INSN1(SCM_VM_TAIL_CALL, 3),
2690       SCM_VM_INSN(SCM_VM_RET) },
2691     { SCM_VM_INSN1(SCM_VM_TAIL_CALL, 4),
2692       SCM_VM_INSN(SCM_VM_RET) },
2693 };
2694 
2695 ScmObj Scm_VMApply(ScmObj proc, ScmObj args)
2696 {
2697     DECL_REGS;
2698     int numargs = Scm_Length(args);
2699     int reqstack;
2700     ScmObj cp;
2701 
2702     if (numargs < 0) Scm_Error("improper list not allowed: %S", args);
2703     reqstack = ENV_SIZE(numargs) + 1;
2704     if (reqstack >= SCM_VM_STACK_SIZE) {
2705         /* there's no way we can accept that many arguments */
2706         Scm_Error("too many arguments (%d) to apply", numargs);
2707     }
2708     CHECK_STACK(reqstack);
2709 
2710     SCM_FOR_EACH(cp, args) {
2711         PUSH_ARG(SCM_CAR(cp));
2712     }
2713     if (numargs <= 4) {
2714         PC = apply_calls[numargs];
2715     } else {
2716         PC = SCM_NEW_ARRAY(ScmWord, 2);
2717         PC[0] = SCM_VM_INSN1(SCM_VM_TAIL_CALL, numargs);
2718         PC[1] = SCM_VM_INSN(SCM_VM_RET);
2719     }
2720     SAVE_REGS();
2721     return proc;
2722 }
2723 
2724 /* shortcuts for common cases */
2725 ScmObj Scm_VMApply0(ScmObj proc)
2726 {
2727     ScmVM *vm = theVM;
2728     vm->pc = apply_calls[0];
2729     return proc;
2730 }
2731 
2732 ScmObj Scm_VMApply1(ScmObj proc, ScmObj arg)
2733 {
2734     DECL_REGS;
2735     CHECK_STACK(1);
2736     PUSH_ARG(arg);
2737     PC = apply_calls[1];
2738     SAVE_REGS();
2739     return proc;
2740 }
2741 
2742 ScmObj Scm_VMApply2(ScmObj proc, ScmObj arg1, ScmObj arg2)
2743 {
2744     DECL_REGS;
2745     CHECK_STACK(2);
2746     PUSH_ARG(arg1);
2747     PUSH_ARG(arg2);
2748     PC = apply_calls[2];
2749     SAVE_REGS();
2750     return proc;
2751 }
2752 
2753 ScmObj Scm_VMApply3(ScmObj proc, ScmObj arg1, ScmObj arg2, ScmObj arg3)
2754 {
2755     DECL_REGS;
2756     CHECK_STACK(3);
2757     PUSH_ARG(arg1);
2758     PUSH_ARG(arg2);
2759     PUSH_ARG(arg3);
2760     PC = apply_calls[3];
2761     SAVE_REGS();
2762     return proc;
2763 }
2764 
2765 ScmObj Scm_VMApply4(ScmObj proc, ScmObj arg1, ScmObj arg2, ScmObj arg3, ScmObj arg4)
2766 {
2767     DECL_REGS;
2768     CHECK_STACK(4);
2769     PUSH_ARG(arg1);
2770     PUSH_ARG(arg2);
2771     PUSH_ARG(arg3);
2772     PUSH_ARG(arg4);
2773     PC = apply_calls[4];
2774     SAVE_REGS();
2775     return proc;
2776 }
2777 
2778 static ScmObj eval_restore_env(ScmObj *args, int argc, void *data)
2779 {
2780     Scm_VM()->module = SCM_MODULE(data);
2781     return SCM_UNDEFINED;
2782 }
2783 
2784 /* For now, we only supports a module as the evaluation environment */
2785 ScmObj Scm_VMEval(ScmObj expr, ScmObj e)
2786 {
2787     ScmObj v = SCM_NIL;
2788     ScmVM *vm = Scm_VM();
2789     int restore_module = SCM_MODULEP(e);
2790 
2791     v = Scm_Compile(expr, e);
2792     if (SCM_VM_COMPILER_FLAG_IS_SET(theVM, SCM_COMPILE_SHOWRESULT)) {
2793         Scm_CompiledCodeDump(SCM_COMPILED_CODE(v));
2794     }
2795 
2796     vm->numVals = 1;
2797     if (restore_module) {
2798         /* if we swap the module, we need to make sure it is recovered
2799            after eval */
2800         ScmObj body = Scm_MakeClosure(v, get_env(vm));
2801         ScmObj before = Scm_MakeSubr(eval_restore_env, SCM_MODULE(e),
2802                                      0, 0, SCM_SYM_EVAL_BEFORE);
2803         ScmObj after = Scm_MakeSubr(eval_restore_env, (void*)vm->module,
2804                                     0, 0, SCM_SYM_EVAL_AFTER);
2805         return Scm_VMDynamicWind(before, body, after);
2806     } else {
2807         /* shortcut */
2808         SCM_ASSERT(SCM_COMPILED_CODE_P(v));
2809         vm->base = SCM_COMPILED_CODE(v);
2810         vm->pc = SCM_COMPILED_CODE(v)->code;
2811         SCM_PROF_COUNT_CALL(vm, v);
2812         return SCM_UNDEFINED;
2813     }
2814 }
2815 
2816 /*-------------------------------------------------------------
2817  * User level eval and apply.
2818  *   When the C routine wants the Scheme code to return to it,
2819  *   instead of using C-continuation, the continuation
2820  *   "cross the border" of C-stack and Scheme-stack.  This
2821  *   border has peculiar characteristics.   Once the Scheme
2822  *   returns, continuations saved during the execution of the
2823  *   Scheme code becomes invalid.
2824  *
2825  *   At the implementation level, this boundary is kept in a
2826  *   structure ScmCStack.
2827  */
2828 
2829 /* Border gate.  All the C->Scheme calls should go through here.
2830  *
2831  *   The current C stack information is saved in cstack.  The
2832  *   current VM stack information is saved (as a continuation
2833  *   frame pointer) in cstack.cont.
2834  */
2835 
2836 static ScmObj user_eval_inner(ScmObj program, ScmWord *codevec)
2837 {
2838     DECL_REGS_VOLATILE;
2839     ScmCStack cstack;
2840     /* Save prev_pc, for the boundary continuation uses pc slot
2841        to mark the boundary. */
2842     ScmWord * volatile prev_pc = PC;
2843 
2844     /* Push extra continuation.  This continuation frame is a 'boundary
2845        frame' and marked by pc == &boundaryFrameMark.   VM loop knows
2846        it should return to C frame when it sees a boundary frame.
2847        A boundary frame also keeps the unfinished argument frame at
2848        the point when Scm_Eval or Scm_Apply is called. */
2849     CHECK_STACK(CONT_FRAME_SIZE);
2850     PUSH_CONT(&boundaryFrameMark);
2851     SCM_ASSERT(SCM_COMPILED_CODE_P(program));
2852     vm->base = SCM_COMPILED_CODE(program);
2853     if (codevec != NULL) {
2854         PC = codevec;
2855     } else {
2856         PC = vm->base->code;
2857         CHECK_STACK(vm->base->maxstack);
2858     }
2859     SCM_PROF_COUNT_CALL(vm, program);
2860     SAVE_REGS();
2861 
2862     cstack.prev = vm->cstack;
2863     cstack.cont = vm->cont;
2864     vm->cstack = &cstack;
2865     
2866   restart:
2867     vm->escapeReason = SCM_VM_ESCAPE_NONE;
2868     if (sigsetjmp(cstack.jbuf, TRUE) == 0) {
2869         run_loop();
2870         VAL0 = vm->val0;
2871         if (vm->cont == cstack.cont) {
2872             RESTORE_REGS();
2873             POP_CONT();
2874             PC = prev_pc;
2875             SAVE_REGS();
2876         }
2877     } else {
2878         /* An escape situation happened. */
2879         if (vm->escapeReason == SCM_VM_ESCAPE_CONT) {
2880              ScmEscapePoint *ep = (ScmEscapePoint*)vm->escapeData[0];
2881             if (ep->cstack == vm->cstack) {
2882                 ScmObj handlers = throw_cont_calculate_handlers(ep, vm);
2883                 /* force popping continuation when restarted */
2884                 vm->pc = PC_TO_RETURN;
2885                 vm->val0 = throw_cont_body(handlers, ep, vm->escapeData[1]);
2886                 goto restart;
2887             } else {
2888                 SCM_ASSERT(vm->cstack && vm->cstack->prev);
2889                 vm->cont = cstack.cont;
2890                 VAL0 = vm->val0;
2891                 RESTORE_REGS();
2892                 POP_CONT();
2893                 SAVE_REGS();
2894                 vm->cstack = vm->cstack->prev;
2895                 siglongjmp(vm->cstack->jbuf, 1);
2896             }
2897         } else if (vm->escapeReason == SCM_VM_ESCAPE_ERROR) {
2898             ScmEscapePoint *ep = (ScmEscapePoint*)vm->escapeData[0];
2899             if (ep && ep->cstack == vm->cstack) {
2900                 vm->cont = ep->cont;
2901                 vm->pc = PC_TO_RETURN;
2902                 goto restart;
2903             } else if (vm->cstack->prev == NULL) {
2904                 /* This loop is the outermost C stack, and nobody will
2905                    capture the error.  Usually this means we're running
2906                    scripts.  We can safely exit here, for the dynamic
2907                    stack is already rewound. */
2908                 exit(EX_SOFTWARE);
2909             } else {
2910                 /* Jump again until C stack is recovered.  We sould pop
2911                    the extra continuation frame so that the VM stack
2912                    is consistent. */
2913                 vm->cont = cstack.cont;
2914                 VAL0 = vm->val0;
2915                 RESTORE_REGS();
2916                 POP_CONT();
2917                 SAVE_REGS();
2918                 vm->cstack = vm->cstack->prev;
2919                 siglongjmp(vm->cstack->jbuf, 1);
2920             }
2921         } else {
2922             Scm_Panic("invalid longjmp");
2923         }
2924         /* NOTREACHED */
2925     }
2926     vm->cstack = vm->cstack->prev;
2927     return vm->val0;
2928 }
2929 
2930 ScmObj Scm_Eval(ScmObj expr, ScmObj e)
2931 {
2932     ScmObj v = SCM_NIL;
2933     v = Scm_Compile(expr, e);
2934     SCM_COMPILED_CODE(v)->name = SCM_SYM_INTERNAL_EVAL;
2935     if (SCM_VM_COMPILER_FLAG_IS_SET(theVM, SCM_COMPILE_SHOWRESULT)) {
2936         Scm_CompiledCodeDump(SCM_COMPILED_CODE(v));
2937     }
2938     return user_eval_inner(v, NULL);
2939 }
2940 
2941 ScmObj Scm_EvalCString(const char *expr, ScmObj e)
2942 {
2943     return Scm_Eval(Scm_ReadFromCString(expr), e);
2944 }
2945 
2946 ScmObj Scm_Apply(ScmObj proc, ScmObj args)
2947 {
2948     ScmObj program;
2949     int nargs = Scm_Length(args);
2950     ScmVM *vm = Scm_VM();
2951     ScmWord *code = SCM_NEW_ARRAY(ScmWord, 3);
2952 
2953     if (nargs < 0) {
2954         Scm_Error("improper list not allowed: %S", args);        
2955     }
2956 
2957     code[0] = SCM_WORD(SCM_VM_INSN1(SCM_VM_CONST_APPLY, nargs));
2958     code[1] = SCM_WORD(Scm_Cons(proc, args));
2959     code[2] = SCM_WORD(SCM_VM_INSN(SCM_VM_RET));
2960 
2961     program = vm->base? SCM_OBJ(vm->base) : SCM_OBJ(&internal_apply_compiled_code);
2962 
2963     return user_eval_inner(program, code);
2964 }
2965 
2966 /* Arrange C function AFTER to be called after the procedure returns.
2967  * Usually followed by Scm_VMApply* function.
2968  */
2969 void Scm_VMPushCC(ScmObj (*after)(ScmObj result, void **data),
2970                   void **data, int datasize)
2971 {
2972     DECL_REGS;
2973     int i;
2974     ScmContFrame *cc;
2975     ScmObj *s;
2976 
2977     CHECK_STACK(CONT_FRAME_SIZE+datasize);
2978     s = SP;
2979     cc = (ScmContFrame*)s;
2980     s += CONT_FRAME_SIZE;
2981     cc->prev = CONT;
2982     cc->argp = NULL;
2983     cc->size = datasize;
2984     cc->pc = (ScmWord*)after;
2985     cc->base = BASE;
2986     cc->env = ENV;
2987     for (i=0; i<datasize; i++) {
2988         *s++ = SCM_OBJ(data[i]);
2989     }
2990     CONT = cc;
2991     ARGP = SP = s;
2992     SAVE_REGS();
2993 }
2994 
2995 /*=================================================================
2996  * Dynamic handlers
2997  */
2998 
2999 static ScmObj dynwind_before_cc(ScmObj result, void **data);
3000 static ScmObj dynwind_body_cc(ScmObj result, void **data);
3001 static ScmObj dynwind_after_cc(ScmObj result, void **data);
3002 
3003 ScmObj Scm_VMDynamicWind(ScmObj before, ScmObj body, ScmObj after)
3004 {
3005     void *data[3];
3006 
3007 #if 0 /* allow object-apply hook for all thunks */
3008     if (!SCM_PROCEDUREP(before) || SCM_PROCEDURE_REQUIRED(before) != 0)
3009         Scm_Error("thunk required for BEFORE argument, but got %S", before);
3010     if (!SCM_PROCEDUREP(body) || SCM_PROCEDURE_REQUIRED(body) != 0)
3011         Scm_Error("thunk required for BODY argument, but got %S", body);
3012     if (!SCM_PROCEDUREP(after) || SCM_PROCEDURE_REQUIRED(after) != 0)
3013         Scm_Error("thunk required for AFTER argument, but got %S", after);
3014 #endif
3015 
3016     data[0] = (void*)before;
3017     data[1] = (void*)body;
3018     data[2] = (void*)after;
3019 
3020     Scm_VMPushCC(dynwind_before_cc, data, 3);
3021     return Scm_VMApply0(before);
3022 }
3023 
3024 static ScmObj dynwind_before_cc(ScmObj result, void **data)
3025 {
3026     ScmObj before  = SCM_OBJ(data[0]);
3027     ScmObj body = SCM_OBJ(data[1]);
3028     ScmObj after = SCM_OBJ(data[2]);
3029     ScmObj prev = theVM->handlers;
3030 
3031     void *d[2];
3032     d[0] = (void*)after;
3033     d[1] = (void*)prev;
3034     theVM->handlers = Scm_Cons(Scm_Cons(before, after), prev);
3035     Scm_VMPushCC(dynwind_body_cc, d, 2);
3036     return Scm_VMApply0(body);
3037 }
3038 
3039 static ScmObj dynwind_body_cc(ScmObj result, void **data)
3040 {
3041     ScmVM *vm = theVM;
3042     ScmObj after = SCM_OBJ(data[0]);
3043     ScmObj prev  = SCM_OBJ(data[1]);
3044     void *d[3];
3045 
3046     vm->handlers = prev;
3047     d[0] = (void*)result;
3048     d[1] = (void*)vm->numVals;
3049     if (vm->numVals > 1) {
3050         ScmObj *array = SCM_NEW_ARRAY(ScmObj, (vm->numVals-1));
3051         memcpy(array, vm->vals, sizeof(ScmObj)*(vm->numVals-1));
3052         d[2] = (void*)array;
3053     }
3054     Scm_VMPushCC(dynwind_after_cc, d, 3);
3055     return Scm_VMApply0(after);
3056 }
3057 
3058 static ScmObj dynwind_after_cc(ScmObj result, void **data)
3059 {
3060     ScmObj val0 = SCM_OBJ(data[0]);
3061     ScmVM *vm = theVM;
3062     int nvals = (int)data[1];
3063     vm->numVals = nvals;
3064     if (nvals > 1) {
3065         SCM_ASSERT(nvals <= SCM_VM_MAX_VALUES);
3066         memcpy(vm->vals, data[2], sizeof(ScmObj)*(nvals-1));
3067     }
3068     return val0;
3069 }
3070 
3071 /* C-friendly wrapper */
3072 ScmObj Scm_VMDynamicWindC(ScmObj (*before)(ScmObj *args, int nargs, void *data),
3073                           ScmObj (*body)(ScmObj *args, int nargs, void *data),
3074                           ScmObj (*after)(ScmObj *args, int nargs, void *data),
3075                           void *data)
3076 {
3077     ScmObj beforeproc, bodyproc, afterproc;
3078     beforeproc =
3079         before ? Scm_MakeSubr(before, data, 0, 0, SCM_FALSE) : Scm_NullProc();
3080     afterproc =
3081         after ? Scm_MakeSubr(after, data, 0, 0, SCM_FALSE) : Scm_NullProc();
3082     bodyproc =
3083         body ? Scm_MakeSubr(body, data, 0, 0, SCM_FALSE) : Scm_NullProc();
3084     
3085     return Scm_VMDynamicWind(beforeproc, bodyproc, afterproc);
3086 }
3087 
3088 
3089 /*=================================================================
3090  * Exception handling
3091  */
3092 
3093 /* Conceptually, exception handling is nothing more than a particular
3094  * combination of dynamic-wind and call/cc.   Gauche implements a parts
3095  * of it in C so that it will be efficient and safer to use.
3096  *
3097  * The most basic layer consists of these two functions:
3098  *
3099  *  with-exception-handler
3100  *  raise
3101  *
3102  * There is a slight problem, though.  These two functions are defined
3103  * both in srfi-18 (multithreads) and srfi-34 (exception handling), and
3104  * two disagrees in the semantics of raise.
3105  *
3106  * Srfi-18 requires an exception handler to be called with the same dynamic
3107  * environment as the one of the primitive that raises the exception.
3108  * That means when an exception handler is running, the current
3109  * exception handler is the running handler itself.  Naturally, calling
3110  * raise unconditionally within the exception handler causes infinite loop.
3111  *
3112  * Srfi-34 says that an exception handler is called with the same dynamic
3113  * envionment where the exception is raised, _except_ that the current
3114  * exception handler is "popped", i.e. when an exception handler is running,
3115  * the current exception handler is the "outer" or "old" one.  Calling
3116  * raise within an exception handler passes the control to the outer
3117  * exception handler.
3118  *
3119  * At this point I haven't decided which model Gauche should support natively.
3120  * The current implementation predates srfi-34 and roughly follows srfi-18.
3121  * It appears that srfi-18's mechanism is more "primitive" or "lightweight"
3122  * than srfi-34's, so it's likely that Gauche will continue to support
3123  * srfi-18 model natively, and maybe provides srfi-34's interface by an
3124  * additional module.
3125  *
3126  * The following is a model of the current implementation, sans the messy
3127  * part of handling C stacks.
3128  * Suppose a system variable %xh keeps the list of exception handlers.
3129  *
3130  *  (define (current-exception-handler) (car %xh))
3131  *
3132  *  (define (raise exn)
3133  *    (receive r ((car %xh) exn)
3134  *      (when (uncontinuable-exception? exn)
3135  *        (set! %xh (cdr %xh))
3136  *        (error "returned from uncontinuable exception"))
3137  *      (apply values r)))
3138  *
3139  *  (define (with-exception-handler handler thunk)
3140  *    (let ((prev %xh))
3141  *      (dynamic-wind
3142  *        (lambda () (set! %xh (cons handler)))
3143  *        thunk
3144  *        (lambda () (set! %xh prev)))))
3145  *
3146  * In C level, the chain of the handlers are represented in the chain
3147  * of ScmEscapePoints.
3148  *
3149  * Note that this model assumes an exception handler returns unless it
3150  * explictly invokes continuation captured elsewhere.   In reality,
3151  * "error" exceptions are not supposed to return (hence it is checked
3152  * in raise).  Gauche provides another useful exception handling
3153  * constructs that automates such continuation capturing.  It can be
3154  * explained by the following code.
3155  *
3156  * (define (with-error-handler handler thunk)
3157  *   (call/cc
3158  *     (lambda (cont)
3159  *       (let ((prev-handler (current-exception-handler)))
3160  *         (with-exception-handler
3161  *           (lambda (exn)
3162  *             (if (error? exn)
3163  *                 (call-with-values (handler exn) cont)
3164  *                 (prev-handler exn)))
3165  *           thunk)))))
3166  *
3167  * In the actual implementation,
3168  *
3169  *  - No "real" continuation procedure is created, but a lightweight
3170  *    mechanism is used.  The lightweight mechanism is similar to
3171  *    "one-shot" callback (call/1cc in Chez Scheme).
3172  *  - The error handler chain is kept in vm->escapePoint
3173  *  - There are messy lonjmp/setjmp stuff involved to keep C stack sane.
3174  */
3175 
3176 /*
3177  * Default exception handler
3178  *  This is what we have as the system default, and also
3179  *  what with-error-handler installs as an exception handler.
3180  */
3181 
3182 void Scm_VMDefaultExceptionHandler(ScmObj e)
3183 {
3184     ScmVM *vm = theVM;
3185     ScmEscapePoint *ep = vm->escapePoint;
3186     ScmObj hp;
3187 
3188     if (ep) {
3189         /* There's an escape point defined by with-error-handler. */
3190         ScmObj target, current;
3191         ScmObj result = SCM_FALSE, rvals[SCM_VM_MAX_VALUES];
3192         int numVals = 0, i;
3193 
3194         /* Call the error handler and save the results.
3195            NB: before calling the error handler, we need to pop
3196            vm->escapePoint, so that the error occurred during
3197            the error handler should be dealt with the upstream error
3198            handler.  We keep ep in vm->escapePoint->floating, so that
3199            ep->cont can be updated when stack overflow occurs during the
3200            error handler.  See also the description of ScmEscapePoint in
3201            gauche/vm.h. */
3202         vm->escapePoint = ep->prev;
3203         SCM_VM_FLOATING_EP_SET(vm, ep);
3204 
3205         SCM_UNWIND_PROTECT {
3206             result = Scm_Apply(ep->ehandler, SCM_LIST1(e));
3207             if ((numVals = vm->numVals) > 1) {
3208                 for (i=0; i<numVals-1; i++) rvals[i] = vm->vals[i];
3209             }
3210             target = ep->handlers;
3211             current = vm->handlers;
3212             /* Call dynamic handlers */
3213             for (hp = current; SCM_PAIRP(hp)&&hp != target; hp = SCM_CDR(hp)) {
3214                 ScmObj proc = SCM_CDAR(hp);
3215                 vm->handlers = SCM_CDR(hp);
3216                 Scm_Apply(proc, SCM_NIL);
3217             }
3218         }
3219         SCM_WHEN_ERROR {
3220             /* make sure the floating pointer is reset when an error is
3221                signalled during handlers */
3222             SCM_VM_FLOATING_EP_SET(vm, ep->floating);
3223             SCM_NEXT_HANDLER;
3224         }
3225         SCM_END_PROTECT;
3226         
3227         /* Install the continuation */
3228         for (i=0; i<numVals; i++) vm->vals[i] = rvals[i];
3229         vm->numVals = numVals;
3230         vm->val0 = result;
3231         vm->cont = ep->cont;
3232         SCM_VM_FLOATING_EP_SET(vm, ep->floating);
3233         if (ep->errorReporting) {
3234             SCM_VM_RUNTIME_FLAG_SET(vm, SCM_ERROR_BEING_REPORTED);
3235         }
3236     } else {
3237         Scm_ReportError(e);
3238         /* unwind the dynamic handlers */
3239         SCM_FOR_EACH(hp, vm->handlers) {
3240             ScmObj proc = SCM_CDAR(hp);
3241             vm->handlers = SCM_CDR(hp);
3242             Scm_Apply(proc, SCM_NIL);
3243         }
3244     }
3245 
3246     if (vm->cstack) {
3247         vm->escapeReason = SCM_VM_ESCAPE_ERROR;
3248         vm->escapeData[0] = ep;
3249         vm->escapeData[1] = e;
3250         siglongjmp(vm->cstack->jbuf, 1);
3251     } else {
3252         exit(EX_SOFTWARE);
3253     }
3254 }
3255 
3256 static ScmObj default_exception_handler_body(ScmObj *argv, int argc, void *data)
3257 {
3258     SCM_ASSERT(argc == 1);
3259     Scm_VMDefaultExceptionHandler(argv[0]);
3260     return SCM_UNDEFINED;       /*NOTREACHED*/
3261 }
3262 
3263 static SCM_DEFINE_STRING_CONST(default_exception_handler_name,
3264                                "default-exception-handler",
3265                                25, 25); /* strlen("default-exception-handler") */
3266 static SCM_DEFINE_SUBR(default_exception_handler_rec, 1, 0,
3267                        SCM_OBJ(&default_exception_handler_name),
3268                        default_exception_handler_body, NULL, NULL);
3269 
3270 /*
3271  * Entry point of throwing exception.
3272  *
3273  *  This function can be called from Scheme function raise,
3274  *  or C-function Scm_Error families and signal handler. 
3275  *  So there may be a raw C code in the continuation of this C call.
3276  *  Thus we can't use Scm_VMApply to call the user-defined exception
3277  *  handler.
3278  *  Note that this function may return.
3279  */
3280 ScmObj Scm_VMThrowException(ScmVM *vm, ScmObj exception)
3281 {
3282     ScmEscapePoint *ep = vm->escapePoint;
3283 
3284     SCM_VM_RUNTIME_FLAG_CLEAR(vm, SCM_ERROR_BEING_HANDLED);
3285 
3286     if (vm->exceptionHandler != DEFAULT_EXCEPTION_HANDLER) {
3287         vm->val0 = Scm_Apply(vm->exceptionHandler, SCM_LIST1(exception));
3288         if (SCM_SERIOUS_CONDITION_P(exception)) {
3289             /* the user-installed exception handler returned while it
3290                shouldn't.  In order to prevent infinite loop, we should
3291                pop the erroneous handler.  For now, we just reset
3292                the current exception handler. */
3293             vm->exceptionHandler = DEFAULT_EXCEPTION_HANDLER;
3294             Scm_Error("user-defined exception handler returned on non-continuable exception %S", exception);
3295         }
3296         return vm->val0;
3297     } else if (!SCM_SERIOUS_CONDITION_P(exception)) {
3298         /* The system's default handler does't care about
3299            continuable exception.  See if there's a user-defined
3300            exception handler in the chain.  */
3301         for (; ep; ep = ep->prev) {
3302             if (ep->xhandler != DEFAULT_EXCEPTION_HANDLER) {
3303                 return Scm_Apply(ep->xhandler, SCM_LIST1(exception));
3304             }
3305         }
3306     }
3307     Scm_VMDefaultExceptionHandler(exception);
3308     /* this never returns */
3309 }
3310 
3311 /*
3312  * with-error-handler
3313  */
3314 static ScmObj install_ehandler(ScmObj *args, int nargs, void *data)
3315 {
3316     ScmEscapePoint *ep = (ScmEscapePoint*)data;
3317     ScmVM *vm = theVM;
3318     vm->exceptionHandler = DEFAULT_EXCEPTION_HANDLER;
3319     vm->escapePoint = ep;
3320     SCM_VM_RUNTIME_FLAG_CLEAR(vm, SCM_ERROR_BEING_REPORTED);
3321     return SCM_UNDEFINED;
3322 }
3323 
3324 static ScmObj discard_ehandler(ScmObj *args, int nargs, void *data)
3325 {
3326     ScmEscapePoint *ep = (ScmEscapePoint *)data;
3327     ScmVM *vm = theVM;
3328     vm->escapePoint = ep->prev;
3329     vm->exceptionHandler = ep->xhandler;
3330     if (ep->errorReporting) {
3331         SCM_VM_RUNTIME_FLAG_SET(vm, SCM_ERROR_BEING_REPORTED);
3332     }
3333     return SCM_UNDEFINED;
3334 }
3335 
3336 ScmObj Scm_VMWithErrorHandler(ScmObj handler, ScmObj thunk)
3337 {
3338     ScmVM *vm = theVM;
3339     ScmEscapePoint *ep = SCM_NEW(ScmEscapePoint);
3340     ScmObj before, after;
3341 
3342     /* NB: we can save pointer to the stack area (vm->cont) to ep->cont,
3343      * since such ep is always accessible via vm->escapePoint chain and
3344      * ep->cont is redirected whenever the continuation is captured while
3345      * ep is valid.
3346      */
3347     ep->prev = vm->escapePoint;
3348     ep->floating = SCM_VM_FLOATING_EP(vm);
3349     ep->ehandler = handler;
3350     ep->handlers = vm->handlers;
3351     ep->cstack = vm->cstack;
3352     ep->xhandler = vm->exceptionHandler;
3353     ep->cont = vm->cont;
3354     ep->errorReporting =
3355         SCM_VM_RUNTIME_FLAG_IS_SET(vm, SCM_ERROR_BEING_REPORTED);
3356     
3357     vm->escapePoint = ep; /* This will be done in install_ehandler, but
3358                              make sure ep is visible from save_cont
3359                              to redirect ep->cont */
3360     before = Scm_MakeSubr(install_ehandler, ep, 0, 0, SCM_FALSE);
3361     after  = Scm_MakeSubr(discard_ehandler, ep, 0, 0, SCM_FALSE);
3362     return Scm_VMDynamicWind(before, thunk, after);
3363 }
3364 
3365 /* 
3366  * with-exception-handler
3367  *
3368  *   This primitive gives the programmer whole responsibility of
3369  *   dealing with exceptions.
3370  */
3371 
3372 static ScmObj install_xhandler(ScmObj *args, int nargs, void *data)
3373 {
3374     theVM->exceptionHandler = SCM_OBJ(data);
3375     return SCM_UNDEFINED;
3376 }
3377 
3378 ScmObj Scm_VMWithExceptionHandler(ScmObj handler, ScmObj thunk)
3379 {
3380     ScmObj current = theVM->exceptionHandler;
3381     ScmObj before = Scm_MakeSubr(install_xhandler, handler, 0, 0, SCM_FALSE);
3382     ScmObj after  = Scm_MakeSubr(install_xhandler, current, 0, 0, SCM_FALSE);
3383     return Scm_VMDynamicWind(before, thunk, after);
3384 }
3385 
3386 /*==============================================================
3387  * Call With Current Continuation
3388  */
3389 
3390 /* Figure out which before and after thunk should be called. */
3391 static ScmObj throw_cont_calculate_handlers(ScmEscapePoint *ep, /*target*/
3392                                             ScmVM *vm)
3393 {
3394     ScmObj target  = Scm_Reverse(ep->handlers);
3395     ScmObj current = vm->handlers;
3396     ScmObj h = SCM_NIL, t = SCM_NIL, p;
3397 
3398     SCM_FOR_EACH(p, current) {
3399         SCM_ASSERT(SCM_PAIRP(SCM_CAR(p)));
3400         if (!SCM_FALSEP(Scm_Memq(SCM_CAR(p), target))) break;
3401         /* push 'after' handlers to be called */
3402         SCM_APPEND1(h, t, SCM_CDAR(p));
3403     }
3404     SCM_FOR_EACH(p, target) {
3405         SCM_ASSERT(SCM_PAIRP(SCM_CAR(p)));
3406         if (!SCM_FALSEP(Scm_Memq(SCM_CAR(p), current))) continue;
3407         /* push 'before' handlers to be called */
3408         SCM_APPEND1(h, t, SCM_CAAR(p));
3409     }
3410     return h;
3411 }
3412 
3413 static ScmObj throw_cont_cc(ScmObj, void **);
3414 
3415 static ScmObj throw_cont_body(ScmObj handlers,    /* after/before thunks
3416                                                      to be called */
3417                               ScmEscapePoint *ep, /* target continuation */
3418                               ScmObj args)        /* args to pass to the
3419                                                      target continuation */ 
3420 {
3421     void *data[3];
3422     int nargs, i;
3423     ScmObj ap;
3424     ScmVM *vm = theVM;
3425 
3426     /*
3427      * first, check to see if we need to evaluate dynamic handlers.
3428      */
3429     if (SCM_PAIRP(handlers)) {
3430         data[0] = (void*)SCM_CDR(handlers);
3431         data[1] = (void*)ep;
3432         data[2] = (void*)args;
3433         Scm_VMPushCC(throw_cont_cc, data, 3);
3434         return Scm_VMApply0(SCM_CAR(handlers));
3435     }
3436 
3437     /*
3438      * now, install the target continuation
3439      */
3440     vm->pc = PC_TO_RETURN;
3441     vm->cont = ep->cont;
3442 
3443     nargs = Scm_Length(args);
3444     if (nargs == 1) {
3445         return SCM_CAR(args);
3446     } else if (nargs < 1) {
3447         return SCM_UNDEFINED;
3448     } else if (nargs >= SCM_VM_MAX_VALUES) {
3449         Scm_Error("too many values passed to the continuation");
3450     }
3451 
3452     for (i=0, ap=SCM_CDR(args); SCM_PAIRP(ap); i++, ap=SCM_CDR(ap)) {
3453         vm->vals[i] = SCM_CAR(ap);
3454     }
3455     vm->numVals = nargs;
3456     return SCM_CAR(args);
3457 }
3458 
3459 static ScmObj throw_cont_cc(ScmObj result, void **data)
3460 {
3461     ScmObj handlers = SCM_OBJ(data[0]);
3462     ScmEscapePoint *ep = (ScmEscapePoint *)data[1];
3463     ScmObj args = SCM_OBJ(data[2]);
3464     return throw_cont_body(handlers, ep, args);
3465 }
3466 
3467 /* Body of the continuation SUBR */
3468 static ScmObj throw_continuation(ScmObj *argframe, int nargs, void *data)
3469 {
3470     ScmEscapePoint *ep = (ScmEscapePoint*)data;
3471     ScmVM *vm = theVM;
3472     ScmObj args = argframe[0];
3473 
3474     if (vm->cstack != ep->cstack) {
3475         ScmCStack *cstk;
3476         for (cstk = vm->cstack; cstk; cstk = cstk->prev) {
3477             if (ep->cstack == cstk) break;
3478         }
3479         if (cstk == NULL) {
3480             Scm_Error("a continuation is thrown outside of it's extent: %p",
3481                       ep);
3482         } else {
3483             /* Rewind C stack */
3484             vm->escapeReason = SCM_VM_ESCAPE_CONT;
3485             vm->escapeData[0] = ep;
3486             vm->escapeData[1] = args;
3487             siglongjmp(vm->cstack->jbuf, 1);
3488         }
3489     } else {
3490         ScmObj handlers_to_call = throw_cont_calculate_handlers(ep, vm);
3491         vm->handlers = ep->handlers;
3492         return throw_cont_body(handlers_to_call, ep, args);
3493     }
3494     return SCM_UNDEFINED; /*dummy*/
3495 }
3496 
3497 ScmObj Scm_VMCallCC(ScmObj proc)
3498 {
3499     ScmObj contproc;
3500     ScmEscapePoint *ep;
3501     ScmVM *vm = theVM;
3502 
3503     if (!SCM_PROCEDUREP(proc)
3504         || (!SCM_PROCEDURE_OPTIONAL(proc) && SCM_PROCEDURE_REQUIRED(proc) != 1)
3505         || (SCM_PROCEDURE_OPTIONAL(proc) && SCM_PROCEDURE_REQUIRED(proc) > 1))
3506         Scm_Error("Procedure taking one argument is required, but got: %S",
3507                   proc);
3508 
3509     save_cont(vm);
3510     ep = SCM_NEW(ScmEscapePoint);
3511     ep->prev = NULL;
3512     ep->ehandler = SCM_FALSE;
3513     ep->cont = vm->cont;
3514     ep->handlers = vm->handlers;
3515     ep->cstack = vm->cstack;
3516 
3517     contproc = Scm_MakeSubr(throw_continuation, ep, 0, 1,
3518                             SCM_MAKE_STR("continuation"));
3519     return Scm_VMApply1(proc, contproc);
3520 }
3521 
3522 /*==============================================================
3523  * Values
3524  */
3525 
3526 ScmObj Scm_Values(ScmObj args)
3527 {
3528     ScmVM *vm = theVM;
3529     ScmObj cp;
3530     int nvals;
3531     
3532     if (!SCM_PAIRP(args)) {
3533         vm->numVals = 0;
3534         return SCM_UNDEFINED;
3535     }
3536     nvals = 1;
3537     SCM_FOR_EACH(cp, SCM_CDR(args)) {
3538         vm->vals[nvals-1] = SCM_CAR(cp);
3539         if (nvals++ >= SCM_VM_MAX_VALUES) {
3540             Scm_Error("too many values: %S", args);
3541         }
3542     }
3543     vm->numVals = nvals;
3544     return SCM_CAR(args);
3545 }
3546 
3547 ScmObj Scm_Values2(ScmObj val0, ScmObj val1)
3548 {
3549     ScmVM *vm = theVM;
3550     vm->numVals = 2;
3551     vm->vals[0] = val1;
3552     return val0;
3553 }
3554 
3555 ScmObj Scm_Values3(ScmObj val0, ScmObj val1, ScmObj val2)
3556 {
3557     ScmVM *vm = theVM;
3558     vm->numVals = 3;
3559     vm->vals[0] = val1;
3560     vm->vals[1] = val2;
3561     return val0;
3562 }
3563 
3564 ScmObj Scm_Values4(ScmObj val0, ScmObj val1, ScmObj val2, ScmObj val3)
3565 {
3566     ScmVM *vm = theVM;
3567     vm->numVals = 4;
3568     vm->vals[0] = val1;
3569     vm->vals[1] = val2;
3570     vm->vals[2] = val3;
3571     return val0;
3572 }
3573 
3574 ScmObj Scm_Values5(ScmObj val0, ScmObj val1, ScmObj val2, ScmObj val3, ScmObj val4)
3575 {
3576     ScmVM *vm = theVM;
3577     vm->numVals = 5;
3578     vm->vals[0] = val1;
3579     vm->vals[1] = val2;
3580     vm->vals[2] = val3;
3581     vm->vals[3] = val4;
3582     return val0;
3583 }
3584 
3585 /*==================================================================
3586  * Queued handler processing.
3587  */
3588 
3589 /* Signal handlers and finalizers are queued in VM when they
3590  * are requested, and processed when VM is in consistent state.
3591  * process_queued_requests() are called near the beginning of
3592  * VM loop, when the VM checks if there's any queued request.
3593  *
3594  * When this procedure is called, VM is in middle of any two
3595  * VM instructions.  We need to make sure the handlers won't
3596  * disturb the VM state.
3597  *
3598  * Conceptually, this procedure inserts handler invocations before
3599  * the current continuation.
3600  */
3601 
3602 static ScmObj process_queued_requests_cc(ScmObj result, void **data)
3603 {
3604     /* restore the saved continuation of normal execution flow of VM */
3605     int i;
3606     ScmObj cp;
3607     ScmVM *vm = theVM;
3608     vm->numVals = (int)data[0];
3609     vm->val0 = data[1];
3610     if (vm->numVals > 1) {
3611         cp = SCM_OBJ(data[2]);
3612         for (i=0; i<vm->numVals-1; i++) {
3613             vm->vals[i] = SCM_CAR(cp);
3614             cp = SCM_CDR(cp);
3615         }
3616     }
3617     return vm->val0;
3618 }
3619 
3620 static void process_queued_requests(ScmVM *vm)
3621 {
3622     void *data[3];
3623 
3624     /* preserve the current continuation */
3625     data[0] = (void*)vm->numVals;
3626     data[1] = vm->val0;
3627     if (vm->numVals > 1) {
3628         int i;
3629         ScmObj h = SCM_NIL, t = SCM_NIL;
3630 
3631         for (i=0; i<vm->numVals-1; i++) {
3632             SCM_APPEND1(h, t, vm->vals[i]);
3633         }
3634         data[2] = h;
3635     } else {
3636         data[2] = NULL;
3637     }
3638     Scm_VMPushCC(process_queued_requests_cc, data, 3);
3639 
3640     /* Process queued stuff.  Currently they call VM recursively,
3641        but we'd better to arrange them to be processed in the same
3642        VM level. */
3643     if (vm->queueNotEmpty & SCM_VM_SIGQ_MASK) {
3644         Scm_SigCheck(vm);
3645     }
3646     if (vm->queueNotEmpty & SCM_VM_FINQ_MASK) {
3647         Scm_VMFinalizerRun(vm);
3648     }
3649 }
3650 
3651 /*==============================================================
3652  * Debug features.
3653  */
3654 
3655 /*
3656  * Stack trace.
3657  *
3658  *   The "lite" version returns a list of source information of
3659  *   continuation frames.
3660  *
3661  *   The full stack trace is consisted by a list of pair of
3662  *   source information and environment vector.  Environment vector
3663  *   is a copy of content of env frame, with the first element
3664  *   be the environment info.   Environment vector may be #f if
3665  *   the continuation frame doesn't have associated env.
3666  */
3667 
3668 ScmObj Scm_VMGetStackLite(ScmVM *vm)
3669 {
3670     ScmContFrame *c = vm->cont;
3671     ScmObj stack = SCM_NIL, tail = SCM_NIL;
3672     ScmObj info;
3673 
3674     info = Scm_VMGetSourceInfo(vm->base, vm->pc);
3675     if (!SCM_FALSEP(info)) SCM_APPEND1(stack, tail, info);
3676     while (c) {
3677         info = Scm_VMGetSourceInfo(c->base, c->pc);
3678         if (!SCM_FALSEP(info)) SCM_APPEND1(stack, tail, info);
3679         c = c->prev;
3680     }
3681     return stack;
3682 }
3683 
3684 #define DEFAULT_ENV_TABLE_SIZE  64
3685 
3686 struct EnvTab {
3687     struct EnvTabEntry {
3688         ScmEnvFrame *env;
3689         ScmObj vec;
3690     } entries[DEFAULT_ENV_TABLE_SIZE];
3691     int numEntries;
3692 };
3693 
3694 static ScmObj env2vec(ScmEnvFrame *env, struct EnvTab *etab)
3695 {
3696     int i;
3697     ScmObj vec;
3698     
3699     if (!env) return SCM_FALSE;
3700     for (i=0; i<etab->numEntries; i++) {
3701         if (etab->entries[i].env == env) {
3702             return etab->entries[i].vec;
3703         }
3704     }
3705     vec = Scm_MakeVector(env->size+2, SCM_FALSE);
3706     SCM_VECTOR_ELEMENT(vec, 0) = env2vec(env->up, etab);
3707     SCM_VECTOR_ELEMENT(vec, 1) = SCM_NIL; /*Scm_VMGetBindInfo(env->info);*/
3708     for (i=0; i<env->size; i++) {
3709         SCM_VECTOR_ELEMENT(vec, i+2) = ENV_DATA(env, (env->size-i-1));
3710     }
3711     if (etab->numEntries < DEFAULT_ENV_TABLE_SIZE) {
3712         etab->entries[etab->numEntries].env = env;
3713         etab->entries[etab->numEntries].vec = vec;
3714         etab->numEntries++;
3715     }
3716     return vec;
3717 }
3718 
3719 ScmObj Scm_VMGetStack(ScmVM *vm)
3720 {
3721 #if 0 /* for now */
3722     ScmContFrame *c = vm->cont;
3723     ScmObj stack = SCM_NIL, tail = SCM_NIL;
3724     ScmObj info, evec;
3725     struct EnvTab envTab;
3726 
3727     envTab.numEntries = 0;
3728     if (SCM_PAIRP(vm->pc)) {
3729         info = Scm_VMGetSourceInfo(vm->pc);
3730         SCM_APPEND1(stack, tail, Scm_Cons(info, env2vec(vm->env, &envTab)));
3731     }
3732     
3733     for (; c; c = c->prev) {
3734         if (!SCM_PAIRP(c->info)) continue;
3735         info = Scm_VMGetSourceInfo(c->info);
3736         evec = env2vec(c->env, &envTab);
3737         SCM_APPEND1(stack, tail, Scm_Cons(info, evec));
3738     }
3739     return stack;
3740 #endif
3741     return SCM_NIL;
3742 }
3743 
3744 /*
3745  * Dump VM internal state.
3746  */
3747 static ScmObj get_debug_info(ScmCompiledCode *base, SCM_PCTYPE pc)
3748 {
3749     int off;
3750     ScmObj ip;
3751     if (base == NULL
3752         || (pc < base->code && pc >= base->code + base->codeSize)) {
3753         return SCM_FALSE;
3754     }
3755     off = pc - base->code - 1;  /* pc is already incremented, so -1. */
3756     SCM_FOR_EACH(ip, base->info) {
3757         ScmObj p = SCM_CAR(ip);
3758         if (!SCM_PAIRP(p) || !SCM_INTP(SCM_CAR(p))) continue;
3759         if (SCM_INT_VALUE(SCM_CAR(p)) < off) {
3760             return SCM_CDR(p);
3761             break;
3762         }
3763     }
3764     return SCM_FALSE;
3765 }
3766 
3767 ScmObj Scm_VMGetSourceInfo(ScmCompiledCode *base, SCM_PCTYPE pc)
3768 {
3769     ScmObj info = get_debug_info(base, pc);
3770     if (SCM_PAIRP(info)) {
3771         ScmObj p = Scm_Assq(SCM_SYM_SOURCE_INFO, info);
3772         if (SCM_PAIRP(p)) return SCM_CDR(p);
3773     }
3774     return SCM_FALSE;
3775 }
3776 
3777 ScmObj Scm_VMGetBindInfo(ScmCompiledCode *base, SCM_PCTYPE pc)
3778 {
3779     ScmObj info = get_debug_info(base, pc);
3780     if (SCM_PAIRP(info)) {
3781         ScmObj p = Scm_Assq(SCM_SYM_BIND_INFO, info);
3782         if (SCM_PAIRP(p)) return SCM_CDR(p);
3783     }
3784     return SCM_FALSE;
3785 }
3786 
3787 static void dump_env(ScmEnvFrame *env, ScmPort *out)
3788 {
3789     int i;
3790     Scm_Printf(out, "   %p %55.1S\n", env, env->info);
3791     Scm_Printf(out, "       up=%p size=%d\n", env->up, env->size);
3792     Scm_Printf(out, "       [");
3793     for (i=0; i<env->size; i++) {
3794         Scm_Printf(out, " %S", ENV_DATA(env, i));
3795     }
3796     Scm_Printf(out, " ]\n");
3797 }
3798 
3799 void Scm_VMDump(ScmVM *vm)
3800 {
3801     ScmPort *out = vm->curerr;
3802     ScmEnvFrame *env = vm->env;
3803     ScmContFrame *cont = vm->cont;
3804     ScmCStack *cstk = vm->cstack;
3805     ScmEscapePoint *ep = vm->escapePoint;
3806 
3807     Scm_Printf(out, "VM %p -----------------------------------------------------------\n", vm);
3808     Scm_Printf(out, "   pc: %08x ", vm->pc);
3809     Scm_Printf(out, "(%08x)\n", *vm->pc);
3810     Scm_Printf(out, "   sp: %p  base: %p  [%p-%p]\n", vm->sp, vm->stackBase,
3811                vm->stack, vm->stackEnd);
3812     Scm_Printf(out, " argp: %p\n", vm->argp);
3813     Scm_Printf(out, " val0: %#65.1S\n", vm->val0);
3814 
3815     Scm_Printf(out, " envs:\n");
3816     while (env) {
3817         dump_env(env, out);
3818         env = env->up;
3819     }
3820     
3821     Scm_Printf(out, "conts:\n");
3822     while (cont) {
3823         Scm_Printf(out, "   %p\n", cont);
3824         Scm_Printf(out, "              env = %p\n", cont->env);
3825         Scm_Printf(out, "             argp = %p[%d]\n", cont->argp, cont->size);
3826         if (cont->argp) {
3827             Scm_Printf(out, "               pc = %p ", cont->pc);
3828             Scm_Printf(out, "(%08x)\n", *cont->pc);
3829         } else {
3830             Scm_Printf(out, "               pc = {cproc %p}\n", cont->pc);
3831         }
3832         Scm_Printf(out, "             base = %p\n", cont->base);
3833         cont = cont->prev;
3834     }
3835 
3836     Scm_Printf(out, "C stacks:\n");
3837     while (cstk) {
3838         Scm_Printf(out, "  %p: prev=%p, cont=%p\n",
3839                    cstk, cstk->prev, cstk->cont);
3840         cstk = cstk->prev;
3841     }
3842     Scm_Printf(out, "Escape points:\n");
3843     while (ep) {
3844         Scm_Printf(out, "  %p: cont=%p, handler=%#20.1S\n",
3845                    ep, ep->cont, ep->ehandler);
3846         ep = ep->prev;
3847     }
3848     Scm_Printf(out, "dynenv: %S\n", vm->handlers);
3849     if (vm->base) {
3850         Scm_Printf(out, "Code:\n");
3851         Scm_CompiledCodeDump(vm->base);
3852     }
3853 }
3854 
3855 #ifdef USE_CUSTOM_STACK_MARKER
3856 struct GC_ms_entry *vm_stack_mark(GC_word *addr,
3857                                   struct GC_ms_entry *mark_sp,
3858                                   struct GC_ms_entry *mark_sp_limit,
3859                                   GC_word env)
3860 {
3861     struct GC_ms_entry *e = mark_sp;
3862     ScmObj *vmsb = ((ScmObj*)addr)+1;
3863     ScmVM *vm = (ScmVM*)*addr;
3864     int i, limit = vm->sp - vm->stackBase + 5;
3865     GC_PTR spb = (GC_PTR)vm->stackBase;
3866     GC_PTR sbe = (GC_PTR)(vm->stackBase + SCM_VM_STACK_SIZE);
3867     GC_PTR hb = GC_least_plausible_heap_addr;
3868     GC_PTR he = GC_greatest_plausible_heap_addr;
3869 
3870     for (i=0; i<limit; i++, vmsb++) {
3871         ScmObj z = *vmsb;
3872         if ((hb < (GC_PTR)z && (GC_PTR)z < spb)
3873             || ((GC_PTR)z > sbe && (GC_PTR)z < he)) {
3874             e = GC_mark_and_push((GC_PTR)z, e, mark_sp_limit, (GC_PTR)addr);
3875         }
3876     }
3877     return e;
3878 }
3879 #endif /*USE_CUSTOM_STACK_MARKER*/
3880 
3881 /*===============================================================
3882  * Initialization
3883  */
3884 
3885 void Scm__InitVM(void)
3886 {
3887 #ifdef USE_CUSTOM_STACK_MARKER
3888     vm_stack_free_list = GC_new_free_list();
3889     vm_stack_mark_proc = GC_new_proc(vm_stack_mark);
3890     vm_stack_kind = GC_new_kind(vm_stack_free_list,
3891                                 GC_MAKE_PROC(vm_stack_mark_proc, 0),
3892                                 0, 0);
3893 #endif /*USE_CUSTOM_STACK_MARKER*/
3894 
3895     /* Create root VM */
3896 #ifdef GAUCHE_USE_PTHREADS
3897     if (pthread_key_create(&vm_key, NULL) != 0) {
3898         Scm_Panic("pthread_key_create failed.");
3899     }
3900     rootVM = Scm_NewVM(NULL, SCM_MAKE_STR_IMMUTABLE("root"));
3901     if (pthread_setspecific(vm_key, rootVM) != 0) {
3902         Scm_Panic("pthread_setspecific failed.");
3903     }
3904     rootVM->thread = pthread_self();
3905 #else   /* !GAUCHE_USE_PTHREADS */
3906     rootVM = theVM = Scm_NewVM(NULL, SCM_MAKE_STR_IMMUTABLE("root"));
3907 #endif  /* !GAUCHE_USE_PTHREADS */
3908     rootVM->state = SCM_VM_RUNNABLE;
3909 
3910 #ifdef COUNT_INSN_FREQUENCY
3911     Scm_AddCleanupHandler(dump_insn_frequency, NULL);
3912 #endif /*COUNT_INSN_FREQUENCY*/
3913 }
3914 

/* [<][>][^][v][top][bottom][index][help] */