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