1 /* -*- tab-width:4; -*- */
2 /*
3 * Try for a virtual machine using special GCC features
4 *
5 *
6 * Inspired by gforth
7 *
8 * $Id: vm2.c 1.33.1.34 Wed, 19 Apr 2000 22:43:15 +0200 crad $
9 *
10 */
11 #define __VM2_INTERNAL__
12 #include "s.h"
13 #include "heap.h"
14 #include "vm2.h"
15
16 /*
17 #define ENGINE_TRACE
18 */
19
20 /* #define DEBUG_VM_JUMP */
21 /* #define DEBUG_VM_CLOSURE */
22
23 #define USE_TOS
24 #define INUM_OPTIMIZATION
25
26 typedef void *Label;
27
28 int scm_op_max; /* number of opcode */
29
30 void *scm_op_low_addr; /* low and high address for opcodes */
31 void *scm_op_high_addr;
32
33 #ifndef SCM_WITH_THREADS
34 SCM_VMD scm_vmdata; /* the only thread */
35 #endif
36
37 /*-- stack macros */
38 #ifdef STACK_CHECKS
39 #define check_overflow() if (sp <= sp_base) goto l_overflow
40 #define check_sunderflow() if (sp > sp0) goto l_underflow
41 #else
42 #define check_soverflow()
43 #define check_sunderflow()
44 #endif
45
46
47 static SOBJ *scm_print_op(SOBJ *code);
48
49 /********************************
50 * VM and REGS support
51 ********************************/
52
53 /* reset all vm registers */
scm_vmd_regs_reset(SCM_VMD * vm)54 void scm_vmd_regs_reset(SCM_VMD *vm)
55 {
56 vm->reg.sp = vm->stack_limit;
57 vm->reg.ip = NULL;
58 vm->reg.cont = NULL;
59 vm->reg.env = NULL;
60 }
61
62 /* dump the contents of a SCM_VMD structure */
scm_vmd_dump(SCM_VMD * vm)63 void scm_vmd_dump(SCM_VMD *vm)
64 {
65 printf("VM at %p:\n", vm);
66 printf(" code = %d\n", vm->code);
67 printf(" regs: sp=%p ip=%p cont=%p env=%p\n",
68 vm->reg.sp, vm->reg.ip, vm->reg.cont, vm->reg.env);
69 printf(" stack: base=%p limit=%p size=%d\n",
70 vm->stack_base, vm->stack_limit, vm->stack_size);
71 printf("arg=%p ret=%p\n", vm->arg.addr, vm->ret.ptr);
72
73 }
74
75 /* alloc a stack for a vm */
scm_vmd_stack_alloc(SCM_VMD * vm,int size)76 void scm_vmd_stack_alloc(SCM_VMD *vm, int size)
77 {
78 vm->stack_size = size;
79 vm->stack_base = scm_must_alloc(sizeof(SOBJ)*size);
80 vm->stack_limit = vm->stack_base + size;
81 scm_vmd_regs_reset(vm);
82 }
83
84 /* free stack */
scm_vmd_stack_free(SCM_VMD * vm)85 void scm_vmd_stack_free(SCM_VMD *vm)
86 {
87 if (vm->stack_base) scm_free(vm->stack_base);
88 vm->stack_base = NULL;
89 vm->stack_limit = NULL;
90 vm->stack_size = 0;
91 scm_vmd_regs_reset(vm); /* clear registers to disable access */
92 }
93
scm_vmd_new()94 SCM_VMD *scm_vmd_new()
95 {
96 SCM_VMD *vmd = scm_must_alloc(sizeof(SCM_VMD));
97 return(vmd);
98 }
99
100 /********************************
101 * Stack
102 ********************************/
103
sdump(SCM_VMD * vm)104 void sdump(SCM_VMD *vm)
105 {
106 SOBJ *p;
107
108 scm_puts("stack: ");
109 #ifdef TOP_TO_BOTTOM
110 p = vm->stack_limit;
111 while(--p >= vm->reg.sp) {
112 scm_cdisplay(*p); scm_putc(' ');
113 }
114 #else
115 p = vm->reg.sp;
116 while(p < vm->stack_limit) {
117 scm_cdisplay(*p++); scm_putc(' ');
118 }
119 #endif
120 scm_putc('\n');
121 }
122
123
124 /****************************************************************
125 * Debugging functions (to be use in the scm_vm function)
126 ****************************************************************/
127
128 #ifdef ENGINE_TRACE
129
dump_stack(SOBJ * p,SOBJ * l)130 static void dump_stack(SOBJ *p, SOBJ *l)
131 {
132 while(p < l) {
133 printf(" %p: ", p); scm_cprint(*p++);
134 }
135 }
136
137 #define SDUMP() \
138 { \
139 *sp=TOS; \
140 printf("S stack: depth=%d\n", vm->stack_limit - sp); \
141 dump_stack(sp, (SOBJ*)cont); \
142 }
143
144 #define EDUMP() \
145 { \
146 printf("\ncode: "); scm_print_op(ip); \
147 printf("ip=%p cont=%p env=%p\n", ip, cont, env); \
148 }
149
150 #define ENV_DUMP() scm_dump_env(env)
151 #define CONT_DUMP() scm_dump_cont(cont)
152
153
154 #define DUMPSTATE() { SDUMP(); ENV_DUMP(); CONT_DUMP(); EDUMP(); }
155 #define NEXT { DUMPSTATE(); goto *(*ip++);}
156 #else
157 #define NEXT {goto *(*ip++);}
158 #endif
159
160 /*-- number of args in a var arg primitive :
161 * must be called before the sp moves :-)
162 */
163 #define NARGS ((SOBJ *)cont - sp)
164
165 #ifdef WHY_THIS
166 /*-- return from a variable arg function */
167 #define VRETURN(value) \
168 { \
169 SOBJ r=value; \
170 sp=(void*)cont+(sizeof(SCM_ContFrame)-sizeof(SOBJ)); \
171 cont=cont->next; \
172 TOS=r; \
173 NEXT; \
174 }
175 #endif /* WHY_THIS */
176
177 /*-- return from a variable arg function */
178 #define VRETURN(value) \
179 { \
180 TOS=value; \
181 sp=(void*)cont+(sizeof(SCM_ContFrame)-sizeof(SOBJ)); \
182 cont=cont->next; \
183 NEXT; \
184 }
185
186 #define RETURN(value) { TOS=(value); NEXT; }
187
188 #define Prim(name,str,nargs) l_##name: /* str */
189 #define PrimVarargs(name,str) l_##name: /* str */
190
191
192 /****************************************************************
193 * Debug and print functions
194 ****************************************************************/
195
scm_dump_cont(SCM_ContFrame * c)196 void scm_dump_cont(SCM_ContFrame *c)
197 {
198 printf("Continuations:\n");
199 while(c) {
200 printf(" cont %p: next=%p env=%p ip=%p\n", c, c->next, c->env, c->ip);
201 c = c->next;
202 }
203 }
204
scm_dump_env(SOBJ e)205 void scm_dump_env(SOBJ e)
206 {
207 int i, l;
208 while(e) {
209 l = SCM_INUM(SCM_ENV_FRAME(e)->nslots);
210 printf(" env %p: next=%p nslots=%d\n",
211 e, SCM_ENV_NEXT(e), l);
212 if (l > 20) l = 20;
213 for (i = 0; i < l; i++) {
214 printf(" binding[%d] = ", i); scm_cprint(SCM_ENV_FRAME(e)->binding[i]);
215 }
216 if (SCM_INUM(SCM_ENV_FRAME(e)->nslots) != l) {
217 printf(" ...\n");
218 }
219 e = SCM_ENV_NEXT(e);
220 }
221 }
222
223 /****************************************************************
224 * vm function type
225 ****************************************************************/
scm_vmfunc_mark(SOBJ obj)226 void scm_vmfunc_mark(SOBJ obj)
227 {
228 }
229
scm_vmfunc_sweep(SOBJ obj)230 void scm_vmfunc_sweep(SOBJ obj)
231 {
232 }
233
234 /****************************************************************
235 * NEW ENGINE
236 ****************************************************************/
237
238 /****************************************************************
239 *
240 * Virtual Machine Registers:
241 * ENV: points to the current environment chain
242 * CONT points to the current continuation chain
243 * IP points to the instruction to execute
244 * SP points to the current stack position
245 * TOS cache of the top of stack value...
246 *
247 ****************************************************************/
248
249 /****************************************************************
250 * Engine: helper functions and macros
251 ****************************************************************/
252
scm_clone_env(SOBJ env)253 static SOBJ scm_clone_env(SOBJ env)
254 {
255 SOBJ new;
256 SCM_EnvFrame *ef;
257 int nbytes;
258
259 new = scm_newcell(SOBJ_T_ENV);
260 ef = SCM_ENV_FRAME(env);
261 nbytes = offsetof(SCM_EnvFrame, binding[SCM_INUM(ef->nslots)]);
262
263 /* SCM_ENV_NEXT(new) = NULL; */
264 SCM_ENV_FRAME(new) = scm_must_alloc(nbytes);
265 memcpy(SCM_ENV_FRAME(new), ef, nbytes);
266 return(new);
267 }
268
mk_persistent_env(SOBJ env,void * sbase,void * slimit)269 static SOBJ mk_persistent_env(SOBJ env, void *sbase, void *slimit)
270 {
271 SOBJ e, new, last, chain;
272
273 if ((void*)env >= sbase && (void *)env < slimit) { /* on stack */
274 #ifdef DEBUG_VM_CLOSURE
275 printf("mk_persistent_env: env on stack\n");
276 #endif
277 chain = NULL; last = NULL;
278 for (e = env; e; e = SCM_ENV_NEXT(e)) {
279 new = scm_clone_env(e);
280 #ifdef DEBUG_VM_CLOSURE
281 printf("mk_persistent_env: cloned "); scm_cprint(new);
282 #endif
283 if (last) {
284 SCM_ENV_NEXT(last) = new;
285 } else {
286 chain = new;
287 }
288 last = new;
289 }
290 } else {
291 #ifdef DEBUG_VM_CLOSURE
292 printf("mk_persistent_env: head not on stack\n");
293 #endif
294 for (e = env; e; e = SCM_ENV_NEXT(e)) {
295 if (! ((void*)e >= sbase && (void *)e < slimit) ) {
296 #ifdef DEBUG_VM_CLOSURE
297 printf("mk_persistent_env: EnvFrame still on stack");
298 scm_cprint(e);
299 #endif
300 }
301 }
302 chain = env;
303 }
304 return(chain);
305 }
306
307
copy_closure_env(SOBJ closure,SOBJ env,void * sbase,void * slimit)308 static void copy_closure_env(SOBJ closure, SOBJ env,
309 void *sbase, void *slimit)
310 {
311 SOBJ clenv;
312 SOBJ e, *p;
313
314 /* printf("copy_closure_env: env chain before:\n"); scm_dump_env(env); */
315
316 clenv = SCM_CLOSURE_ENV(closure);
317 if (clenv != NULL && /* not null */
318 ((void*)clenv >= sbase && (void*)clenv < slimit)) { /* on stack */
319 printf("copy_closure_env: env of closure @%p is on stack\n", closure);
320
321 p = &SCM_CLOSURE_ENV(closure);
322
323 for (e = env; e != NULL; e = SCM_ENV_NEXT(e)) {
324 *p = scm_clone_env(e);
325 p = &SCM_ENV_NEXT(*p);
326 }
327 }
328 /* printf("copy_closure_env: env chain after:\n");
329 scm_dump_env(SCM_CLOSURE_ENV(closure));
330 */
331 }
332
333 /*
334 * Copy the stack. Works also with overlapping areas.
335 */
scm_vm_move_stack(SOBJ * dst,SOBJ * src,int nitems)336 inline void scm_vm_move_stack(SOBJ *dst, SOBJ *src, int nitems)
337 {
338 if (src == dst || nitems == 0)
339 return;
340
341 if (dst < src) { /* copy down */
342 while(nitems-- > 0)
343 *dst++ = *src++;
344
345 } else { /* copy up */
346 dst += nitems;
347 src += nitems;
348 while(nitems-- > 0)
349 *(--dst) = *(--src);
350 }
351 }
352
353
354 #define PUSH_CONT() { \
355 vm->reg.sp = sp; supdate(); \
356 sp -= sizeof(SCM_ContFrame)/sizeof(SOBJ); \
357 *sp = TOS = (SOBJ)cont; \
358 cont = (SCM_ContFrame*)sp; \
359 cont->env = NULL; cont->ip = NULL; \
360 }
361
362 /*-- pop continuation, restore registers saved in cont */
363 #define POP_CONT() \
364 { \
365 sp = (void*)cont + sizeof(SCM_ContFrame) - sizeof(SOBJ); \
366 ip = cont->ip; env = cont->env; \
367 cbinding = (env) ? SCM_ENV_FRAME(env)->binding : NULL; \
368 cont = cont->next; \
369 }
370
371 /*-- push an environement object on the stack.
372 *
373 * The stack transformation is :
374 *
375 * arg#n-1 ... arg0 -- arg#n-1 ... arg0 nslots [env_object]
376 *
377 * - the args and nslots are packed in an SCM_EnvFrame structure
378 * - the new env_object use this for it's env link.
379 * - the env register points to the env_object
380 * - the cbinding variable points to first argument (arg0)
381 *
382 * Note: all this circus is to avoid allocating cell each time a
383 * temporary environment is created. Temporary environments (stored on
384 * the stack) are copied to heap when a closure object is returned.
385 *
386 */
387 #define PUSH_ENV_FRAME(nextenv, nslots) \
388 { \
389 SCM_EnvFrame *ef; \
390 cbinding = sp; \
391 *(--sp) = SCM_MKINUM(nslots); \
392 ef = (SCM_EnvFrame*)sp; \
393 /* alloc space on stack for an env object and fill it's frame and \
394 next fields */ \
395 /*((void*)sp) -= sizeof(Sobject);*/ \
396 sp = ((void*)sp) - sizeof(Sobject); \
397 SCM_ENV_FRAME((SOBJ)sp) = ef; \
398 SCM_ENV_NEXT((SOBJ)sp) = nextenv; \
399 env = (SOBJ)sp; \
400 }
401
402 #define COMPLETE_ENV(proc) \
403 { \
404 SOBJ env_obj = SCM_PROC_ENV(proc); \
405 SCM_EnvFrame *sf = SCM_ENV_FRAME(env_obj); \
406 sp[0] = TOS; \
407 PUSH_ENV_FRAME(SCM_ENV_NEXT(env_obj), SCM_INUM(sf->nslots)); \
408 }
409
410 /* save/restore vm registers to/from a SCM_vmRegisters structure */
411
412 #define SCM_SAVE_VMREGS(x) \
413 { *sp = TOS; (x)->sp = sp; (x)->ip = ip; (x)->cont = cont; (x)->env = env; }
414
415 #define SCM_RESTORE_VMREGS(x) \
416 { sp = (x)->sp; ip = (x)->ip; cont = (x)->cont; env = (x)->env; \
417 TOS = *sp; }
418
419 #define SCM_RESTORE_CBINDING() \
420 { cbinding = (env) ? SCM_ENV_FRAME(env)->binding : NULL; }
421
422
423 /*** the vm itself */
scm_vm(SCM_VMD * vm)424 void scm_vm(SCM_VMD *vm)
425 {
426 register SOBJ *ip IPREG;
427 register SOBJ *sp SPREG;
428 register SOBJ TOS TOSREG;
429 register SCM_ContFrame *cont;
430 register SOBJ env;
431
432 SOBJ r0; /* gp register */
433 SOBJ *cbinding; /* current bindings */
434
435 SOBJ proc; /* current proc during callv and jumpv */
436 SOBJ *src, *dst; /* global src and dst for stack copy */
437
438 SOBJ *sp_base;
439
440 static SCM_PRIM_TABLE symbol[] = {
441 /* address name narg,follow,term*/
442 {&&l_nop, "%nop", 0, 0, 0 },
443 {&&l_end, "%end", 0, 0, 1 },
444
445 {&&l_dolet, "%dolet", 0, 0, 0 },
446 {&&l_doletstar, "%dolet*", 0, 1, 0 },
447 {&&l_endlet_jump, "%endlet-jump", 0, 0, 0 },
448
449 {&&l_drop, "%drop", 0, 0, 0 },
450 {&&l_push, "%push", 0, 1, 0 },
451 {&&l_pushv, "%pushv", 0, 1, 0 },
452 {&&l_pushn, "%pushn", 0, 1, 0 },
453 {&&l_pushl, "%pushl", 0, 1, 0 },
454 {&&l_pushl0, "%pushl0", 0, 1, 0 },
455 {&&l_pushl1, "%pushl1", 0, 1, 0 },
456 {&&l_pushl2, "%pushl2", 0, 1, 0 },
457 {&&l_pushl3, "%pushl3", 0, 1, 0 },
458 {&&l_alloc, "%alloc", 0, 1, 0 },
459 {&&l_pushlist, "%pushlist", 0, 1, 0 },
460
461 {&&l_mark, "%mark", 0, 0, 0 },
462 {&&l_mkclosure, "%mkclosure", 0, 0, 0 },
463 {&&l_endlet, "%endlet", 0, 0, 0 },
464 {&&l_return, "%return", 0, 0, 0 },
465 {&&l_callc, "%callc", 0, 0, 0 },
466 {&&l_callc0, "%callc0", 0, 0, 0 },
467 {&&l_callc1, "%callc1", 0, 0, 0 },
468 {&&l_callc2, "%callc2", 0, 0, 0 },
469 {&&l_callc3, "%callc3", 0, 0, 0 },
470 {&&l_callc4, "%callc4", 0, 0, 0 },
471 {&&l_callc5, "%callc5", 0, 0, 0 },
472 {&&l_callc6, "%callc6", 0, 0, 0 },
473 {&&l_callc7, "%callc7", 0, 0, 0 },
474 {&&l_callc8, "%callc8", 0, 0, 0 },
475 {&&l_callc9, "%callc9", 0, 0, 0 },
476 {&&l_callc10, "%callc10", 0, 0, 0 },
477 {&&l_calls, "%calls", 0, 0, 0 },
478
479 {&&l_no_call, "%no-call", 0, 0, 0,},
480 {&&l_jump, "%jump", 0, 0, 0,},
481 {&&l_call, "%call", 0, 0, 0,},
482 {&&l_call_prim, "%call-prim", 0, 0, 0,},
483 {&&l_call_cprim, "%call-cprim", 0, 0, 0,},
484 {&&l_call_code, "%call-code", 0, 0, 0,},
485 {&&l_call_proc, "%call-proc", 0, 0, 0,},
486 {&&l_call_closure, "%call-closure", 0, 0, 0,},
487 {&&l_call_macro, "%call-macro", 0, 0, 0,},
488 {&&l_call_extfunc, "%call-extfunc", 0, 0, 0,},
489 {&&l_call_vmfunc, "%call-vmfunc", 0, 0, 0,},
490
491 {&&l_catch, "%catch", 2, 1, 0,},
492 {&&l_uncatch, "%uncatch", 0, 0, 0,},
493
494 {&&l_store, "%store-global", 0, 0, 0 },
495 {&&l_setl, "%setl", 0, 1, 0 },
496 {&&l_setl0, "%setl0", 0, 1, 0 },
497 {&&l_setl0drop, "%setl0drop", 0, 1, 0 },
498 {&&l_getvar, "%getvar", 1, 0, 0 },
499 {&&l_setvar, "%setvar", 2, 0, 0 },
500 {&&l_br_and, "%br_and", 0, 1, 0 },
501 {&&l_br_or, "%br_or", 0, 1, 0 },
502 {&&l_br_cond, "%br_cond", 0, 1, 0 },
503 {&&l_br_while, "%br_while", 0, 1, 0 },
504 {&&l_bra, "%bra", 0, 1, 0 },
505 {&&l_brf, "%brf", 0, 1, 0 },
506 {&&l_brt, "%brt", 0, 1, 0 },
507
508 {&&l_save_r0, "%save_r0", 0, 0, 0 },
509 {&&l_load_r0, "%load_r0", 0, 0, 0 },
510
511 #include "prim2.x"
512 #include "number.x"
513 { NULL }
514 };
515
516 if (vm->code != SCM_VM_DO_EXECUTE) {
517 if (vm->code == SCM_VM_DO_INIT) {
518 /********************************
519 * VM initialization
520 ********************************/
521
522 int i, opc;
523
524 /* if already initialized returns symbol */
525 if ((void*)scm_type_hook[0].execute == &&l_nop) {
526 printf("scm_vm: already initialized\n");
527 return;
528 }
529
530 /* scm_type_hook and fix the execute field */
531 for (i = 0; i < scm_type_next_descr; i++) {
532 opc = scm_type_hook[i].execute;
533 if (opc >= 0 && opc < SCM_OP_MAX) {
534 scm_type_hook[i].execute = (long)symbol[opc].address;
535 }
536 }
537
538 #ifdef CHECK_ODDITY
539 for (i = 0; symbol[i].name; i++) {
540 if ( ((long) symbol[i].address & 1) != 0) {
541 printf("scm_vm: oops: opcode %s at %p is not odd\n",
542 symbol[i].name, symbol[i].address);
543 }
544 }
545 #endif
546
547 /* register primitive functions and set scm_op_max,
548 * scm_op_low_addr and scm_op_high_addr */
549 scm_op_low_addr = (void*)-1;
550 scm_op_high_addr = (void*)0;
551 for (i = 0; symbol[i].name; i++) {
552
553 if (symbol[i].name[0] != '%') /* don't register vm internals */
554 scm_add_prim(symbol[i].name, symbol + i);
555
556 if (scm_op_low_addr > symbol[i].address)
557 scm_op_low_addr = symbol[i].address;
558
559 if (scm_op_high_addr < symbol[i].address)
560 scm_op_high_addr= symbol[i].address;
561 }
562 scm_op_max = i;
563 return;
564
565 } else if (vm->code == SCM_VM_DO_GET_OPCODE) {
566 if (vm->arg.opcode < 0 || vm->arg.opcode >= scm_op_max) {
567 vm->ret.entry = NULL;
568 } else {
569 vm->ret.entry = symbol + vm->arg.opcode;
570 }
571 return;
572
573 } else if (vm->code == SCM_VM_DO_GET_OPCODE_BY_NAME) {
574 int i;
575 for (i = 0; symbol[i].name; i++) {
576 if (streq(vm->arg.name, symbol[i].name)) {
577 vm->ret.entry = symbol + i;
578 return;
579 }
580 }
581 vm->ret.entry = NULL;
582 return;
583
584 } else if (vm->code == SCM_VM_DO_GET_OPCODE_BY_ADDR) {
585 int i;
586 for (i = 0; symbol[i].name; i++) {
587 if (symbol[i].address == vm->arg.addr) {
588 vm->ret.entry = symbol + i;
589 return;
590 }
591 }
592 vm->ret.entry = NULL;
593 return;
594 }
595
596 SCM_ERR("bad vm code:", SCM_MKINUM(vm->code));
597 }
598
599 /********************************
600 * VM executor
601 ********************************/
602
603 /* load registers with vm registers */
604 ip = vm->reg.ip;
605 sp = vm->reg.sp;
606 cont = vm->reg.cont;
607 env = vm->reg.env;
608 proc = NULL;
609 dst = NULL;
610 sp_base = vm->stack_base + STACK_OVERFLOW_GRACE;
611
612 cbinding = (env) ? SCM_ENV_FRAME(env)->binding : NULL;
613
614 #ifdef ENGINE_TRACE
615 printf("*** new engine started ***\n");
616 #endif
617
618 #ifdef USE_TOS
619 TOS = sp[0];
620 #endif
621 NEXT;
622
623 l_nop: {
624 NEXT;
625 }
626
627 l_end: {
628 spop(vm->ret.obj);
629 supdate();
630 vm->reg.sp = sp;
631 #ifdef ENGINE_TRACE
632 printf("*** engine finished bcz l_end: ***\n");
633 #endif
634 return;
635 }
636
637 #ifdef STACK_CHECKS
638 l_overflow:
639 {
640 SCM_ERR("Stack overflow", NULL);
641 }
642
643 #ifdef NOT_USED
644 l_underflow:
645 {
646 SCM_ERR("Stack underflow", NULL);
647 }
648 #endif
649 #endif
650
651 l_doletstar:
652 {
653 int n = SCM_INUM(*ip++);
654 /*-- mark and push n #unbound object */
655 PUSH_CONT();
656 while(--n >= 0) spush(scm_unbound);
657 } /* FALL THROUGH */
658
659 l_dolet:
660 {
661 /* stack: cont binding_n ... binding_0 */
662 int nslots = (SOBJ*)cont - sp;
663
664 cont->env = env; /* save env */
665 *sp = TOS;
666 PUSH_ENV_FRAME(env, nslots);
667 NEXT;
668 }
669
670
671 /* simple stack manipulations */
672
673 l_drop: { sdrop(); NEXT; }
674 l_push: { spush( *ip++ ); NEXT; }
675 l_pushv:
676 {
677 spush( SCM_SYM_VALUE((SOBJ)(*ip++)));
678 if (TOS == scm_unbound)
679 SCM_ERR("symbol unbound", SCM_SYM_NAME((SOBJ)ip[-1]));
680 NEXT;
681 }
682
683 l_pushn:
684 {
685 int n = SCM_INUM(*ip++);
686 while(--n >= 0)
687 spush(*ip++);
688 NEXT;
689 }
690
691 l_pushl: { /* lev, ofs */
692 SOBJ p = env;
693 short n = SCM_INUM(*ip) >> 16;
694 while(--n >= 0) p = SCM_ENV_NEXT(p);
695 spush(SCM_ENV_FRAME(p)->binding[(short)SCM_INUM(*ip++)]);
696 NEXT;
697 }
698
699 l_pushl0: {
700 spush(cbinding[SCM_INUM(*ip++)]);
701 NEXT;
702 }
703
704 l_pushl1: {
705 spush(SCM_ENV_FRAME(SCM_ENV_NEXT(env))
706 ->binding[SCM_INUM(*ip++)]);
707 NEXT;
708 }
709
710 l_pushl2: {
711 spush(SCM_ENV_FRAME(SCM_ENV_NEXT(SCM_ENV_NEXT(env)))
712 ->binding[SCM_INUM(*ip++)]);
713 NEXT;
714 }
715
716 l_pushl3: {
717 spush(SCM_ENV_FRAME(SCM_ENV_NEXT(SCM_ENV_NEXT(SCM_ENV_NEXT(env))))
718 ->binding[SCM_INUM(*ip++)]);
719 NEXT;
720 }
721
722 l_alloc: { /* S: -- [ nil ]n */
723 int n = SCM_INUM(*ip++);
724 while(--n >= 0)
725 spush(NULL);
726 NEXT;
727 }
728
729 l_pushlist: /* mark -- mark item#n-1 ... item#0 */
730 {
731 SOBJ p, list = *ip++;
732 int i;
733
734 *sp = TOS;
735 for (i = 0, p = list; p; p = SCM_CDR(p), i++)
736 ;
737 sp -= i;
738 for (i = 0, p = list; p; sp[i++] = SCM_CAR(p), p = SCM_CDR(p))
739 ;
740 TOS = *sp;
741 NEXT;
742 }
743
744 #ifdef NOT_USED
745 l_nonimp: {
746 SCM_ERR("not implemented opcode", NULL);
747 }
748 #endif
749
750 /*-- create a contframe struct on the stack:
751 * we push because of possible use of TOS cache:
752 * after PUSH_CONT, cont will point to a contframe struct...
753 */
754 l_mark: { /* push a continuation frame on the stack */
755 PUSH_CONT();
756 NEXT;
757 }
758
759 l_mkclosure: { /* proc -- closure */
760 SOBJ closure = scm_newcell(SOBJ_T_CLOSURE);
761 SCM_CLOSURE_CODE(closure) = TOS;
762 SCM_CLOSURE_ENV(closure) = env = mk_persistent_env(env,sp,vm->stack_limit);
763 SCM_RESTORE_CBINDING();
764 TOS = closure;
765 NEXT;
766
767 #ifdef OLD_CLOSURE
768 SOBJ closure = scm_newcell(SOBJ_T_CLOSURE);
769 SCM_CLOSURE_CODE(closure) = TOS;
770 SCM_CLOSURE_ENV(closure) = env;
771 #ifdef DEBUG_VM_CLOSURE
772 printf("mkclosure: %p (code=%p env=%p)\n", closure, TOS, env);
773 #endif
774 copy_closure_env(closure, env, sp, vm->stack_limit);
775 env = SCM_CLOSURE_ENV(closure);
776 SCM_RESTORE_CBINDING();
777 TOS = closure;
778 NEXT;
779 #endif
780 }
781
782 l_callc: {
783 SCM_ERR("%callc: not implemented", NULL);
784 }
785
786 l_callc0: { /* proc -- n */
787 sresync();
788 TOS = (*SCM_CPRIM_FUNC((SOBJ)TOS)) ();
789 check_overflow();
790 NEXT;
791 }
792 l_callc1: { /* a1 proc -- n */
793 SOBJ r;
794 sresync();
795 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1]);
796 sp += 1; TOS=r;
797 check_overflow();
798 NEXT;
799 }
800 l_callc2: { /* a2 a1 proc -- n */
801 SOBJ r;
802 sresync();
803 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1], sp[2]);
804 sp += 2; TOS=r;
805 check_overflow();
806 NEXT;
807 }
808 l_callc3: {
809 SOBJ r;
810 sresync();
811 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1], sp[2], sp[3]);
812 sp += 3; TOS = r;
813 check_overflow();
814 NEXT;
815 }
816 l_callc4: {
817 SOBJ r;
818 sresync();
819 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1], sp[2], sp[3], sp[4]);
820 sp += 4; TOS = r;
821 check_overflow();
822 NEXT;
823 }
824 l_callc5: {
825 SOBJ r;
826 sresync();
827 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1], sp[2], sp[3], sp[4], sp[5]);
828 sp += 5; TOS = r;
829 check_overflow();
830 NEXT;
831 }
832 l_callc6: {
833 SOBJ r;
834 sresync();
835 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1],sp[2],sp[3],sp[4],sp[5],sp[6]);
836 sp += 6; TOS = r;
837 check_overflow();
838 NEXT;
839 }
840 l_callc7: {
841 SOBJ r;
842 sresync();
843 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1],sp[2],sp[3],sp[4],sp[5],sp[6],sp[7]);
844 sp += 7; TOS = r;
845 check_overflow();
846 NEXT;
847 }
848 l_callc8: {
849 SOBJ r;
850 sresync();
851 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1],sp[2],sp[3],sp[4],sp[5],sp[6],sp[7],sp[8]);
852 sp += 8; TOS = r;
853 check_overflow();
854 NEXT;
855 }
856 l_callc9: {
857 SOBJ r;
858 sresync();
859 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1],sp[2],sp[3],sp[4],sp[5],sp[6],sp[7],sp[8],sp[9]);
860 sp += 9; TOS = r;
861 check_overflow();
862 NEXT;
863 }
864 l_callc10: {
865 SOBJ r;
866 sresync();
867 r = (*SCM_CPRIM_FUNC((SOBJ)TOS))(sp[1],sp[2],sp[3],sp[4],sp[5],sp[6],sp[7],sp[8],sp[9],sp[10]);
868 sp += 10; TOS = r;
869 check_overflow();
870 NEXT;
871 }
872
873 l_calls: { /* cont an..a0 proc -- r */
874 SOBJ ret, func;
875
876 spop(func);
877 cont->env = env;
878 cont->ip = ip;
879 ret = (*SCM_CPRIM_FUNC(func))( (SOBJ*)cont - (SOBJ*)sp, sp);
880 spush(ret);
881 goto l_return;
882 }
883
884 l_no_call1:
885 proc = TOS;
886
887 l_no_call:
888 {
889 /* dirty hack: ip points after the call now: so we should have
890 *
891 * ip-3: pushv
892 * ip-2: variable
893 * ip-1: call
894 * ip: ???
895 */
896 scm_puts("\nOOPS: ip="); scm_putx(ip);
897 scm_puts(": "); scm_cdisplay(ip[-2]); scm_puts(" is unbound.");
898 SCM_ERR("cannot call", proc);
899 }
900
901 l_endlet_jump: /* args proc */
902 {
903 src = (SOBJ*)cont;
904 cont = cont->next;
905 goto l_jump1;
906 }
907
908 l_jump: {
909 #ifdef DEBUG_VM_JUMP
910 scm_puts("jump: "); scm_cprint(TOS);
911 #endif
912 src = (SOBJ*)cont;
913
914 l_jump1:
915 if (TOS == NULL || SCM_INUMP(TOS)) goto l_no_call1;
916
917 spop(proc);
918 cont = cont->next;
919 env = cont->env;
920 ip = cont->ip;
921 dst = (SOBJ*)cont;
922 while(src > sp) { *(--dst) = *(--src); }
923
924 /* OOPS: have a bug in egcc ?
925 * sp += (dst - src) shoud be sp = dst, but I have not a correct
926 * value in sp if I choose the 2nd option. Strange is not it ?
927 */
928 sp += (dst - src); /* seems to have a bug in gcc */
929 TOS = *sp;
930 goto *(scm_type_hook[proc->type].execute);
931 }
932
933
934 l_call: {
935 if (TOS == NULL || SCM_INUMP(TOS)) goto l_no_call1;
936
937 cont->ip = ip;
938 cont->env = env;
939 spop(proc);
940 goto *(scm_type_hook[proc->type].execute);
941 }
942
943 l_call_prim: {
944 SCM_PRIM_TABLE *p = SCM_PRIM(proc);
945 if (p->nargs >= 0) { /* pop continuation frame (not used) */
946 cont = cont->next;
947 }
948 goto *(p->address);
949 }
950
951 l_call_cprim: {
952 spush(proc);
953
954 switch(SCM_CPRIM_NARGS(proc)) {
955 case -1: goto l_calls;
956 case 0: cont=cont->next; goto l_callc0;
957 case 1: cont=cont->next; goto l_callc1;
958 case 2: cont=cont->next; goto l_callc2;
959 case 3: cont=cont->next; goto l_callc3;
960 case 4: cont=cont->next; goto l_callc4;
961 case 5: cont=cont->next; goto l_callc5;
962 case 6: cont=cont->next; goto l_callc6;
963 }
964 goto l_no_call;
965 }
966
967 l_call_code: {
968 ip = SCM_CODE_CODE(proc);
969 NEXT;
970 }
971
972 l_call_proc: {
973 ip = SCM_PROC_CODE(proc)->code;
974 if (SCM_PROC_CODE(proc)->optargs == 0) {
975 COMPLETE_ENV(proc);
976 NEXT;
977 }
978 SCM_ERR("callv: opt args not supported yet", proc);
979 /* have optionnal */
980 NEXT;
981 }
982
983 l_call_closure: {
984 SCM_Code *code;
985
986 code = SCM_PROC_CODE(SCM_CLOSURE_CODE(proc));
987 ip = code->code;
988 if (code->optargs != 0) { /* optionnal arguments */
989 SOBJ list, *p, *q;
990 if ((q = sp+code->nargs-1) > (SOBJ*)cont)
991 SCM_ERR("callv: bad number of args", proc);
992
993 *sp = TOS; p = (SOBJ*)cont; list = NULL;
994 while(--p >= q) list = scm_cons(*p, list);
995 if (q == (SOBJ*)cont) { /* insert space on stack */
996 for (p = sp; p < q; p++) { p[-1] = p[0]; }
997 q[-1] = list; sp--;
998 } else {
999 p = ((SOBJ*)cont)-1; while(--q >= sp) { *(--p) = *q; }
1000 ((SOBJ*)cont)[-1] = list;
1001 sp = p;
1002 }
1003 TOS=*sp;
1004 }
1005 /* alloc room for local arguments */
1006 sp -= code->nlocals;
1007
1008 /* sp[0] = TOS; */
1009 PUSH_ENV_FRAME(SCM_CLOSURE_ENV(proc), code->nlocals + code->nargs);
1010 NEXT;
1011 }
1012
1013
1014 l_call_macro:
1015 {
1016 SCM_ERR("l_call_macro: call to macro is forbiden", proc);
1017
1018 if (SCM_MACRO_FUNC(proc)) {
1019 proc = SCM_MACRO_FUNC(proc);
1020 goto l_call_closure;
1021 }
1022 }
1023
1024 l_call_extfunc:
1025 {
1026 /* don't need supdate(), because last action was poping proc */
1027 sresync();
1028 TOS = scm_extfunc_call(proc, (SOBJ*)cont - sp, sp);
1029 POP_CONT(); /* pop current continuation */
1030 NEXT;
1031 }
1032
1033 l_call_vmfunc:
1034 {
1035 SCM_vmRegisters vm;
1036 void (*func)(SCM_vmRegisters *);
1037
1038 func = SCM_VMFUNC(proc);
1039 SCM_SAVE_VMREGS(&vm);
1040 (*func)(&vm);
1041 SCM_RESTORE_VMREGS(&vm);
1042 SCM_RESTORE_CBINDING();
1043 NEXT;
1044 }
1045
1046 /*-- low level error handling */
1047
1048 l_catch: { /* handler tag -- */
1049 SOBJ catch;
1050 SCM_CatchContext *c;
1051
1052 catch = scm_mkcatch(); /* create a catch context object */
1053 c = SCM_CATCH_CONTEXT(catch); /* keep pointer to catch context struct */
1054 scm_catch_list = scm_cons(catch, scm_catch_list);
1055
1056 /* fill internal catch context structure */
1057 spop(c->tag); /* with the tag */
1058 spop(c->handler); /* with the handler */
1059 SCM_SAVE_VMREGS(&c->vm);
1060 c->vm.ip += SCM_INUM(*ip++); /* correct address in case of catch */
1061 if (setjmp(c->env) != 0) { /* wheepee!!! got a catch */
1062 SCM_RESTORE_VMREGS(&c->vm);
1063 SCM_RESTORE_CBINDING();
1064 scm_puts("*** catch: scm_catch_list="); scm_cprint(scm_catch_list);
1065 if (c->handler) {
1066 PUSH_CONT();
1067 spush(scm_thrown_msg);
1068 spush(scm_thrown_tag);
1069 spush(c->handler);
1070 goto l_call; /* execute handler */
1071 }
1072 SCM_ERR("catch: katastroph: no handler", NULL);
1073 }
1074 NEXT;
1075 }
1076
1077 l_uncatch: { /* uncatch: -- */
1078 if (SCM_PAIRP(scm_catch_list)) {
1079 scm_catch_list = SCM_CDR(scm_catch_list);
1080 }
1081 NEXT;
1082 }
1083
1084 l_endlet:
1085 {
1086 cont->ip = ip;
1087 } /* FALL THROUGH */
1088
1089 l_return: {
1090 SOBJ r;
1091
1092 if (TOS && SCM_CLOSUREP(TOS)) {
1093 if (SCM_CLOSURE_ENV(TOS) >= (SOBJ)sp &&
1094 SCM_CLOSURE_ENV(TOS) < (SOBJ)vm->stack_limit) {
1095 printf("return: OOPS: closure env still on stack\n");
1096 }
1097 #ifdef DEBUG_VM_CLOSURE
1098 printf("return: closure %p env=%p\n", TOS, env);
1099 #endif
1100 copy_closure_env(TOS, env, sp, vm->stack_limit);
1101 env = SCM_CLOSURE_ENV(TOS);
1102 SCM_RESTORE_CBINDING();
1103 }
1104
1105 spop(r);
1106 if (sp >= vm->stack_limit) {
1107 printf("*** Stack underflow: depth=%d ***\n",
1108 vm->stack_limit - vm->reg.sp);
1109 }
1110 #ifdef OLD
1111 if (sp >= vm->reg.sp) {
1112 printf("*** engine terminates bcz sp>=sp0 ***\n");
1113 vm->ret.obj = r;
1114 return;
1115 }
1116 #endif
1117 POP_CONT(); *sp = TOS = r;
1118 NEXT;
1119
1120 }
1121
1122 l_store: { /* value symbol -- value */
1123 SOBJ sym;
1124 spop(sym);
1125 SCM_SYM_VALUE(sym) = TOS;
1126 NEXT;
1127 }
1128
1129 l_setl: {
1130 SOBJ p = env;
1131 short n = SCM_INUM(*ip) >> 16;
1132 while(--n >= 0) p = SCM_ENV_NEXT(p);
1133 SCM_ENV_FRAME(p)->binding[(short)SCM_INUM(*ip++)] = TOS;
1134 NEXT;
1135 }
1136
1137 l_setl0: {
1138 cbinding[SCM_INUM(*ip++)] = TOS;
1139 NEXT;
1140 }
1141
1142 l_setl0drop: {
1143 cbinding[SCM_INUM(*ip++)] = TOS; sdrop();
1144 NEXT;
1145 }
1146
1147 l_getvar: { /* var -- value */
1148 TOS = (*(SCM_VAR_AUX(TOS)->get))(TOS,NULL);
1149 NEXT;
1150 }
1151
1152 l_setvar: { /* value var -- value */
1153 SOBJ var;
1154 spop(var);
1155 (*(SCM_VAR_AUX(var)->set))(var,NULL,TOS);
1156 NEXT;
1157 }
1158
1159 l_br_and: { /* #f -- #f +bra || x -- */
1160 if (TOS == scm_false) {
1161 ip += SCM_INUM(*ip);
1162 NEXT;
1163 }
1164 sdrop();
1165 ip++;
1166 NEXT;
1167 }
1168
1169 l_br_or: { /* #f -- || x -- x +bra */
1170 if (TOS != scm_false) {
1171 ip += SCM_INUM(*ip);
1172 NEXT;
1173 }
1174 sdrop();
1175 ip++;
1176 NEXT;
1177 }
1178
1179 l_br_cond: { /* #f -- +bra || x -- x */
1180 if (TOS != scm_false) {
1181 ip++;
1182 NEXT;
1183 }
1184 sdrop();
1185 ip += SCM_INUM(*ip);
1186 NEXT;
1187 }
1188
1189 l_br_while: { /* #f -- #f || x -- +bra */
1190 if (TOS == scm_false) {
1191 ip++;
1192 NEXT;
1193 }
1194 sdrop();
1195 ip += SCM_INUM(*ip);
1196 NEXT;
1197 }
1198
1199 l_bra: {
1200 ip += SCM_INUM(*ip);
1201 NEXT;
1202 }
1203
1204 l_brf: {
1205 SOBJ flag;
1206 spop(flag);
1207 if (flag == scm_false) {
1208 ip += SCM_INUM(*ip);
1209 NEXT;
1210 }
1211 ip++;
1212 NEXT;
1213 }
1214
1215 l_brt: {
1216 SOBJ flag;
1217 spop(flag);
1218 if (flag != scm_false) {
1219 ip += SCM_INUM(*ip);
1220 NEXT;
1221 }
1222 ip++;
1223 NEXT;
1224 }
1225
1226 l_save_r0: { spop(r0); NEXT; }
1227 l_load_r0: { spush(r0); NEXT; }
1228
1229
1230 #include "prim2.i"
1231 #include "number.i"
1232
1233 return;
1234 }
1235
1236 /*-- intialize */
1237
scm_engine_init()1238 void scm_engine_init()
1239 {
1240 SCM_VMD vm;
1241
1242 /* initialize the engine */
1243 vm.code = SCM_VM_DO_INIT; scm_vm(&vm);
1244 }
1245
1246
scm_run_engine(SOBJ * ip)1247 SOBJ scm_run_engine(SOBJ *ip)
1248 {
1249 SCM_VMD *v = scm_vmd();
1250 v->code = SCM_VM_DO_EXECUTE;
1251 v->reg.ip = ip;
1252 scm_vm(v);
1253 return(v->ret.obj);
1254 }
1255
1256
scm_get_addr(int opc)1257 SCM_PRIM_TABLE *scm_get_addr(int opc)
1258 {
1259 SCM_VMD vm;
1260
1261 vm.code = SCM_VM_DO_GET_OPCODE;
1262 vm.arg.opcode = opc;
1263 scm_vm(&vm);
1264 return(vm.ret.entry);
1265 }
1266
scm_is_opcode_address(void * p)1267 int scm_is_opcode_address(void *p)
1268 {
1269 return (p >= scm_op_low_addr && p <= scm_op_high_addr);
1270 }
1271
1272
scm_search_opcode_address(char * name)1273 SCM_PRIM_TABLE *scm_search_opcode_address(char *name)
1274 {
1275 SCM_VMD vm;
1276
1277 vm.code = SCM_VM_DO_GET_OPCODE_BY_NAME;
1278 vm.arg.name = name;
1279 scm_vm(&vm);
1280 return(vm.ret.entry);
1281 }
1282
scm_search_opcode_by_addr(void * p)1283 static SCM_PRIM_TABLE *scm_search_opcode_by_addr(void *p)
1284 {
1285 SCM_VMD vm;
1286
1287 vm.code = SCM_VM_DO_GET_OPCODE_BY_ADDR;
1288 vm.arg.addr = p;
1289 scm_vm(&vm);
1290 return(vm.ret.entry);
1291 }
1292
scm_search_opcode_name(void * p)1293 char *scm_search_opcode_name(void *p)
1294 {
1295 SCM_PRIM_TABLE *pt = scm_search_opcode_by_addr(p);
1296 return( (pt == NULL) ? NULL : pt->name);
1297 }
1298
scm_print_op(SOBJ * code)1299 static SOBJ *scm_print_op(SOBJ *code)
1300 {
1301 int i;
1302 SCM_PRIM_TABLE *op;
1303
1304 if (!scm_is_opcode_address(*code)) {
1305 port_putx(SCM_OUTP, code);
1306 port_puts(SCM_OUTP, ": ");
1307 scm_cprint(*code++);
1308 return(code);
1309 }
1310
1311 if ((op = scm_search_opcode_by_addr(*code)) != NULL) {
1312 port_putx(SCM_OUTP, code); port_puts(SCM_OUTP, ": ");
1313 port_puts(SCM_OUTP, op->name);
1314 code++;
1315 for (i = 0; i < op->following; i++) {
1316 scm_putc(' '); scm_write2(*code++, NULL);
1317 }
1318 scm_putc('\n');
1319 return(code);
1320 }
1321 return(NULL);
1322 }
1323
scm_disassemble(SOBJ * code,int nslots)1324 SOBJ scm_disassemble(SOBJ *code, int nslots)
1325 {
1326 SOBJ *limit;
1327 limit = code + nslots;
1328
1329 while(code < limit) {
1330 code = scm_print_op(code);
1331 }
1332 return(NULL);
1333 }
1334