/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_NewVM
- Scm_AttachVM
- Scm_VMGetResult
- Scm_VMSetResult
- Scm_VM
- Scm_VMKey
- run_loop
- save_env
- save_cont
- save_stack
- get_env
- Scm_VMApply
- Scm_VMApply0
- Scm_VMApply1
- Scm_VMApply2
- Scm_VMApply3
- Scm_VMApply4
- eval_restore_env
- Scm_VMEval
- user_eval_inner
- Scm_Eval
- Scm_EvalCString
- Scm_Apply
- Scm_VMPushCC
- Scm_VMDynamicWind
- dynwind_before_cc
- dynwind_body_cc
- dynwind_after_cc
- Scm_VMDynamicWindC
- Scm_VMDefaultExceptionHandler
- default_exception_handler_body
- Scm_VMThrowException
- install_ehandler
- discard_ehandler
- Scm_VMWithErrorHandler
- install_xhandler
- Scm_VMWithExceptionHandler
- throw_cont_calculate_handlers
- throw_cont_body
- throw_cont_cc
- throw_continuation
- Scm_VMCallCC
- Scm_Values
- Scm_Values2
- Scm_Values3
- Scm_Values4
- Scm_Values5
- process_queued_requests_cc
- process_queued_requests
- Scm_VMGetStackLite
- env2vec
- Scm_VMGetStack
- get_debug_info
- Scm_VMGetSourceInfo
- Scm_VMGetBindInfo
- dump_env
- Scm_VMDump
- vm_stack_mark
- 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