HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial revision
[bpt/guile.git] / src / vm.c
CommitLineData
a98cef7e
KN		 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 (1 * 1024) /* = 128KB */
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. */
66static struct scm_instruction *scm_regular_instruction_table = 0;
67static struct scm_instruction *scm_debug_instruction_table = 0;
68
69/* Hash table for finding instructions from addresses */
70static 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
76static long scm_instruction_tag;
77
78static SCM
79make_instruction (struct scm_instruction *instp)
80{
81 SCM_RETURN_NEWSMOB (scm_instruction_tag, instp);
82}
83
84static int
85print_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
93static void
94init_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
102static struct scm_instruction *
103find_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
112static struct scm_instruction *
113find_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
124static void *
125instruction_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
134SCM_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
143SCM_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
152SCM_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
161SCM_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
171SCM_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
187SCM_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
200SCM_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
210SCM_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
220SCM_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
230SCM_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
243SCM_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
264static long scm_bytecode_tag;
265
266static SCM
267make_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
275static SCM
276mark_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
305static int
306print_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
314static scm_sizet
315free_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
328static void
329init_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
339SCM_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
348SCM_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
459SCM_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
526static long scm_program_tag;
527
528static SCM
529make_program (SCM bytecode, SCM parent)
530{
531 SCM env = SCM_PROGRAM_P (parent) ? SCM_PROGRAM_ENV (parent) : SCM_BOOL_F;
532 int nexts = SCM_BYTECODE_NEXTS (bytecode);
533
534 if (nexts)
535 {
536 SCM tmp = SCM_VM_MAKE_EXTERNAL (nexts);
537 SCM_VM_EXTERNAL_LINK (tmp) = env;
538 env = tmp;
539 }
540
541 SCM_RETURN_NEWSMOB2 (scm_program_tag,
542 SCM_UNPACK (bytecode),
543 SCM_UNPACK (env));
544}
545
546static SCM
547mark_program (SCM program)
548{
549 scm_gc_mark (SCM_PROGRAM_CODE (program));
550 return SCM_PROGRAM_ENV (program);
551}
552
553static SCM scm_program_name (SCM program);
554
555static int
556print_program (SCM obj, SCM port, scm_print_state *pstate)
557{
558 SCM name = scm_program_name (obj);
559 scm_puts ("#<program ", port);
560 if (SCM_FALSEP (name))
561 {
562 scm_puts ("0x", port);
563 scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
564 }
565 else
566 {
567 scm_display (name, port);
568 }
569 scm_putc ('>', port);
570 return 1;
571}
572
573static void
574init_program_type ()
575{
576 scm_program_tag = scm_make_smob_type ("program", 0);
577 scm_set_smob_mark (scm_program_tag, mark_program);
578 scm_set_smob_print (scm_program_tag, print_program);
579}
580
581/* Scheme interface */
582
583SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
584 (SCM obj),
585"")
586#define FUNC_NAME s_scm_program_p
587{
588 return SCM_BOOL (SCM_PROGRAM_P (obj));
589}
590#undef FUNC_NAME
591
592SCM_DEFINE (scm_make_program, "make-program", 2, 0, 0,
593 (SCM bytecode, SCM parent),
594"")
595#define FUNC_NAME s_scm_make_program
596{
597 SCM_VALIDATE_BYTECODE (1, bytecode);
598 return make_program (bytecode, parent);
599}
600#undef FUNC_NAME
601
602SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
603 (SCM program),
604"")
605#define FUNC_NAME s_scm_program_name
606{
607 SCM_VALIDATE_PROGRAM (1, program);
608 return scm_object_property (program, scm_sym_name);
609}
610#undef FUNC_NAME
611
612SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
613 (SCM program),
614"")
615#define FUNC_NAME s_scm_program_code
616{
617 SCM_VALIDATE_PROGRAM (1, program);
618 return SCM_PROGRAM_CODE (program);
619}
620#undef FUNC_NAME
621
622SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
623 (SCM program),
624"")
625#define FUNC_NAME s_scm_program_base
626{
627 SCM_VALIDATE_PROGRAM (1, program);
628 return SCM_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program));
629}
630#undef FUNC_NAME
631
632SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
633 (SCM program),
634"")
635#define FUNC_NAME s_scm_program_external
636{
637 SCM_VALIDATE_PROGRAM (1, program);
638 return SCM_PROGRAM_ENV (program);
639}
640#undef FUNC_NAME
641
642\f
643/*
644 * VM Frame
645 */
646
647static long scm_vm_frame_tag;
648
649/* This is used for debugging */
650struct scm_vm_frame {
651 int size;
652 SCM program;
653 SCM variables;
654 SCM dynamic_link;
655 SCM stack_pointer;
656 SCM return_address;
657};
658
659#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ)
660#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR))
661#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P)
662
663static SCM
664make_vm_frame (SCM *fp)
665{
666 int i;
667 int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp));
668 struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame");
669 p->program = SCM_VM_FRAME_PROGRAM (fp);
670 p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp);
671 p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp);
672 p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp);
673
674 if (!SCM_FALSEP (p->dynamic_link))
675 p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link));
676
677 size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program);
678 p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
679 for (i = 0; i < size; i++)
680 SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
681
682 SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p);
683}
684
685static SCM
686mark_vm_frame (SCM frame)
687{
688 struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame);
689 scm_gc_mark (p->program);
690 scm_gc_mark (p->dynamic_link);
691 return p->variables;
692}
693
694static void
695init_vm_frame_type ()
696{
697 scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0);
698 scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame);
699}
700
701/* Scheme interface */
702
703SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
704 (SCM obj),
705"")
706#define FUNC_NAME s_scm_frame_p
707{
708 return SCM_BOOL (SCM_VM_FRAME_P (obj));
709}
710#undef FUNC_NAME
711
712SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
713 (SCM frame),
714"")
715#define FUNC_NAME s_scm_frame_program
716{
717 SCM_VALIDATE_VM_FRAME (1, frame);
718 return SCM_VM_FRAME_DATA (frame)->program;
719}
720#undef FUNC_NAME
721
722SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
723 (SCM frame),
724"")
725#define FUNC_NAME s_scm_frame_variables
726{
727 SCM_VALIDATE_VM_FRAME (1, frame);
728 return SCM_VM_FRAME_DATA (frame)->variables;
729}
730#undef FUNC_NAME
731
732SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
733 (SCM frame),
734"")
735#define FUNC_NAME s_scm_frame_dynamic_link
736{
737 SCM_VALIDATE_VM_FRAME (1, frame);
738 return SCM_VM_FRAME_DATA (frame)->dynamic_link;
739}
740#undef FUNC_NAME
741
742SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
743 (SCM frame),
744"")
745#define FUNC_NAME s_scm_frame_stack_pointer
746{
747 SCM_VALIDATE_VM_FRAME (1, frame);
748 return SCM_VM_FRAME_DATA (frame)->stack_pointer;
749}
750#undef FUNC_NAME
751
752SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
753 (SCM frame),
754"")
755#define FUNC_NAME s_scm_frame_return_address
756{
757 SCM_VALIDATE_VM_FRAME (1, frame);
758 return SCM_VM_FRAME_DATA (frame)->return_address;
759}
760#undef FUNC_NAME
761
762\f
763/*
764 * VM Continuation
765 */
766
767static long scm_vm_cont_tag;
768
769static SCM
770capture_vm_cont (struct scm_vm *vmp)
771{
772 struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
773 p->stack_size = vmp->stack_limit - vmp->sp;
774 p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
775 "capture_vm_cont");
776 p->stack_limit = p->stack_base + p->stack_size - 1;
777 p->pc = vmp->pc;
778 p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
779 p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
780 memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
781 SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p);
782}
783
784static void
785reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
786{
787 struct scm_vm *p = SCM_VM_CONT_VMP (cont);
788 if (vmp->stack_size < p->stack_size)
789 {
790 puts ("FIXME: Need to expand");
791 abort ();
792 }
793 vmp->pc = p->pc;
794 vmp->sp = vmp->stack_limit - (int) p->sp;
795 vmp->fp = vmp->stack_limit - (int) p->fp;
796 memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
797}
798
799static SCM
800mark_vm_cont (SCM cont)
801{
802 SCM *p;
803 struct scm_vm *vmp = SCM_VM_CONT_VMP (cont);
804 for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
805 if (SCM_NIMP (*p))
806 scm_gc_mark (*p);
807 return SCM_BOOL_F;
808}
809
810static scm_sizet
811free_vm_cont (SCM cont)
812{
813 struct scm_vm *p = SCM_VM_CONT_VMP (cont);
814 int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
815 scm_must_free (p->stack_base);
816 scm_must_free (p);
817 return size;
818}
819
820static void
821init_vm_cont_type ()
822{
823 scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0);
824 scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont);
825 scm_set_smob_free (scm_vm_cont_tag, free_vm_cont);
826}
827
828\f
829/*
830 * VM
831 */
832
833static long scm_vm_tag;
834
835static SCM
836make_vm (int stack_size)
837{
838 struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm");
839 vmp->stack_size = stack_size;
840 vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm");
841 vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
842 vmp->sp = vmp->stack_limit;
843 vmp->ac = SCM_BOOL_F;
844 vmp->pc = NULL;
845 vmp->fp = NULL;
846 vmp->options = SCM_EOL;
847 vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1));
848 vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1));
849 vmp->next_hook = scm_make_hook (SCM_MAKINUM (1));
850 vmp->call_hook = scm_make_hook (SCM_MAKINUM (1));
851 vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1));
852 vmp->return_hook = scm_make_hook (SCM_MAKINUM (1));
853 SCM_RETURN_NEWSMOB (scm_vm_tag, vmp);
854}
855
856static SCM
857mark_vm (SCM vm)
858{
859 SCM *p;
860 struct scm_vm *vmp = SCM_VM_DATA (vm);
861 for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
862 if (SCM_NIMP (*p))
863 scm_gc_mark (*p);
864
865 scm_gc_mark (vmp->ac);
866 scm_gc_mark (vmp->boot_hook);
867 scm_gc_mark (vmp->halt_hook);
868 scm_gc_mark (vmp->next_hook);
869 scm_gc_mark (vmp->call_hook);
870 scm_gc_mark (vmp->apply_hook);
871 scm_gc_mark (vmp->return_hook);
872 return vmp->options;
873}
874
875static void
876init_vm_type ()
877{
878 scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm));
879 scm_set_smob_mark (scm_vm_tag, mark_vm);
880}
881
882/* Scheme interface */
883
884SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
885 (),
886"")
887#define FUNC_NAME s_scm_vm_version
888{
889 return scm_makfrom0str (VERSION);
890}
891#undef FUNC_NAME
892
893SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
894 (SCM obj),
895"")
896#define FUNC_NAME s_scm_vm_p
897{
898 return SCM_BOOL (SCM_VM_P (obj));
899}
900#undef FUNC_NAME
901
902SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
903 (),
904"")
905#define FUNC_NAME s_scm_make_vm
906{
907 return make_vm (VM_DEFAULT_STACK_SIZE);
908}
909#undef FUNC_NAME
910
911SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0,
912 (SCM vm),
913"")
914#define FUNC_NAME s_scm_vm_ac
915{
916 SCM_VALIDATE_VM (1, vm);
917 return SCM_VM_DATA (vm)->ac;
918}
919#undef FUNC_NAME
920
921SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0,
922 (SCM vm),
923"")
924#define FUNC_NAME s_scm_vm_pc
925{
926 SCM_VALIDATE_VM (1, vm);
927 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc);
928}
929#undef FUNC_NAME
930
931SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
932 (SCM vm),
933"")
934#define FUNC_NAME s_scm_vm_sp
935{
936 SCM_VALIDATE_VM (1, vm);
937 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->sp);
938}
939#undef FUNC_NAME
940
941SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
942 (SCM vm),
943"")
944#define FUNC_NAME s_scm_vm_fp
945{
946 SCM_VALIDATE_VM (1, vm);
947 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp);
948}
949#undef FUNC_NAME
950
951SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
952 (SCM vm),
953"")
954#define FUNC_NAME s_scm_vm_current_frame
955{
956 SCM_VALIDATE_VM (1, vm);
957 return make_vm_frame (SCM_VM_DATA (vm)->fp);
958}
959#undef FUNC_NAME
960
961SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0,
962 (SCM vm, SCM addr),
963"")
964#define FUNC_NAME s_scm_vm_fetch_code
965{
966 SCM *p, list;
967 struct scm_instruction *inst;
968
969 SCM_VALIDATE_VM (1, vm);
970 SCM_VALIDATE_INUM (2, addr);
971
972 p = SCM_VM_ADDRESS (addr);
973
974 inst = find_instruction_by_code (*p);
975 if (!inst)
976 SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr));
977
978 list = SCM_LIST1 (scm_instruction_name (inst->obj));
979 if (inst->type != INST_NONE)
980 {
981 if (inst->type == INST_ADDR)
982 {
983 p = SCM_CODE_TO_ADDR (p[1]);
984 SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p)));
985 }
986 else
987 SCM_SETCDR (list, SCM_LIST1 (p[1]));
988 }
989 return list;
990}
991#undef FUNC_NAME
992
993SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0,
994 (SCM vm),
995"")
996#define FUNC_NAME s_scm_vm_stack_to_list
997{
998 struct scm_vm *vmp;
999 SCM *p, list = SCM_EOL;
1000
1001 SCM_VALIDATE_VM (1, vm);
1002
1003 vmp = SCM_VM_DATA (vm);
1004 for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
1005 list = scm_cons (*p, list);
1006 return list;
1007}
1008#undef FUNC_NAME
1009
1010SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
1011 (SCM vm, SCM key),
1012"")
1013#define FUNC_NAME s_scm_vm_option
1014{
1015 SCM_VALIDATE_VM (1, vm);
1016 SCM_VALIDATE_SYMBOL (2, key);
1017 return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
1018}
1019#undef FUNC_NAME
1020
1021SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0,
1022 (SCM vm, SCM key, SCM val),
1023"")
1024#define FUNC_NAME s_scm_vm_set_option_x
1025{
1026 SCM_VALIDATE_VM (1, vm);
1027 SCM_VALIDATE_SYMBOL (2, key);
1028 SCM_VM_DATA (vm)->options
1029 = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
1030 return SCM_UNSPECIFIED;
1031}
1032#undef FUNC_NAME
1033
1034SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
1035 (SCM vm),
1036"")
1037#define FUNC_NAME s_scm_vm_boot_hook
1038{
1039 SCM_VALIDATE_VM (1, vm);
1040 return SCM_VM_DATA (vm)->boot_hook;
1041}
1042#undef FUNC_NAME
1043
1044SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
1045 (SCM vm),
1046"")
1047#define FUNC_NAME s_scm_vm_halt_hook
1048{
1049 SCM_VALIDATE_VM (1, vm);
1050 return SCM_VM_DATA (vm)->halt_hook;
1051}
1052#undef FUNC_NAME
1053
1054SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
1055 (SCM vm),
1056"")
1057#define FUNC_NAME s_scm_vm_next_hook
1058{
1059 SCM_VALIDATE_VM (1, vm);
1060 return SCM_VM_DATA (vm)->next_hook;
1061}
1062#undef FUNC_NAME
1063
1064SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0,
1065 (SCM vm),
1066"")
1067#define FUNC_NAME s_scm_vm_call_hook
1068{
1069 SCM_VALIDATE_VM (1, vm);
1070 return SCM_VM_DATA (vm)->call_hook;
1071}
1072#undef FUNC_NAME
1073
1074SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
1075 (SCM vm),
1076"")
1077#define FUNC_NAME s_scm_vm_apply_hook
1078{
1079 SCM_VALIDATE_VM (1, vm);
1080 return SCM_VM_DATA (vm)->apply_hook;
1081}
1082#undef FUNC_NAME
1083
1084SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
1085 (SCM vm),
1086"")
1087#define FUNC_NAME s_scm_vm_return_hook
1088{
1089 SCM_VALIDATE_VM (1, vm);
1090 return SCM_VM_DATA (vm)->return_hook;
1091}
1092#undef FUNC_NAME
1093
1094SCM_SYMBOL (sym_debug, "debug");
1095
1096static SCM scm_regular_vm (SCM vm, SCM program);
1097static SCM scm_debug_vm (SCM vm, SCM program);
1098
1099#define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr)
1100
1101SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0,
1102 (SCM vm, SCM program),
1103"")
1104#define FUNC_NAME s_scm_vm_run
1105{
1106 SCM bootcode;
1107 static SCM template[5];
1108
1109 SCM_VALIDATE_VM (1, vm);
1110 SCM_VALIDATE_PROGRAM (2, program);
1111
1112 if (SCM_EQ_P (template[0], SCM_PACK (0)))
1113 {
1114 template[0] = VM_CODE ("%loadc");
1115 template[1] = SCM_BOOL_F;
1116 template[2] = VM_CODE ("%call");
1117 template[3] = SCM_MAKINUM (0);
1118 template[4] = VM_CODE ("%halt");
1119 }
1120
1121 /* Create a boot program */
1122 bootcode = make_bytecode (5);
1123 memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5);
1124 SCM_BYTECODE_BASE (bootcode)[1] = program;
1125 SCM_BYTECODE_SIZE (bootcode) = 5;
1126 SCM_BYTECODE_EXTS (bootcode) = NULL;
1127 SCM_BYTECODE_NREQS (bootcode) = 0;
1128 SCM_BYTECODE_RESTP (bootcode) = 0;
1129 SCM_BYTECODE_NVARS (bootcode) = 0;
1130 SCM_BYTECODE_NEXTS (bootcode) = 0;
1131 program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F);
1132
1133 if (SCM_FALSEP (scm_vm_option (vm, sym_debug)))
1134 return scm_regular_vm (vm, program);
1135 else
1136 return scm_debug_vm (vm, program);
1137}
1138#undef FUNC_NAME
1139
1140\f
1141/*
1142 * The VM engines
1143 */
1144
1145/* We don't want to snarf the engines */
1146#ifndef SCM_MAGIC_SNARFER
1147
1148/* the regular engine */
1149#define VM_ENGINE SCM_VM_REGULAR_ENGINE
1150#include "vm_engine.c"
1151#undef VM_ENGINE
1152
1153/* the debug engine */
1154#define VM_ENGINE SCM_VM_DEBUG_ENGINE
1155#include "vm_engine.c"
1156#undef VM_ENGINE
1157
1158#endif /* not SCM_MAGIC_SNARFER */
1159
1160\f
1161/*
1162 * Initialize
1163 */
1164
1165static SCM scm_module_vm;
1166
1167void
1168scm_init_vm ()
1169{
1170 SCM old_module;
1171
1172 /* Initialize the module */
1173 scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)"));
1174 old_module = scm_select_module (scm_module_vm);
1175
1176 init_instruction_type ();
1177 init_bytecode_type ();
1178 init_program_type ();
1179 init_vm_frame_type ();
1180 init_vm_cont_type ();
1181 init_vm_type ();
1182
1183#include "vm.x"
1184
1185 scm_select_module (old_module);
1186
1187 /* Initialize instruction tables */
1188 {
1189 int i;
1190 struct scm_instruction *p;
1191
1192 SCM vm = make_vm (0);
1193 scm_regular_vm (vm, SCM_BOOL_F);
1194 scm_debug_vm (vm, SCM_BOOL_F);
1195
1196 /* hash table */
1197 for (i = 0; i < INSTRUCTION_HASH_SIZE; i++)
1198 scm_instruction_hash_table[i] = NULL;
1199
1200 for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
1201 {
1202 int hash;
1203 struct inst_hash *data;
1204 SCM inst = scm_permanent_object (make_instruction (p));
1205 p->obj = inst;
1206 if (p->restp) p->type = INST_INUM;
1207 hash = INSTRUCTION_HASH (p->addr);
1208 data = scm_must_malloc (sizeof (*data), "inst_hash");
1209 data->addr = p->addr;
1210 data->inst = p;
1211 data->next = scm_instruction_hash_table[hash];
1212 scm_instruction_hash_table[hash] = data;
1213 }
1214 }
1215}
1216
1217void
1218scm_init_vm_vm_module ()
1219{
1220 scm_register_module_xxx ("vm vm", (void *) scm_init_vm);
1221}
Unnamed repository; edit this file 'description' to name the repository.