1 /* Copyright (C) 2000 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 #define SCM_DEBUG_TYPING_STRICTNESS 0
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 */
50 /* I sometimes use this for debugging. */
51 #define vm_puts(OBJ) \
53 scm_display (OBJ, scm_def_errp); \
54 scm_newline (scm_def_errp); \
62 static SCM scm_name_property
;
64 SCM_DEFINE (scm_name
, "name", 1, 0, 0,
67 #define FUNC_NAME s_scm_name
69 return scm_primitive_property_ref (scm_name_property
, obj
);
73 SCM_DEFINE (scm_set_name_x
, "set-name!", 2, 0, 0,
76 #define FUNC_NAME s_scm_set_name_x
78 SCM_VALIDATE_SYMBOL (2, name
);
79 return scm_primitive_property_set_x (scm_name_property
, obj
, name
);
84 scm_smob_print_with_name (SCM smob
, SCM port
, scm_print_state
*pstate
)
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
);
91 if (SCM_FALSEP (name
))
93 scm_puts ("0x", port
);
94 scm_intprint (SCM_UNPACK (scm_smobs
[n
].size
? SCM_CDR (smob
) : smob
),
99 scm_display (name
, port
);
101 scm_putc ('>', port
);
106 init_name_property ()
109 = scm_permanent_object (scm_primitive_make_property (SCM_BOOL_F
));
117 #define INSTRUCTION_HASH_SIZE op_last
118 #define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE)
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;
124 /* Hash table for finding instructions from addresses */
125 static struct inst_hash
{
127 struct scm_instruction
*inst
;
128 struct inst_hash
*next
;
129 } *scm_instruction_hash_table
[INSTRUCTION_HASH_SIZE
];
131 static long scm_instruction_tag
;
134 make_instruction (struct scm_instruction
*instp
)
136 SCM_RETURN_NEWSMOB (scm_instruction_tag
, instp
);
140 print_instruction (SCM obj
, SCM port
, scm_print_state
*pstate
)
142 scm_puts ("#<instruction ", port
);
143 scm_puts (SCM_INSTRUCTION_DATA (obj
)->name
, port
);
144 scm_putc ('>', port
);
149 init_instruction_type ()
151 scm_instruction_tag
= scm_make_smob_type ("instruction", 0);
152 scm_set_smob_print (scm_instruction_tag
, print_instruction
);
157 static struct scm_instruction
*
158 find_instruction_by_name (const char *name
)
160 struct scm_instruction
*p
;
161 for (p
= scm_regular_instruction_table
; p
->opcode
!= op_last
; p
++)
162 if (strcmp (name
, p
->name
) == 0)
167 static struct scm_instruction
*
168 find_instruction_by_code (SCM code
)
171 void *addr
= SCM_CODE_TO_ADDR (code
);
172 for (p
= scm_instruction_hash_table
[INSTRUCTION_HASH (addr
)]; p
; p
= p
->next
)
178 #ifdef HAVE_LABELS_AS_VALUES
180 instruction_code_to_debug_addr (SCM code
)
182 struct scm_instruction
*p
= find_instruction_by_code (code
);
183 return scm_debug_instruction_table
[p
->opcode
].addr
;
187 /* Scheme interface */
189 SCM_DEFINE (scm_instruction_p
, "instruction?", 1, 0, 0,
192 #define FUNC_NAME s_scm_instruction_p
194 return SCM_BOOL (SCM_INSTRUCTION_P (obj
));
198 SCM_DEFINE (scm_system_instruction_p
, "system-instruction?", 1, 0, 0,
201 #define FUNC_NAME s_scm_system_instruction_p
203 return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj
));
207 SCM_DEFINE (scm_functional_instruction_p
, "functional-instruction?", 1, 0, 0,
210 #define FUNC_NAME s_scm_functional_instruction_p
212 return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj
));
216 SCM_DEFINE (scm_instruction_name_p
, "instruction-name?", 1, 0, 0,
219 #define FUNC_NAME s_scm_instruction_name_p
221 SCM_VALIDATE_SYMBOL (1, name
);
222 return SCM_BOOL (find_instruction_by_name (SCM_SYMBOL_CHARS (name
)));
226 SCM_DEFINE (scm_symbol_to_instruction
, "symbol->instruction", 1, 0, 0,
229 #define FUNC_NAME s_scm_symbol_to_instruction
231 struct scm_instruction
*p
;
232 SCM_VALIDATE_SYMBOL (1, name
);
234 p
= find_instruction_by_name (SCM_SYMBOL_CHARS (name
));
236 SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name
));
242 SCM_DEFINE (scm_instruction_list
, "instruction-list", 0, 0, 0,
245 #define FUNC_NAME s_scm_instruction_list
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
);
255 SCM_DEFINE (scm_instruction_opcode
, "instruction-opcode", 1, 0, 0,
258 #define FUNC_NAME s_scm_instruction_opcode
260 SCM_VALIDATE_INSTRUCTION (1, inst
);
261 return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst
)->opcode
);
265 SCM_DEFINE (scm_instruction_name
, "instruction-name", 1, 0, 0,
268 #define FUNC_NAME s_scm_instruction_name
270 SCM_VALIDATE_INSTRUCTION (1, inst
);
271 return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst
)->name
));
275 SCM_DEFINE (scm_instruction_type
, "instruction-type", 1, 0, 0,
278 #define FUNC_NAME s_scm_instruction_type
280 SCM_VALIDATE_INSTRUCTION (1, inst
);
281 return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst
)->type
);
285 SCM_DEFINE (scm_instruction_scheme_name
, "instruction-scheme-name", 1, 0, 0,
288 #define FUNC_NAME s_scm_instruction_scheme_name
290 SCM_VALIDATE_INSTRUCTION (1, inst
);
291 if (SCM_FUNCTIONAL_INSTRUCTION_P (inst
))
292 return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst
)->sname
));
298 SCM_DEFINE (scm_instruction_arity
, "instruction-arity", 1, 0, 0,
301 #define FUNC_NAME s_scm_instruction_arity
303 SCM_VALIDATE_INSTRUCTION (1, inst
);
304 if (SCM_FUNCTIONAL_INSTRUCTION_P (inst
))
306 struct scm_instruction
*p
= SCM_INSTRUCTION_DATA (inst
);
307 return SCM_LIST2 (SCM_MAKINUM (p
->nargs
), SCM_BOOL (p
->restp
));
319 static long scm_bytecode_tag
;
322 make_bytecode (int size
)
324 struct scm_bytecode
*p
325 = scm_must_malloc (sizeof (*p
) + (size
* sizeof (SCM
)), "make_bytecode");
327 SCM_RETURN_NEWSMOB (scm_bytecode_tag
, p
);
331 mark_bytecode (SCM bytecode
)
334 struct scm_instruction
*p
;
336 int size
= SCM_BYTECODE_SIZE (bytecode
);
337 SCM
*base
= SCM_BYTECODE_BASE (bytecode
);
339 for (i
= 0; i
< size
; i
++)
341 p
= find_instruction_by_code (base
[i
]);
350 scm_gc_mark (base
[++i
]);
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! */
361 print_bytecode (SCM obj
, SCM port
, scm_print_state
*pstate
)
363 scm_puts ("#<bytecode 0x", port
);
364 scm_intprint ((long) SCM_BYTECODE_BASE (obj
), 16, port
);
365 scm_putc ('>', port
);
370 free_bytecode (SCM bytecode
)
372 int size
= (sizeof (struct scm_bytecode
)
373 + (SCM_BYTECODE_SIZE (bytecode
) * sizeof (SCM
)));
374 if (SCM_BYTECODE_EXTS (bytecode
))
376 size
+= (SCM_BYTECODE_EXTS (bytecode
)[0] + 1) * sizeof (int);
377 scm_must_free (SCM_BYTECODE_EXTS (bytecode
));
379 scm_must_free (SCM_BYTECODE_DATA (bytecode
));
384 init_bytecode_type ()
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
);
392 /* Internal functions */
395 lookup_variable (SCM sym
)
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
);
404 /* Scheme interface */
406 SCM_DEFINE (scm_bytecode_p
, "bytecode?", 1, 0, 0,
409 #define FUNC_NAME s_scm_bytecode_p
411 return SCM_BOOL (SCM_BYTECODE_P (obj
));
415 SCM_DEFINE (scm_make_bytecode
, "make-bytecode", 1, 0, 0,
418 #define FUNC_NAME s_scm_make_bytecode
420 int i
, size
, len
, offset
;
421 SCM header
, body
, nreqs
, restp
, nvars
, nexts
, exts
, bytecode
;
422 SCM
*old
, *new, *address
;
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
);
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
);
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
);
457 SCM_BYTECODE_EXTS (bytecode
) = NULL
;
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
]);
468 /* Initialize the body */
469 for (i
= 0; i
< size
; i
++)
471 struct scm_instruction
*p
;
473 /* Process instruction */
474 if (!SCM_SYMBOLP (old
[i
])
475 || !(p
= find_instruction_by_name (SCM_SYMBOL_CHARS (old
[i
]))))
476 SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old
[i
]));
477 new[i
] = SCM_ADDR_TO_CODE (p
->addr
);
479 /* Process arguments */
480 if (p
->type
== INST_NONE
)
483 SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL
);
487 /* never come here */
489 SCM_VALIDATE_INUM (1, old
[i
]);
496 /* top-level variable */
497 SCM_VALIDATE_SYMBOL (1, old
[i
]);
498 new[i
] = lookup_variable (old
[i
]);
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
]));
508 /* another bytecode */
509 new[i
] = scm_make_bytecode (old
[i
]);
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
);
526 SCM_DEFINE (scm_bytecode_decode
, "bytecode-decode", 1, 0, 0,
529 #define FUNC_NAME s_scm_bytecode_decode
532 SCM code
, *old
, *new;
534 SCM_VALIDATE_BYTECODE (1, bytecode
);
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
);
541 for (i
= 0; i
< size
; i
++)
543 struct scm_instruction
*p
;
545 /* Process instruction */
546 p
= find_instruction_by_code (old
[i
]);
550 SCM_MISC_ERROR ("Broken bytecode", SCM_EOL
);
552 new[i
] = scm_instruction_name (p
->obj
);
554 /* Process arguments */
555 if (p
->type
== INST_NONE
)
562 /* never come here */
570 /* top-level variable */
571 new[i
] = SCM_CAR (old
[i
]);
574 /* another bytecode */
575 new[i
] = scm_bytecode_decode (old
[i
]);
578 /* program address */
579 offset
= SCM_VM_ADDRESS (old
[i
]) - old
;
580 new[i
] = SCM_MAKINUM (offset
);
593 static long scm_program_tag
;
596 make_program (SCM code
, SCM env
)
598 SCM_RETURN_NEWSMOB2 (scm_program_tag
, SCM_UNPACK (code
), SCM_UNPACK (env
));
602 mark_program (SCM program
)
604 scm_gc_mark (SCM_PROGRAM_CODE (program
));
605 return SCM_PROGRAM_ENV (program
);
608 static SCM
scm_vm_apply (SCM vm
, SCM program
, SCM args
);
609 static SCM
make_vm (int stack_size
);
612 apply_program (SCM program
, SCM args
)
614 return scm_vm_apply (make_vm (VM_DEFAULT_STACK_SIZE
), program
, args
);
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);
626 /* Scheme interface */
628 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
631 #define FUNC_NAME s_scm_program_p
633 return SCM_BOOL (SCM_PROGRAM_P (obj
));
637 SCM_DEFINE (scm_make_program
, "make-program", 2, 0, 0,
638 (SCM bytecode
, SCM parent
),
640 #define FUNC_NAME s_scm_make_program
642 SCM_VALIDATE_BYTECODE (1, bytecode
);
643 return make_program (bytecode
, parent
);
647 SCM_DEFINE (scm_program_code
, "program-code", 1, 0, 0,
650 #define FUNC_NAME s_scm_program_code
652 SCM_VALIDATE_PROGRAM (1, program
);
653 return SCM_PROGRAM_CODE (program
);
657 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
660 #define FUNC_NAME s_scm_program_base
662 SCM_VALIDATE_PROGRAM (1, program
);
663 return SCM_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program
));
672 static long scm_vm_frame_tag
;
674 /* This is used for debugging */
675 struct scm_vm_frame
{
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)
690 make_vm_frame (SCM
*fp
)
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
);
701 if (!SCM_FALSEP (p
->dynamic_link
))
702 p
->dynamic_link
= make_vm_frame (SCM_VM_ADDRESS (p
->dynamic_link
));
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
);
709 SCM_RETURN_NEWSMOB (scm_vm_frame_tag
, p
);
713 mark_vm_frame (SCM frame
)
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
);
723 init_vm_frame_type ()
725 scm_vm_frame_tag
= scm_make_smob_type ("vm-frame", 0);
726 scm_set_smob_mark (scm_vm_frame_tag
, mark_vm_frame
);
729 /* Scheme interface */
731 SCM_DEFINE (scm_frame_p
, "frame?", 1, 0, 0,
734 #define FUNC_NAME s_scm_frame_p
736 return SCM_BOOL (SCM_VM_FRAME_P (obj
));
740 SCM_DEFINE (scm_frame_program
, "frame-program", 1, 0, 0,
743 #define FUNC_NAME s_scm_frame_program
745 SCM_VALIDATE_VM_FRAME (1, frame
);
746 return SCM_VM_FRAME_DATA (frame
)->program
;
750 SCM_DEFINE (scm_frame_variables
, "frame-variables", 1, 0, 0,
753 #define FUNC_NAME s_scm_frame_variables
755 SCM_VALIDATE_VM_FRAME (1, frame
);
756 return SCM_VM_FRAME_DATA (frame
)->variables
;
760 SCM_DEFINE (scm_frame_dynamic_link
, "frame-dynamic-link", 1, 0, 0,
763 #define FUNC_NAME s_scm_frame_dynamic_link
765 SCM_VALIDATE_VM_FRAME (1, frame
);
766 return SCM_VM_FRAME_DATA (frame
)->dynamic_link
;
770 SCM_DEFINE (scm_frame_external_link
, "frame-external-link", 1, 0, 0,
773 #define FUNC_NAME s_scm_frame_external_link
775 SCM_VALIDATE_VM_FRAME (1, frame
);
776 return SCM_VM_FRAME_DATA (frame
)->external_link
;
780 SCM_DEFINE (scm_frame_stack_pointer
, "frame-stack-pointer", 1, 0, 0,
783 #define FUNC_NAME s_scm_frame_stack_pointer
785 SCM_VALIDATE_VM_FRAME (1, frame
);
786 return SCM_VM_FRAME_DATA (frame
)->stack_pointer
;
790 SCM_DEFINE (scm_frame_return_address
, "frame-return-address", 1, 0, 0,
793 #define FUNC_NAME s_scm_frame_return_address
795 SCM_VALIDATE_VM_FRAME (1, frame
);
796 return SCM_VM_FRAME_DATA (frame
)->return_address
;
805 static long scm_vm_cont_tag
;
808 capture_vm_cont (struct scm_vm
*vmp
)
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
),
814 p
->stack_limit
= p
->stack_base
+ p
->stack_size
- 1;
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
);
823 reinstate_vm_cont (struct scm_vm
*vmp
, SCM cont
)
825 struct scm_vm
*p
= SCM_VM_CONT_VMP (cont
);
826 if (vmp
->stack_size
< p
->stack_size
)
828 puts ("FIXME: Need to expand");
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
));
838 mark_vm_cont (SCM cont
)
841 struct scm_vm
*vmp
= SCM_VM_CONT_VMP (cont
);
842 for (p
= vmp
->stack_base
; p
<= vmp
->stack_limit
; p
++)
849 free_vm_cont (SCM cont
)
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
);
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
);
871 static long scm_vm_tag
;
874 make_vm (int stack_size
)
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
;
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
);
898 struct scm_vm
*vmp
= SCM_VM_DATA (vm
);
899 for (p
= vmp
->sp
+ 1; p
<= vmp
->stack_limit
; p
++)
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
);
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
);
921 /* Scheme interface */
923 SCM_DEFINE (scm_vm_version
, "vm-version", 0, 0, 0,
926 #define FUNC_NAME s_scm_vm_version
928 return scm_makfrom0str (VERSION
);
932 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
935 #define FUNC_NAME s_scm_vm_p
937 return SCM_BOOL (SCM_VM_P (obj
));
941 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
944 #define FUNC_NAME s_scm_make_vm
946 return make_vm (VM_DEFAULT_STACK_SIZE
);
950 SCM_DEFINE (scm_vm_ac
, "vm:ac", 1, 0, 0,
953 #define FUNC_NAME s_scm_vm_ac
955 SCM_VALIDATE_VM (1, vm
);
956 return SCM_VM_DATA (vm
)->ac
;
960 SCM_DEFINE (scm_vm_pc
, "vm:pc", 1, 0, 0,
963 #define FUNC_NAME s_scm_vm_pc
965 SCM_VALIDATE_VM (1, vm
);
966 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm
)->pc
);
970 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
973 #define FUNC_NAME s_scm_vm_sp
975 SCM_VALIDATE_VM (1, vm
);
976 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm
)->sp
);
980 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
983 #define FUNC_NAME s_scm_vm_fp
985 SCM_VALIDATE_VM (1, vm
);
986 return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm
)->fp
);
990 SCM_DEFINE (scm_vm_current_frame
, "vm-current-frame", 1, 0, 0,
993 #define FUNC_NAME s_scm_vm_current_frame
995 SCM_VALIDATE_VM (1, vm
);
996 return make_vm_frame (SCM_VM_DATA (vm
)->fp
);
1000 SCM_DEFINE (scm_vm_fetch_code
, "vm-fetch-code", 2, 0, 0,
1003 #define FUNC_NAME s_scm_vm_fetch_code
1006 struct scm_instruction
*inst
;
1008 SCM_VALIDATE_VM (1, vm
);
1009 SCM_VALIDATE_INUM (2, addr
);
1011 p
= SCM_VM_ADDRESS (addr
);
1013 inst
= find_instruction_by_code (*p
);
1015 SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr
));
1017 list
= SCM_LIST1 (scm_instruction_name (inst
->obj
));
1018 if (inst
->type
!= INST_NONE
)
1020 if (inst
->type
== INST_ADDR
)
1022 p
= SCM_CODE_TO_ADDR (p
[1]);
1023 SCM_SETCDR (list
, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p
)));
1026 SCM_SETCDR (list
, SCM_LIST1 (p
[1]));
1032 SCM_DEFINE (scm_vm_stack_to_list
, "vm-stack->list", 1, 0, 0,
1035 #define FUNC_NAME s_scm_vm_stack_to_list
1038 SCM
*p
, list
= SCM_EOL
;
1040 SCM_VALIDATE_VM (1, vm
);
1042 vmp
= SCM_VM_DATA (vm
);
1043 for (p
= vmp
->sp
+ 1; p
<= vmp
->stack_limit
; p
++)
1044 list
= scm_cons (*p
, list
);
1049 SCM_DEFINE (scm_vm_option
, "vm-option", 2, 0, 0,
1052 #define FUNC_NAME s_scm_vm_option
1054 SCM_VALIDATE_VM (1, vm
);
1055 SCM_VALIDATE_SYMBOL (2, key
);
1056 return scm_assq_ref (SCM_VM_DATA (vm
)->options
, key
);
1060 SCM_DEFINE (scm_vm_set_option_x
, "vm-set-option!", 3, 0, 0,
1061 (SCM vm
, SCM key
, SCM val
),
1063 #define FUNC_NAME s_scm_vm_set_option_x
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
;
1073 SCM_DEFINE (scm_vm_boot_hook
, "vm-boot-hook", 1, 0, 0,
1076 #define FUNC_NAME s_scm_vm_boot_hook
1078 SCM_VALIDATE_VM (1, vm
);
1079 return SCM_VM_DATA (vm
)->boot_hook
;
1083 SCM_DEFINE (scm_vm_halt_hook
, "vm-halt-hook", 1, 0, 0,
1086 #define FUNC_NAME s_scm_vm_halt_hook
1088 SCM_VALIDATE_VM (1, vm
);
1089 return SCM_VM_DATA (vm
)->halt_hook
;
1093 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
1096 #define FUNC_NAME s_scm_vm_next_hook
1098 SCM_VALIDATE_VM (1, vm
);
1099 return SCM_VM_DATA (vm
)->next_hook
;
1103 SCM_DEFINE (scm_vm_call_hook
, "vm-call-hook", 1, 0, 0,
1106 #define FUNC_NAME s_scm_vm_call_hook
1108 SCM_VALIDATE_VM (1, vm
);
1109 return SCM_VM_DATA (vm
)->call_hook
;
1113 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
1116 #define FUNC_NAME s_scm_vm_apply_hook
1118 SCM_VALIDATE_VM (1, vm
);
1119 return SCM_VM_DATA (vm
)->apply_hook
;
1123 SCM_DEFINE (scm_vm_return_hook
, "vm-return-hook", 1, 0, 0,
1126 #define FUNC_NAME s_scm_vm_return_hook
1128 SCM_VALIDATE_VM (1, vm
);
1129 return SCM_VM_DATA (vm
)->return_hook
;
1133 SCM_SYMBOL (sym_debug
, "debug");
1135 static SCM
scm_regular_vm (SCM vm
, SCM program
);
1136 static SCM
scm_debug_vm (SCM vm
, SCM program
);
1138 #define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr)
1140 SCM_DEFINE (scm_vm_run
, "vm-run", 2, 0, 0,
1141 (SCM vm
, SCM program
),
1143 #define FUNC_NAME s_scm_vm_run
1146 static SCM
template[5];
1148 SCM_VALIDATE_VM (1, vm
);
1149 SCM_VALIDATE_PROGRAM (2, program
);
1151 if (SCM_EQ_P (template[0], SCM_PACK (0)))
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");
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
);
1172 if (SCM_FALSEP (scm_vm_option (vm
, sym_debug
)))
1173 return scm_regular_vm (vm
, program
);
1175 return scm_debug_vm (vm
, program
);
1179 SCM_DEFINE (scm_vm_apply
, "vm-apply", 3, 0, 0,
1180 (SCM vm
, SCM program
, SCM args
),
1182 #define FUNC_NAME s_scm_vm_apply
1186 static SCM
template[7];
1188 SCM_VALIDATE_VM (1, vm
);
1189 SCM_VALIDATE_PROGRAM (2, program
);
1190 SCM_VALIDATE_LIST_COPYLEN (3, args
, len
);
1192 if (SCM_EQ_P (template[0], SCM_PACK (0)))
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");
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
);
1217 if (SCM_FALSEP (scm_vm_option (vm
, sym_debug
)))
1218 return scm_regular_vm (vm
, program
);
1220 return scm_debug_vm (vm
, program
);
1229 /* We don't want to snarf the engines */
1230 #ifndef SCM_MAGIC_SNARFER
1232 /* the regular engine */
1233 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
1234 #include "vm_engine.c"
1237 /* the debug engine */
1238 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
1239 #include "vm_engine.c"
1242 #endif /* not SCM_MAGIC_SNARFER */
1249 static SCM scm_module_vm
;
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
);
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 ();
1270 scm_select_module (old_module
);
1272 /* Initialize instruction tables */
1275 struct scm_instruction
*p
;
1277 SCM vm
= make_vm (0);
1278 scm_regular_vm (vm
, SCM_BOOL_F
);
1279 scm_debug_vm (vm
, SCM_BOOL_F
);
1282 for (i
= 0; i
< INSTRUCTION_HASH_SIZE
; i
++)
1283 scm_instruction_hash_table
[i
] = NULL
;
1285 for (p
= scm_regular_instruction_table
; p
->opcode
!= op_last
; p
++)
1288 struct inst_hash
*data
;
1289 SCM inst
= scm_permanent_object (make_instruction (p
));
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
;
1296 data
->next
= scm_instruction_hash_table
[hash
];
1297 scm_instruction_hash_table
[hash
] = data
;
1303 scm_init_vm_vm_module ()
1305 scm_register_module_xxx ("vm vm", (void *) scm_init_vm
);