HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Create external frames dynamically.
[bpt/guile.git] / src / vm.c
1 /* Copyright (C) 2000 Free Software Foundation, Inc.
2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
41
42 #define SCM_DEBUG_TYPING_STRICTNESS 0
43 #include "config.h"
44 #include "vm.h"
45
46 /* default stack size in the number of SCM */
47 #define VM_DEFAULT_STACK_SIZE (16 * 1024) /* = 64KB */
48 #define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */
49
50 /* I sometimes use this for debugging. */
51 #define vm_puts(OBJ) \
52 { \
53 scm_display (OBJ, scm_def_errp); \
54 scm_newline (scm_def_errp); \
55 }
56
57 \f
58 /*
59 * Instruction
60 */
61
62 #define INSTRUCTION_HASH_SIZE op_last
63 #define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE)
64
65 /* These variables are defined in VM engines when they are first called. */
66 static struct scm_instruction *scm_regular_instruction_table = 0;
67 static struct scm_instruction *scm_debug_instruction_table = 0;
68
69 /* Hash table for finding instructions from addresses */
70 static struct inst_hash {
71 void *addr;
72 struct scm_instruction *inst;
73 struct inst_hash *next;
74 } *scm_instruction_hash_table[INSTRUCTION_HASH_SIZE];
75
76 static long scm_instruction_tag;
77
78 static SCM
79 make_instruction (struct scm_instruction *instp)
80 {
81 SCM_RETURN_NEWSMOB (scm_instruction_tag, instp);
82 }
83
84 static int
85 print_instruction (SCM obj, SCM port, scm_print_state *pstate)
86 {
87 scm_puts ("#<instruction ", port);
88 scm_puts (SCM_INSTRUCTION_DATA (obj)->name, port);
89 scm_putc ('>', port);
90 return 1;
91 }
92
93 static void
94 init_instruction_type ()
95 {
96 scm_instruction_tag = scm_make_smob_type ("instruction", 0);
97 scm_set_smob_print (scm_instruction_tag, print_instruction);
98 }
99
100 /* C interface */
101
102 static struct scm_instruction *
103 find_instruction_by_name (const char *name)
104 {
105 struct scm_instruction *p;
106 for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
107 if (strcmp (name, p->name) == 0)
108 return p;
109 return 0;
110 }
111
112 static struct scm_instruction *
113 find_instruction_by_code (SCM code)
114 {
115 struct inst_hash *p;
116 void *addr = SCM_CODE_TO_ADDR (code);
117 for (p = scm_instruction_hash_table[INSTRUCTION_HASH (addr)]; p; p = p->next)
118 if (p->addr == addr)
119 return p->inst;
120 return 0;
121 }
122
123 #ifdef HAVE_LABELS_AS_VALUES
124 static void *
125 instruction_code_to_debug_addr (SCM code)
126 {
127 struct scm_instruction *p = find_instruction_by_code (code);
128 return scm_debug_instruction_table[p->opcode].addr;
129 }
130 #endif
131
132 /* Scheme interface */
133
134 SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
135 (SCM obj),
136 "")
137 #define FUNC_NAME s_scm_instruction_p
138 {
139 return SCM_BOOL (SCM_INSTRUCTION_P (obj));
140 }
141 #undef FUNC_NAME
142
143 SCM_DEFINE (scm_system_instruction_p, "system-instruction?", 1, 0, 0,
144 (SCM obj),
145 "")
146 #define FUNC_NAME s_scm_system_instruction_p
147 {
148 return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj));
149 }
150 #undef FUNC_NAME
151
152 SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0,
153 (SCM obj),
154 "")
155 #define FUNC_NAME s_scm_functional_instruction_p
156 {
157 return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj));
158 }
159 #undef FUNC_NAME
160
161 SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0,
162 (SCM name),
163 "")
164 #define FUNC_NAME s_scm_instruction_name_p
165 {
166 SCM_VALIDATE_SYMBOL (1, name);
167 return SCM_BOOL (find_instruction_by_name (SCM_CHARS (name)));
168 }
169 #undef FUNC_NAME
170
171 SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0,
172 (SCM name),
173 "")
174 #define FUNC_NAME s_scm_symbol_to_instruction
175 {
176 struct scm_instruction *p;
177 SCM_VALIDATE_SYMBOL (1, name);
178
179 p = find_instruction_by_name (SCM_CHARS (name));
180 if (!p)
181 SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name));
182
183 return p->obj;
184 }
185 #undef FUNC_NAME
186
187 SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
188 (),
189 "")
190 #define FUNC_NAME s_scm_instruction_list
191 {
192 SCM list = SCM_EOL;
193 struct scm_instruction *p;
194 for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
195 list = scm_cons (p->obj, list);
196 return scm_reverse_x (list, SCM_EOL);
197 }
198 #undef FUNC_NAME
199
200 SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0,
201 (SCM inst),
202 "")
203 #define FUNC_NAME s_scm_instruction_opcode
204 {
205 SCM_VALIDATE_INSTRUCTION (1, inst);
206 return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode);
207 }
208 #undef FUNC_NAME
209
210 SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0,
211 (SCM inst),
212 "")
213 #define FUNC_NAME s_scm_instruction_name
214 {
215 SCM_VALIDATE_INSTRUCTION (1, inst);
216 return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name));
217 }
218 #undef FUNC_NAME
219
220 SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0,
221 (SCM inst),
222 "")
223 #define FUNC_NAME s_scm_instruction_type
224 {
225 SCM_VALIDATE_INSTRUCTION (1, inst);
226 return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type);
227 }
228 #undef FUNC_NAME
229
230 SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0,
231 (SCM inst),
232 "")
233 #define FUNC_NAME s_scm_instruction_scheme_name
234 {
235 SCM_VALIDATE_INSTRUCTION (1, inst);
236 if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
237 return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname));
238 else
239 return SCM_BOOL_F;
240 }
241 #undef FUNC_NAME
242
243 SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0,
244 (SCM inst),
245 "")
246 #define FUNC_NAME s_scm_instruction_arity
247 {
248 SCM_VALIDATE_INSTRUCTION (1, inst);
249 if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
250 {
251 struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst);
252 return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp));
253 }
254 else
255 return SCM_BOOL_F;
256 }
257 #undef FUNC_NAME
258
259 \f
260 /*
261 * Bytecode
262 */
263
264 static long scm_bytecode_tag;
265
266 static SCM
267 make_bytecode (int size)
268 {
269 struct scm_bytecode *p
270 = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode");
271 p->size = size;
272 SCM_RETURN_NEWSMOB (scm_bytecode_tag, p);
273 }
274
275 static SCM
276 mark_bytecode (SCM bytecode)
277 {
278 int i;
279 struct scm_instruction *p;
280
281 int size = SCM_BYTECODE_SIZE (bytecode);
282 SCM *base = SCM_BYTECODE_BASE (bytecode);
283
284 for (i = 0; i < size; i++)
285 {
286 p = find_instruction_by_code (base[i]);
287 switch (p->type)
288 {
289 case INST_NONE:
290 break;
291 case INST_SCM:
292 case INST_TOP:
293 case INST_EXT:
294 case INST_CODE:
295 scm_gc_mark (base[++i]);
296 break;
297 case INST_INUM: /* a fixed integer; we don't need to mark it */
298 case INST_ADDR: /* real memory address; we shouldn't mark it! */
299 i++;
300 }
301 }
302 return SCM_BOOL_F;
303 }
304
305 static int
306 print_bytecode (SCM obj, SCM port, scm_print_state *pstate)
307 {
308 scm_puts ("#<bytecode 0x", port);
309 scm_intprint ((long) SCM_BYTECODE_BASE (obj), 16, port);
310 scm_putc ('>', port);
311 return 1;
312 }
313
314 static scm_sizet
315 free_bytecode (SCM bytecode)
316 {
317 int size = (sizeof (struct scm_bytecode)
318 + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM)));
319 if (SCM_BYTECODE_EXTS (bytecode))
320 {
321 size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int);
322 scm_must_free (SCM_BYTECODE_EXTS (bytecode));
323 }
324 scm_must_free (SCM_BYTECODE_DATA (bytecode));
325 return size;
326 }
327
328 static void
329 init_bytecode_type ()
330 {
331 scm_bytecode_tag = scm_make_smob_type ("bytecode", 0);
332 scm_set_smob_mark (scm_bytecode_tag, mark_bytecode);
333 scm_set_smob_print (scm_bytecode_tag, print_bytecode);
334 scm_set_smob_free (scm_bytecode_tag, free_bytecode);
335 }
336
337 /* Scheme interface */
338
339 SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0,
340 (SCM obj),
341 "")
342 #define FUNC_NAME s_scm_bytecode_p
343 {
344 return SCM_BOOL (SCM_BYTECODE_P (obj));
345 }
346 #undef FUNC_NAME
347
348 SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0,
349 (SCM code),
350 "")
351 #define FUNC_NAME s_scm_make_bytecode
352 {
353 int i, size, len, offset;
354 SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode;
355 SCM *old, *new, *address;
356
357 /* Type check */
358 SCM_VALIDATE_VECTOR (1, code);
359 SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2);
360 header = SCM_VELTS (code)[0];
361 body = SCM_VELTS (code)[1];
362 SCM_VALIDATE_VECTOR (1, header);
363 SCM_VALIDATE_VECTOR (2, body);
364 SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5);
365 nreqs = SCM_VELTS (header)[0];
366 restp = SCM_VELTS (header)[1];
367 nvars = SCM_VELTS (header)[2];
368 nexts = SCM_VELTS (header)[3];
369 exts = SCM_VELTS (header)[4];
370 SCM_VALIDATE_INUM (1, nreqs);
371 SCM_VALIDATE_BOOL (2, restp);
372 SCM_VALIDATE_INUM (3, nvars);
373 SCM_VALIDATE_INUM (4, nexts);
374 SCM_VALIDATE_VECTOR (5, exts);
375
376 /* Create a new bytecode */
377 size = SCM_LENGTH (body);
378 old = SCM_VELTS (body);
379 bytecode = make_bytecode (size);
380 new = SCM_BYTECODE_BASE (bytecode);
381
382 /* Initialize the header */
383 SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs);
384 SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1;
385 SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars);
386 SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts);
387 len = SCM_LENGTH (exts);
388 if (len == 0)
389 {
390 SCM_BYTECODE_EXTS (bytecode) = NULL;
391 }
392 else
393 {
394 SCM_BYTECODE_EXTS (bytecode) =
395 scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME);
396 SCM_BYTECODE_EXTS (bytecode)[0] = len;
397 for (i = 0; i < len; i++)
398 SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]);
399 }
400
401 /* Initialize the body */
402 for (i = 0; i < size; i++)
403 {
404 struct scm_instruction *p;
405
406 /* Process instruction */
407 if (!SCM_SYMBOLP (old[i])
408 || !(p = find_instruction_by_name (SCM_CHARS (old[i]))))
409 SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i]));
410 new[i] = SCM_ADDR_TO_CODE (p->addr);
411
412 /* Process arguments */
413 if (p->type == INST_NONE)
414 continue;
415 if (++i >= size)
416 SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL);
417 switch (p->type)
418 {
419 case INST_NONE:
420 /* never come here */
421 case INST_INUM:
422 SCM_VALIDATE_INUM (1, old[i]);
423 /* fall through */
424 case INST_SCM:
425 /* just copy */
426 new[i] = old[i];
427 break;
428 case INST_TOP:
429 /* top-level variable */
430 SCM_VALIDATE_SYMBOL (1, old[i]);
431 new[i] = scm_intern0 (SCM_CHARS (old[i]));
432 break;
433 case INST_EXT:
434 /* just copy for now */
435 SCM_VALIDATE_CONS (1, old[i]);
436 SCM_VALIDATE_INUM (1, SCM_CAR (old[i]));
437 SCM_VALIDATE_INUM (1, SCM_CDR (old[i]));
438 new[i] = old[i];
439 break;
440 case INST_CODE:
441 /* another bytecode */
442 new[i] = scm_make_bytecode (old[i]);
443 break;
444 case INST_ADDR:
445 /* real address */
446 SCM_VALIDATE_INUM (1, old[i]);
447 /* Without the following intermediate variables, type conversion
448 fails on my machine. Casting doesn't work well, why? */
449 offset = SCM_INUM (old[i]);
450 address = new + offset;
451 new[i] = SCM_VM_MAKE_ADDRESS (address);
452 break;
453 }
454 }
455 return bytecode;
456 }
457 #undef FUNC_NAME
458
459 SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0,
460 (SCM bytecode),
461 "")
462 #define FUNC_NAME s_scm_bytecode_decode
463 {
464 int i, size, offset;
465 SCM code, *old, *new;
466
467 SCM_VALIDATE_BYTECODE (1, bytecode);
468
469 size = SCM_BYTECODE_SIZE (bytecode);
470 old = SCM_BYTECODE_BASE (bytecode);
471 code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
472 new = SCM_VELTS (code);
473
474 for (i = 0; i < size; i++)
475 {
476 struct scm_instruction *p;
477
478 /* Process instruction */
479 p = find_instruction_by_code (old[i]);
480 if (!p)
481 {
482 broken:
483 SCM_MISC_ERROR ("Broken bytecode", SCM_EOL);
484 }
485 new[i] = scm_instruction_name (p->obj);
486
487 /* Process arguments */
488 if (p->type == INST_NONE)
489 continue;
490 if (++i >= size)
491 goto broken;
492 switch (p->type)
493 {
494 case INST_NONE:
495 /* never come here */
496 case INST_INUM:
497 case INST_SCM:
498 case INST_EXT:
499 /* just copy */
500 new[i] = old[i];
501 break;
502 case INST_TOP:
503 /* top-level variable */
504 new[i] = SCM_CAR (old[i]);
505 break;
506 case INST_CODE:
507 /* another bytecode */
508 new[i] = scm_bytecode_decode (old[i]);
509 break;
510 case INST_ADDR:
511 /* program address */
512 offset = SCM_VM_ADDRESS (old[i]) - old;
513 new[i] = SCM_MAKINUM (offset);
514 break;
515 }
516 }
517 return code;
518 }
519 #undef FUNC_NAME
520
521 \f
522 /*
523 * Program
524 */
525
526 static long scm_program_tag;
527
528 static SCM
529 make_program (SCM code, SCM env)
530 {
531 SCM_RETURN_NEWSMOB2 (scm_program_tag, SCM_UNPACK (code), SCM_UNPACK (env));
532 }
533
534 static SCM
535 mark_program (SCM program)
536 {
537 scm_gc_mark (SCM_PROGRAM_CODE (program));
538 return SCM_PROGRAM_ENV (program);
539 }
540
541 static SCM scm_program_name (SCM program);
542
543 static int
544 print_program (SCM obj, SCM port, scm_print_state *pstate)
545 {
546 SCM name = scm_program_name (obj);
547 scm_puts ("#<program ", port);
548 if (SCM_FALSEP (name))
549 {
550 scm_puts ("0x", port);
551 scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
552 }
553 else
554 {
555 scm_display (name, port);
556 }
557 scm_putc ('>', port);
558 return 1;
559 }
560
561 static void
562 init_program_type ()
563 {
564 scm_program_tag = scm_make_smob_type ("program", 0);
565 scm_set_smob_mark (scm_program_tag, mark_program);
566 scm_set_smob_print (scm_program_tag, print_program);
567 }
568
569 /* Scheme interface */
570
571 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
572 (SCM obj),
573 "")
574 #define FUNC_NAME s_scm_program_p
575 {
576 return SCM_BOOL (SCM_PROGRAM_P (obj));
577 }
578 #undef FUNC_NAME
579
580 SCM_DEFINE (scm_make_program, "make-program", 2, 0, 0,
581 (SCM bytecode, SCM parent),
582 "")
583 #define FUNC_NAME s_scm_make_program
584 {
585 SCM_VALIDATE_BYTECODE (1, bytecode);
586 return make_program (bytecode, parent);
587 }
588 #undef FUNC_NAME
589
590 SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
591 (SCM program),
592 "")
593 #define FUNC_NAME s_scm_program_name
594 {
595 SCM_VALIDATE_PROGRAM (1, program);
596 return scm_object_property (program, scm_sym_name);
597 }
598 #undef FUNC_NAME
599
600 SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
601 (SCM program),
602 "")
603 #define FUNC_NAME s_scm_program_code
604 {
605 SCM_VALIDATE_PROGRAM (1, program);
606 return SCM_PROGRAM_CODE (program);
607 }
608 #undef FUNC_NAME
609
610 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
611 (SCM program),
612 "")
613 #define FUNC_NAME s_scm_program_base
614 {
615 SCM_VALIDATE_PROGRAM (1, program);
616 return SCM_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program));
617 }
618 #undef FUNC_NAME
619
620 \f
621 /*
622 * VM Frame
623 */
624
625 static long scm_vm_frame_tag;
626
627 /* This is used for debugging */
628 struct scm_vm_frame {
629 int size;
630 SCM program;
631 SCM variables;
632 SCM dynamic_link;
633 SCM external_link;
634 SCM stack_pointer;
635 SCM return_address;
636 };
637
638 #define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ)
639 #define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR))
640 #define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P)
641
642 static SCM
643 make_vm_frame (SCM *fp)
644 {
645 int i;
646 int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp));
647 struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame");
648 p->program = SCM_VM_FRAME_PROGRAM (fp);
649 p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp);
650 p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (fp);
651 p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp);
652 p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp);
653
654 if (!SCM_FALSEP (p->dynamic_link))
655 p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link));
656
657 size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program);
658 p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
659 for (i = 0; i < size; i++)
660 SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
661
662 SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p);
663 }
664
665 static SCM
666 mark_vm_frame (SCM frame)
667 {
668 struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame);
669 scm_gc_mark (p->program);
670 scm_gc_mark (p->dynamic_link);
671 scm_gc_mark (p->external_link);
672 return p->variables;
673 }
674
675 static void
676 init_vm_frame_type ()
677 {
678 scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0);
679 scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame);
680 }
681
682 /* Scheme interface */
683
684 SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
685 (SCM obj),
686 "")
687 #define FUNC_NAME s_scm_frame_p
688 {
689 return SCM_BOOL (SCM_VM_FRAME_P (obj));
690 }
691 #undef FUNC_NAME
692
693 SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
694 (SCM frame),
695 "")
696 #define FUNC_NAME s_scm_frame_program
697 {
698 SCM_VALIDATE_VM_FRAME (1, frame);
699 return SCM_VM_FRAME_DATA (frame)->program;
700 }
701 #undef FUNC_NAME
702
703 SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
704 (SCM frame),
705 "")
706 #define FUNC_NAME s_scm_frame_variables
707 {
708 SCM_VALIDATE_VM_FRAME (1, frame);
709 return SCM_VM_FRAME_DATA (frame)->variables;
710 }
711 #undef FUNC_NAME
712
713 SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
714 (SCM frame),
715 "")
716 #define FUNC_NAME s_scm_frame_dynamic_link
717 {
718 SCM_VALIDATE_VM_FRAME (1, frame);
719 return SCM_VM_FRAME_DATA (frame)->dynamic_link;
720 }
721 #undef FUNC_NAME
722
723 SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
724 (SCM frame),
725 "")
726 #define FUNC_NAME s_scm_frame_external_link
727 {
728 SCM_VALIDATE_VM_FRAME (1, frame);
729 return SCM_VM_FRAME_DATA (frame)->external_link;
730 }
731 #undef FUNC_NAME
732
733 SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
734 (SCM frame),
735 "")
736 #define FUNC_NAME s_scm_frame_stack_pointer
737 {
738 SCM_VALIDATE_VM_FRAME (1, frame);
739 return SCM_VM_FRAME_DATA (frame)->stack_pointer;
740 }
741 #undef FUNC_NAME
742
743 SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
744 (SCM frame),
745 "")
746 #define FUNC_NAME s_scm_frame_return_address
747 {
748 SCM_VALIDATE_VM_FRAME (1, frame);
749 return SCM_VM_FRAME_DATA (frame)->return_address;
750 }
751 #undef FUNC_NAME
752
753 \f
754 /*
755 * VM Continuation
756 */
757
758 static long scm_vm_cont_tag;
759
760 static SCM
761 capture_vm_cont (struct scm_vm *vmp)
762 {
763 struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
764 p->stack_size = vmp->stack_limit - vmp->sp;
765 p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
766 "capture_vm_cont");
767 p->stack_limit = p->stack_base + p->stack_size - 1;
768 p->pc = vmp->pc;
769 p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
770 p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
771 memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
772 SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p);
773 }
774
775 static void
776 reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
777 {
778 struct scm_vm *p = SCM_VM_CONT_VMP (cont);
779 if (vmp->stack_size < p->stack_size)
780 {
781 puts ("FIXME: Need to expand");
782 abort ();
783 }
784 vmp->pc = p->pc;
785 vmp->sp = vmp->stack_limit - (int) p->sp;
786 vmp->fp = vmp->stack_limit - (int) p->fp;
787 memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
788 }
789
790 static SCM
791 mark_vm_cont (SCM cont)
792 {
793 SCM *p;
794 struct scm_vm *vmp = SCM_VM_CONT_VMP (cont);
795 for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
796 if (SCM_NIMP (*p))
797 scm_gc_mark (*p);
798 return SCM_BOOL_F;
799 }
800
801 static scm_sizet
802 free_vm_cont (SCM cont)
803 {
804 struct scm_vm *p = SCM_VM_CONT_VMP (cont);
805 int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
806 scm_must_free (p->stack_base);
807 scm_must_free (p);
808 return size;
809 }
810
811 static void
812 init_vm_cont_type ()
813 {
814 scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0);
815 scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont);
816 scm_set_smob_free (scm_vm_cont_tag, free_vm_cont);
817 }
818
819 \f
820 /*
821 * VM
822 */
823
824 static long scm_vm_tag;
825
826 static SCM
827 make_vm (int stack_size)
828 {
829 struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm");
830 vmp->stack_size = stack_size;
831 vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm");
832 vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
833 vmp->sp = vmp->stack_limit;
834 vmp->ac = SCM_BOOL_F;
835 vmp->pc = NULL;
836 vmp->fp = NULL;
837 vmp->options = SCM_EOL;
838 vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1));
839 vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1));
840 vmp->next_hook = scm_make_hook (SCM_MAKINUM (1));
841 vmp->call_hook = scm_make_hook (SCM_MAKINUM (1));
842 vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1));
843 vmp->return_hook = scm_make_hook (SCM_MAKINUM (1));
844 SCM_RETURN_NEWSMOB (scm_vm_tag, vmp);
845 }
846
847 static SCM
848 mark_vm (SCM vm)
849 {
850 SCM *p;
851 struct scm_vm *vmp = SCM_VM_DATA (vm);
852 for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
853 if (SCM_NIMP (*p))
854 scm_gc_mark (*p);
855
856 scm_gc_mark (vmp->ac);
857 scm_gc_mark (vmp->boot_hook);
858 scm_gc_mark (vmp->halt_hook);
859 scm_gc_mark (vmp->next_hook);
860 scm_gc_mark (vmp->call_hook);
861 scm_gc_mark (vmp->apply_hook);
862 scm_gc_mark (vmp->return_hook);
863 return vmp->options;
864 }
865
866 static void
867 init_vm_type ()
868 {
869 scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm));
870 scm_set_smob_mark (scm_vm_tag, mark_vm);
871 }
872
873 /* Scheme interface */
874
875 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
876 (),
877 "")
878 #define FUNC_NAME s_scm_vm_version
879 {
880 return scm_makfrom0str (VERSION);
881 }
882 #undef FUNC_NAME
883
884 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
885 (SCM obj),
886 "")
887 #define FUNC_NAME s_scm_vm_p
888 {
889 return SCM_BOOL (SCM_VM_P (obj));
890 }
891 #undef FUNC_NAME
892
893 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
894 (),
895 "")
896 #define FUNC_NAME s_scm_make_vm
897 {
898 return make_vm (VM_DEFAULT_STACK_SIZE);
899 }
900 #undef FUNC_NAME
901
902 SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0,
903 (SCM vm),
904 "")
905 #define FUNC_NAME s_scm_vm_ac
906 {
907 SCM_VALIDATE_VM (1, vm);
908 return SCM_VM_DATA (vm)->ac;
909 }
910 #undef FUNC_NAME
911
912 SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0,
913 (SCM vm),
914 "")
915 #define FUNC_NAME s_scm_vm_pc
916 {
917 SCM_VALIDATE_VM (1, vm);
918 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc);
919 }
920 #undef FUNC_NAME
921
922 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
923 (SCM vm),
924 "")
925 #define FUNC_NAME s_scm_vm_sp
926 {
927 SCM_VALIDATE_VM (1, vm);
928 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->sp);
929 }
930 #undef FUNC_NAME
931
932 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
933 (SCM vm),
934 "")
935 #define FUNC_NAME s_scm_vm_fp
936 {
937 SCM_VALIDATE_VM (1, vm);
938 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp);
939 }
940 #undef FUNC_NAME
941
942 SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
943 (SCM vm),
944 "")
945 #define FUNC_NAME s_scm_vm_current_frame
946 {
947 SCM_VALIDATE_VM (1, vm);
948 return make_vm_frame (SCM_VM_DATA (vm)->fp);
949 }
950 #undef FUNC_NAME
951
952 SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0,
953 (SCM vm, SCM addr),
954 "")
955 #define FUNC_NAME s_scm_vm_fetch_code
956 {
957 SCM *p, list;
958 struct scm_instruction *inst;
959
960 SCM_VALIDATE_VM (1, vm);
961 SCM_VALIDATE_INUM (2, addr);
962
963 p = SCM_VM_ADDRESS (addr);
964
965 inst = find_instruction_by_code (*p);
966 if (!inst)
967 SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr));
968
969 list = SCM_LIST1 (scm_instruction_name (inst->obj));
970 if (inst->type != INST_NONE)
971 {
972 if (inst->type == INST_ADDR)
973 {
974 p = SCM_CODE_TO_ADDR (p[1]);
975 SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p)));
976 }
977 else
978 SCM_SETCDR (list, SCM_LIST1 (p[1]));
979 }
980 return list;
981 }
982 #undef FUNC_NAME
983
984 SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0,
985 (SCM vm),
986 "")
987 #define FUNC_NAME s_scm_vm_stack_to_list
988 {
989 struct scm_vm *vmp;
990 SCM *p, list = SCM_EOL;
991
992 SCM_VALIDATE_VM (1, vm);
993
994 vmp = SCM_VM_DATA (vm);
995 for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
996 list = scm_cons (*p, list);
997 return list;
998 }
999 #undef FUNC_NAME
1000
1001 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
1002 (SCM vm, SCM key),
1003 "")
1004 #define FUNC_NAME s_scm_vm_option
1005 {
1006 SCM_VALIDATE_VM (1, vm);
1007 SCM_VALIDATE_SYMBOL (2, key);
1008 return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
1009 }
1010 #undef FUNC_NAME
1011
1012 SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0,
1013 (SCM vm, SCM key, SCM val),
1014 "")
1015 #define FUNC_NAME s_scm_vm_set_option_x
1016 {
1017 SCM_VALIDATE_VM (1, vm);
1018 SCM_VALIDATE_SYMBOL (2, key);
1019 SCM_VM_DATA (vm)->options
1020 = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
1021 return SCM_UNSPECIFIED;
1022 }
1023 #undef FUNC_NAME
1024
1025 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
1026 (SCM vm),
1027 "")
1028 #define FUNC_NAME s_scm_vm_boot_hook
1029 {
1030 SCM_VALIDATE_VM (1, vm);
1031 return SCM_VM_DATA (vm)->boot_hook;
1032 }
1033 #undef FUNC_NAME
1034
1035 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
1036 (SCM vm),
1037 "")
1038 #define FUNC_NAME s_scm_vm_halt_hook
1039 {
1040 SCM_VALIDATE_VM (1, vm);
1041 return SCM_VM_DATA (vm)->halt_hook;
1042 }
1043 #undef FUNC_NAME
1044
1045 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
1046 (SCM vm),
1047 "")
1048 #define FUNC_NAME s_scm_vm_next_hook
1049 {
1050 SCM_VALIDATE_VM (1, vm);
1051 return SCM_VM_DATA (vm)->next_hook;
1052 }
1053 #undef FUNC_NAME
1054
1055 SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0,
1056 (SCM vm),
1057 "")
1058 #define FUNC_NAME s_scm_vm_call_hook
1059 {
1060 SCM_VALIDATE_VM (1, vm);
1061 return SCM_VM_DATA (vm)->call_hook;
1062 }
1063 #undef FUNC_NAME
1064
1065 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
1066 (SCM vm),
1067 "")
1068 #define FUNC_NAME s_scm_vm_apply_hook
1069 {
1070 SCM_VALIDATE_VM (1, vm);
1071 return SCM_VM_DATA (vm)->apply_hook;
1072 }
1073 #undef FUNC_NAME
1074
1075 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
1076 (SCM vm),
1077 "")
1078 #define FUNC_NAME s_scm_vm_return_hook
1079 {
1080 SCM_VALIDATE_VM (1, vm);
1081 return SCM_VM_DATA (vm)->return_hook;
1082 }
1083 #undef FUNC_NAME
1084
1085 SCM_SYMBOL (sym_debug, "debug");
1086
1087 static SCM scm_regular_vm (SCM vm, SCM program);
1088 static SCM scm_debug_vm (SCM vm, SCM program);
1089
1090 #define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr)
1091
1092 SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0,
1093 (SCM vm, SCM program),
1094 "")
1095 #define FUNC_NAME s_scm_vm_run
1096 {
1097 SCM bootcode;
1098 static SCM template[5];
1099
1100 SCM_VALIDATE_VM (1, vm);
1101 SCM_VALIDATE_PROGRAM (2, program);
1102
1103 if (SCM_EQ_P (template[0], SCM_PACK (0)))
1104 {
1105 template[0] = VM_CODE ("%loadc");
1106 template[1] = SCM_BOOL_F;
1107 template[2] = VM_CODE ("%call");
1108 template[3] = SCM_MAKINUM (0);
1109 template[4] = VM_CODE ("%halt");
1110 }
1111
1112 /* Create a boot program */
1113 bootcode = make_bytecode (5);
1114 memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5);
1115 SCM_BYTECODE_BASE (bootcode)[1] = program;
1116 SCM_BYTECODE_SIZE (bootcode) = 5;
1117 SCM_BYTECODE_EXTS (bootcode) = NULL;
1118 SCM_BYTECODE_NREQS (bootcode) = 0;
1119 SCM_BYTECODE_RESTP (bootcode) = 0;
1120 SCM_BYTECODE_NVARS (bootcode) = 0;
1121 SCM_BYTECODE_NEXTS (bootcode) = 0;
1122 program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F);
1123
1124 if (SCM_FALSEP (scm_vm_option (vm, sym_debug)))
1125 return scm_regular_vm (vm, program);
1126 else
1127 return scm_debug_vm (vm, program);
1128 }
1129 #undef FUNC_NAME
1130
1131 \f
1132 /*
1133 * The VM engines
1134 */
1135
1136 /* We don't want to snarf the engines */
1137 #ifndef SCM_MAGIC_SNARFER
1138
1139 /* the regular engine */
1140 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
1141 #include "vm_engine.c"
1142 #undef VM_ENGINE
1143
1144 /* the debug engine */
1145 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
1146 #include "vm_engine.c"
1147 #undef VM_ENGINE
1148
1149 #endif /* not SCM_MAGIC_SNARFER */
1150
1151 \f
1152 /*
1153 * Initialize
1154 */
1155
1156 static SCM scm_module_vm;
1157
1158 void
1159 scm_init_vm ()
1160 {
1161 SCM old_module;
1162
1163 /* Initialize the module */
1164 scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)"));
1165 old_module = scm_select_module (scm_module_vm);
1166
1167 init_instruction_type ();
1168 init_bytecode_type ();
1169 init_program_type ();
1170 init_vm_frame_type ();
1171 init_vm_cont_type ();
1172 init_vm_type ();
1173
1174 #include "vm.x"
1175
1176 scm_select_module (old_module);
1177
1178 /* Initialize instruction tables */
1179 {
1180 int i;
1181 struct scm_instruction *p;
1182
1183 SCM vm = make_vm (0);
1184 scm_regular_vm (vm, SCM_BOOL_F);
1185 scm_debug_vm (vm, SCM_BOOL_F);
1186
1187 /* hash table */
1188 for (i = 0; i < INSTRUCTION_HASH_SIZE; i++)
1189 scm_instruction_hash_table[i] = NULL;
1190
1191 for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
1192 {
1193 int hash;
1194 struct inst_hash *data;
1195 SCM inst = scm_permanent_object (make_instruction (p));
1196 p->obj = inst;
1197 if (p->restp) p->type = INST_INUM;
1198 hash = INSTRUCTION_HASH (p->addr);
1199 data = scm_must_malloc (sizeof (*data), "inst_hash");
1200 data->addr = p->addr;
1201 data->inst = p;
1202 data->next = scm_instruction_hash_table[hash];
1203 scm_instruction_hash_table[hash] = data;
1204 }
1205 }
1206 }
1207
1208 void
1209 scm_init_vm_vm_module ()
1210 {
1211 scm_register_module_xxx ("vm vm", (void *) scm_init_vm);
1212 }
Unnamed repository; edit this file 'description' to name the repository.