1 /* Copyright (C) 2001 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. */
47 #include "vm-bootstrap.h"
49 #include "instructions.h"
54 /* I sometimes use this for debugging. */
55 #define vm_puts(OBJ) \
57 scm_display (OBJ, scm_current_error_port ()); \
58 scm_newline (scm_current_error_port ()); \
66 scm_t_bits scm_tc16_vm_cont
;
69 #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
70 #define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
73 capture_vm_cont (struct scm_vm
*vp
)
75 struct scm_vm
*p
= scm_gc_malloc (sizeof (*p
), "capture_vm_cont");
76 p
->stack_size
= vp
->stack_limit
- vp
->sp
;
77 p
->stack_base
= scm_gc_malloc (p
->stack_size
* sizeof (SCM
),
79 p
->stack_limit
= p
->stack_base
+ p
->stack_size
- 2;
81 p
->sp
= (SCM
*) (vp
->stack_limit
- vp
->sp
);
82 p
->fp
= (SCM
*) (vp
->stack_limit
- vp
->fp
);
83 memcpy (p
->stack_base
, vp
->sp
+ 1, vp
->stack_size
* sizeof (SCM
));
84 SCM_RETURN_NEWSMOB (scm_tc16_vm_cont
, p
);
88 reinstate_vm_cont (struct scm_vm
*vp
, SCM cont
)
90 struct scm_vm
*p
= SCM_VM_CONT_VP (cont
);
91 if (vp
->stack_size
< p
->stack_size
)
93 /* puts ("FIXME: Need to expand"); */
97 vp
->sp
= vp
->stack_limit
- (int) p
->sp
;
98 vp
->fp
= vp
->stack_limit
- (int) p
->fp
;
99 memcpy (vp
->sp
+ 1, p
->stack_base
, p
->stack_size
* sizeof (SCM
));
102 struct vm_unwind_data
111 vm_reset_stack (void *data
)
113 struct vm_unwind_data
*w
= data
;
117 w
->vp
->this_frame
= w
->this_frame
;
121 vm_cont_mark (SCM obj
)
124 struct scm_vm
*vp
= SCM_VM_CONT_VP (obj
);
125 for (p
= vp
->stack_base
; p
<= vp
->stack_limit
; p
++)
132 vm_cont_free (SCM obj
)
134 struct scm_vm
*p
= SCM_VM_CONT_VP (obj
);
136 scm_gc_free (p
->stack_base
, p
->stack_size
* sizeof (SCM
), "stack-base");
137 scm_gc_free (p
, sizeof (struct scm_vm
), "vm");
144 * VM Internal functions
147 SCM_SYMBOL (sym_vm_run
, "vm-run");
148 SCM_SYMBOL (sym_vm_error
, "vm-error");
151 vm_fetch_length (scm_byte_t
*ip
, size_t *lenp
)
153 /* NOTE: format defined in system/vm/conv.scm */
157 else if (*lenp
== 254)
161 *lenp
= (b1
<< 8) + b2
;
169 *lenp
= (b1
<< 24) + (b2
<< 16) + (b3
<< 8) + b4
;
175 vm_heapify_frames_1 (struct scm_vm
*vp
, SCM
*fp
, SCM
*sp
, SCM
**destp
)
178 SCM
*dl
= SCM_FRAME_DYNAMIC_LINK (fp
);
180 SCM
*src
= SCM_FRAME_UPPER_ADDRESS (fp
);
182 SCM
*dest
= SCM_FRAME_LOWER_ADDRESS (fp
);
187 frame
= scm_c_make_heap_frame (fp
);
188 fp
= SCM_HEAP_FRAME_POINTER (frame
);
189 SCM_FRAME_HEAP_LINK (fp
) = SCM_BOOL_T
;
194 SCM link
= SCM_FRAME_HEAP_LINK (dl
);
195 if (!SCM_FALSEP (link
))
196 link
= SCM_FRAME_LOWER_ADDRESS (dl
)[-1]; /* self link */
198 link
= vm_heapify_frames_1 (vp
, dl
, dest
- 1, &dest
);
199 frame
= scm_c_make_heap_frame (fp
);
200 fp
= SCM_HEAP_FRAME_POINTER (frame
);
201 SCM_FRAME_HEAP_LINK (fp
) = link
;
202 SCM_FRAME_SET_DYNAMIC_LINK (fp
, SCM_HEAP_FRAME_POINTER (link
));
205 /* Apparently the intention here is to be able to have a frame on the heap,
206 but data on the stack, so that you can push as much as you want on the
207 stack; but I think that it's currently causing borkage with nonlocal exits
208 and the unwind handler, which reinstates the sp and fp, but it's no longer
209 pointing at a valid stack frame. So disable for now, we'll get back to
212 /* Move stack data */
213 for (; src
<= sp
; src
++, dest
++)
222 vm_heapify_frames (SCM vm
)
224 struct scm_vm
*vp
= SCM_VM_DATA (vm
);
225 if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp
->fp
)))
228 vp
->this_frame
= vm_heapify_frames_1 (vp
, vp
->fp
, vp
->sp
, &dest
);
229 vp
->fp
= SCM_HEAP_FRAME_POINTER (vp
->this_frame
);
232 return vp
->this_frame
;
240 #define VM_DEFAULT_STACK_SIZE (16 * 1024)
242 #define VM_REGULAR_ENGINE 0
243 #define VM_DEBUG_ENGINE 1
246 #define VM_NAME vm_regular_engine
247 #define VM_ENGINE VM_REGULAR_ENGINE
248 #include "vm-engine.c"
253 #define VM_NAME vm_debug_engine
254 #define VM_ENGINE VM_DEBUG_ENGINE
255 #include "vm-engine.c"
259 scm_t_bits scm_tc16_vm
;
265 #define FUNC_NAME "make_vm"
268 struct scm_vm
*vp
= scm_gc_malloc (sizeof (struct scm_vm
), "vm");
270 vp
->stack_size
= VM_DEFAULT_STACK_SIZE
;
271 vp
->stack_base
= scm_gc_malloc (vp
->stack_size
* sizeof (SCM
),
273 vp
->stack_limit
= vp
->stack_base
+ vp
->stack_size
- 3;
275 vp
->sp
= vp
->stack_base
- 1;
279 vp
->options
= SCM_EOL
;
280 vp
->this_frame
= SCM_BOOL_F
;
281 vp
->last_frame
= SCM_BOOL_F
;
283 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
284 vp
->hooks
[i
] = SCM_BOOL_F
;
285 SCM_RETURN_NEWSMOB (scm_tc16_vm
, vp
);
293 struct scm_vm
*vp
= SCM_VM_DATA (obj
);
295 /* mark the stack conservatively */
296 scm_mark_locations ((SCM_STACKITEM
*) vp
->stack_base
,
297 sizeof (SCM
) * (vp
->sp
- vp
->stack_base
+ 1));
299 /* mark other objects */
300 for (i
= 0; i
< SCM_VM_NUM_HOOKS
; i
++)
301 scm_gc_mark (vp
->hooks
[i
]);
302 scm_gc_mark (vp
->this_frame
);
303 scm_gc_mark (vp
->last_frame
);
310 struct scm_vm
*vp
= SCM_VM_DATA (obj
);
312 scm_gc_free (vp
->stack_base
, vp
->stack_size
* sizeof (SCM
),
314 scm_gc_free (vp
, sizeof (struct scm_vm
), "vm");
319 SCM_SYMBOL (sym_debug
, "debug");
322 scm_vm_apply (SCM vm
, SCM program
, SCM args
)
323 #define FUNC_NAME "scm_vm_apply"
325 SCM_VALIDATE_PROGRAM (1, program
);
326 return vm_run (vm
, program
, args
);
330 /* Scheme interface */
332 SCM_DEFINE (scm_vm_version
, "vm-version", 0, 0, 0,
335 #define FUNC_NAME s_scm_vm_version
337 return scm_from_locale_string (PACKAGE_VERSION
);
341 SCM_DEFINE (scm_the_vm
, "the-vm", 0, 0, 0,
344 #define FUNC_NAME s_scm_the_vm
351 SCM_DEFINE (scm_vm_p
, "vm?", 1, 0, 0,
354 #define FUNC_NAME s_scm_vm_p
356 return SCM_BOOL (SCM_VM_P (obj
));
360 SCM_DEFINE (scm_make_vm
, "make-vm", 0, 0, 0,
363 #define FUNC_NAME s_scm_make_vm,
369 SCM_DEFINE (scm_vm_ip
, "vm:ip", 1, 0, 0,
372 #define FUNC_NAME s_scm_vm_ip
374 SCM_VALIDATE_VM (1, vm
);
375 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm
)->ip
);
379 SCM_DEFINE (scm_vm_sp
, "vm:sp", 1, 0, 0,
382 #define FUNC_NAME s_scm_vm_sp
384 SCM_VALIDATE_VM (1, vm
);
385 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm
)->sp
);
389 SCM_DEFINE (scm_vm_fp
, "vm:fp", 1, 0, 0,
392 #define FUNC_NAME s_scm_vm_fp
394 SCM_VALIDATE_VM (1, vm
);
395 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm
)->fp
);
399 #define VM_DEFINE_HOOK(n) \
402 SCM_VALIDATE_VM (1, vm); \
403 vp = SCM_VM_DATA (vm); \
404 if (SCM_FALSEP (vp->hooks[n])) \
405 vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
406 return vp->hooks[n]; \
409 SCM_DEFINE (scm_vm_boot_hook
, "vm-boot-hook", 1, 0, 0,
412 #define FUNC_NAME s_scm_vm_boot_hook
414 VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK
);
418 SCM_DEFINE (scm_vm_halt_hook
, "vm-halt-hook", 1, 0, 0,
421 #define FUNC_NAME s_scm_vm_halt_hook
423 VM_DEFINE_HOOK (SCM_VM_HALT_HOOK
);
427 SCM_DEFINE (scm_vm_next_hook
, "vm-next-hook", 1, 0, 0,
430 #define FUNC_NAME s_scm_vm_next_hook
432 VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK
);
436 SCM_DEFINE (scm_vm_break_hook
, "vm-break-hook", 1, 0, 0,
439 #define FUNC_NAME s_scm_vm_break_hook
441 VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK
);
445 SCM_DEFINE (scm_vm_enter_hook
, "vm-enter-hook", 1, 0, 0,
448 #define FUNC_NAME s_scm_vm_enter_hook
450 VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK
);
454 SCM_DEFINE (scm_vm_apply_hook
, "vm-apply-hook", 1, 0, 0,
457 #define FUNC_NAME s_scm_vm_apply_hook
459 VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK
);
463 SCM_DEFINE (scm_vm_exit_hook
, "vm-exit-hook", 1, 0, 0,
466 #define FUNC_NAME s_scm_vm_exit_hook
468 VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK
);
472 SCM_DEFINE (scm_vm_return_hook
, "vm-return-hook", 1, 0, 0,
475 #define FUNC_NAME s_scm_vm_return_hook
477 VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK
);
481 SCM_DEFINE (scm_vm_option
, "vm-option", 2, 0, 0,
484 #define FUNC_NAME s_scm_vm_option
486 SCM_VALIDATE_VM (1, vm
);
487 return scm_assq_ref (SCM_VM_DATA (vm
)->options
, key
);
491 SCM_DEFINE (scm_set_vm_option_x
, "set-vm-option!", 3, 0, 0,
492 (SCM vm
, SCM key
, SCM val
),
494 #define FUNC_NAME s_scm_set_vm_option_x
496 SCM_VALIDATE_VM (1, vm
);
497 SCM_VM_DATA (vm
)->options
498 = scm_assq_set_x (SCM_VM_DATA (vm
)->options
, key
, val
);
499 return SCM_UNSPECIFIED
;
503 SCM_DEFINE (scm_vm_stats
, "vm-stats", 1, 0, 0,
506 #define FUNC_NAME s_scm_vm_stats
510 SCM_VALIDATE_VM (1, vm
);
512 stats
= scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED
);
513 scm_vector_set_x (stats
, SCM_I_MAKINUM (0),
514 scm_from_ulong (SCM_VM_DATA (vm
)->time
));
515 scm_vector_set_x (stats
, SCM_I_MAKINUM (1),
516 scm_from_ulong (SCM_VM_DATA (vm
)->clock
));
522 #define VM_CHECK_RUNNING(vm) \
523 if (!SCM_VM_DATA (vm)->ip) \
524 SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
526 SCM_DEFINE (scm_vm_this_frame
, "vm-this-frame", 1, 0, 0,
529 #define FUNC_NAME s_scm_vm_this_frame
531 SCM_VALIDATE_VM (1, vm
);
532 return SCM_VM_DATA (vm
)->this_frame
;
536 SCM_DEFINE (scm_vm_last_frame
, "vm-last-frame", 1, 0, 0,
539 #define FUNC_NAME s_scm_vm_last_frame
541 SCM_VALIDATE_VM (1, vm
);
542 return SCM_VM_DATA (vm
)->last_frame
;
546 SCM_DEFINE (scm_vm_last_ip
, "vm:last-ip", 1, 0, 0,
549 #define FUNC_NAME s_scm_vm_last_ip
551 SCM_VALIDATE_VM (1, vm
);
552 return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm
)->last_ip
);
556 SCM_DEFINE (scm_vm_save_stack
, "vm-save-stack", 1, 0, 0,
559 #define FUNC_NAME s_scm_vm_save_stack
563 SCM_VALIDATE_VM (1, vm
);
564 vp
= SCM_VM_DATA (vm
);
568 vp
->last_frame
= vm_heapify_frames_1 (vp
, vp
->fp
, vp
->sp
, &dest
);
569 vp
->last_ip
= vp
->ip
;
573 vp
->last_frame
= SCM_BOOL_F
;
577 return vp
->last_frame
;
581 SCM_DEFINE (scm_vm_fetch_code
, "vm-fetch-code", 1, 0, 0,
584 #define FUNC_NAME s_scm_vm_fetch_code
589 struct scm_instruction
*p
;
591 SCM_VALIDATE_VM (1, vm
);
592 VM_CHECK_RUNNING (vm
);
594 ip
= SCM_VM_DATA (vm
)->ip
;
595 p
= SCM_INSTRUCTION (*ip
);
597 list
= SCM_LIST1 (scm_str2symbol (p
->name
));
598 for (i
= 1; i
<= p
->len
; i
++)
599 list
= scm_cons (SCM_I_MAKINUM (ip
[i
]), list
);
600 return scm_reverse_x (list
, SCM_EOL
);
604 SCM_DEFINE (scm_vm_fetch_stack
, "vm-fetch-stack", 1, 0, 0,
607 #define FUNC_NAME s_scm_vm_fetch_stack
613 SCM_VALIDATE_VM (1, vm
);
614 VM_CHECK_RUNNING (vm
);
616 vp
= SCM_VM_DATA (vm
);
617 for (sp
= vp
->stack_base
; sp
<= vp
->sp
; sp
++)
618 ls
= scm_cons (*sp
, ls
);
628 SCM
scm_load_compiled_with_vm (SCM file
)
630 SCM program
= scm_objcode_to_program (scm_load_objcode (file
));
632 return vm_run (the_vm
, program
, SCM_EOL
);
636 scm_bootstrap_vm (void)
638 static int strappage
= 0;
643 scm_bootstrap_frames ();
644 scm_bootstrap_instructions ();
645 scm_bootstrap_objcodes ();
646 scm_bootstrap_programs ();
648 scm_tc16_vm_cont
= scm_make_smob_type ("vm-cont", 0);
649 scm_set_smob_mark (scm_tc16_vm_cont
, vm_cont_mark
);
650 scm_set_smob_free (scm_tc16_vm_cont
, vm_cont_free
);
652 scm_tc16_vm
= scm_make_smob_type ("vm", 0);
653 scm_set_smob_mark (scm_tc16_vm
, vm_mark
);
654 scm_set_smob_free (scm_tc16_vm
, vm_free
);
655 scm_set_smob_apply (scm_tc16_vm
, scm_vm_apply
, 1, 0, 1);
657 the_vm
= scm_permanent_object (make_vm ());
659 scm_c_define ("load-compiled",
660 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
661 scm_load_compiled_with_vm
));
671 #ifndef SCM_MAGIC_SNARFER