summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/frames.c7
-rw-r--r--libguile/vm-engine.c74
-rw-r--r--libguile/vm-i-system.c145
-rw-r--r--libguile/vm.c95
-rw-r--r--module/system/vm/frame.scm19
5 files changed, 141 insertions, 199 deletions
diff --git a/libguile/frames.c b/libguile/frames.c
index c7505b262..45f1c8d92 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -237,11 +237,16 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_instruction_pointer
{
+ SCM program;
const struct scm_objcode *c_objcode;
SCM_VALIDATE_VM_FRAME (1, frame);
+ program = scm_frame_procedure (frame);
- c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
+ if (!SCM_PROGRAM_P (program))
+ return SCM_INUM0;
+
+ c_objcode = SCM_PROGRAM_DATA (program);
return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
- SCM_C_OBJCODE_BASE (c_objcode)));
}
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 67d606201..12e62d52d 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -86,31 +86,55 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
jump_table = jump_table_pointer;
#endif
- /* Initialization */
- {
- SCM prog = program;
-
- /* Boot program */
- program = vm_make_boot_program (nargs);
-
- /* Initial frame */
- CACHE_REGISTER ();
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- CACHE_PROGRAM ();
- PUSH (program);
- fp = sp + 1;
- ip = SCM_C_OBJCODE_BASE (bp);
- /* MV-call frame, function & arguments */
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- PUSH (prog);
- VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
- while (nargs--)
- PUSH (*argv++);
- }
+ /* Initial frame */
+ CACHE_REGISTER ();
+ PUSH (SCM_PACK (fp)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (ip)); /* ra */
+ PUSH (boot_continuation);
+ fp = sp + 1;
+ ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
+
+ /* MV-call frame, function & arguments */
+ PUSH (SCM_PACK (fp)); /* dynamic link */
+ PUSH (SCM_PACK (ip + 1)); /* mvra */
+ PUSH (SCM_PACK (ip)); /* ra */
+ PUSH (program);
+ fp = sp + 1;
+ VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
+ while (nargs--)
+ PUSH (*argv++);
+
+ PUSH_CONTINUATION_HOOK ();
+
+ apply:
+ program = fp[-1];
+ if (!SCM_PROGRAM_P (program))
+ {
+ if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
+ fp[-1] = SCM_STRUCT_PROCEDURE (program);
+ else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ && SCM_SMOB_APPLICABLE_P (program))
+ {
+ /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
+ int i;
+ PUSH (SCM_BOOL_F);
+ for (i = sp - fp; i >= 0; i--)
+ fp[i] = fp[i - 1];
+ fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline_objcode;
+ }
+ else
+ {
+ SYNC_ALL();
+ vm_error_wrong_type_apply (program);
+ }
+ goto apply;
+ }
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
+ APPLY_HOOK ();
/* Let's go! */
NEXT;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index b8c18f077..5c808a08b 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -764,33 +764,8 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
nargs = FETCH ();
vm_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- PUSH (program);
- prepare_smob_call (sp, ++nargs, program);
- goto vm_call;
- }
- else
- {
- SYNC_ALL();
- vm_error_wrong_type_apply (program);
- }
- }
-
- CACHE_PROGRAM ();
-
{
SCM *old_fp = fp;
@@ -804,8 +779,16 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
}
- ip = SCM_C_OBJCODE_BASE (bp);
PUSH_CONTINUATION_HOOK ();
+
+ program = fp[-1];
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
APPLY_HOOK ();
NEXT;
}
@@ -815,53 +798,34 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
nargs = FETCH ();
vm_tail_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_tail_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- PUSH (program);
- prepare_smob_call (sp, ++nargs, program);
- goto vm_tail_call;
- }
- else
- {
- SYNC_ALL();
- vm_error_wrong_type_apply (program);
- }
- }
- else
- {
- int i;
+ {
+ int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
- CHECK_STACK_LEAK ();
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
- /* switch programs */
- CACHE_PROGRAM ();
- /* shuffle down the program and the arguments */
- for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
- SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- sp = fp + i - 1;
+ sp = fp + i - 1;
- NULLSTACK (old_sp - sp);
+ NULLSTACK (old_sp - sp);
+ }
- ip = SCM_C_OBJCODE_BASE (bp);
+ program = fp[-1];
- APPLY_HOOK ();
- NEXT;
- }
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
+ APPLY_HOOK ();
+ NEXT;
}
VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
@@ -1071,54 +1035,33 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
+ SCM *old_fp = fp;
nargs = FETCH ();
FETCH_OFFSET (offset);
mvra = ip + offset;
- vm_mv_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_mv_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- PUSH (program);
- prepare_smob_call (sp, ++nargs, program);
- goto vm_mv_call;
- }
- else
- {
- SYNC_ALL();
- vm_error_wrong_type_apply (program);
- }
- }
+ fp = sp - nargs + 1;
+
+ ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+
+ PUSH_CONTINUATION_HOOK ();
- CACHE_PROGRAM ();
+ program = fp[-1];
- {
- SCM *old_fp = fp;
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- }
-
+ CACHE_PROGRAM ();
ip = SCM_C_OBJCODE_BASE (bp);
- PUSH_CONTINUATION_HOOK ();
+
APPLY_HOOK ();
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 781175cbc..affec0586 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -597,78 +597,14 @@ vm_error_free_variable ()
#endif
-static SCM
-really_make_boot_program (long nargs)
-{
- SCM u8vec;
- scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
- scm_op_make_int8_1, scm_op_halt };
- struct scm_objcode *bp;
- SCM ret;
-
- if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
- scm_misc_error ("vm-engine", "too many args when making boot procedure",
- scm_list_1 (scm_from_long (nargs)));
-
- text[1] = (scm_t_uint8)nargs;
-
- bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
- "boot-program");
- memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
- bp->len = sizeof(text);
- bp->metalen = 0;
- u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
- ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
- SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
-
- return ret;
-}
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
-{
- static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
-
- if (SCM_UNLIKELY (scm_is_false (programs[0])))
- {
- int i;
- for (i = 0; i < NUM_BOOT_PROGS; i++)
- programs[i] = really_make_boot_program (i);
- }
-
- if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
- return programs[nargs];
- else
- return really_make_boot_program (nargs);
-}
+static SCM boot_continuation;
/*
* VM
*/
-/* We are calling a SMOB. The calling code pushed the SMOB after the
- args, and incremented nargs. That nargs is passed here. This
- function's job is to replace the procedure with the trampoline, and
- shuffle the smob itself to be argument 0. This function must not
- allocate or throw, as the VM registers are not synchronized. */
-static void
-prepare_smob_call (SCM *sp, int nargs, SCM smob)
-{
- SCM *args = sp - nargs + 1;
-
- /* Shuffle args up. */
- while (nargs--)
- args[nargs + 1] = args[nargs];
-
- args[0] = smob;
- /* apply_trampoline_objcode is actually a program. */
- args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode;
-}
-
static SCM
resolve_variable (SCM what, SCM program_module)
{
@@ -1124,6 +1060,33 @@ SCM scm_load_compiled_with_vm (SCM file)
return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
}
+
+static SCM
+make_boot_program (void)
+{
+ struct scm_objcode *bp;
+ size_t bp_size;
+ SCM u8vec, ret;
+
+ const scm_t_uint8 text[] = {
+ scm_op_make_int8_1,
+ scm_op_halt
+ };
+
+ bp_size = sizeof (struct scm_objcode) + sizeof (text);
+ bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
+ memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
+ bp->len = sizeof(text);
+ bp->metalen = 0;
+
+ u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size);
+ ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
+ SCM_BOOL_F, SCM_BOOL_F);
+ SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
+
+ return ret;
+}
+
void
scm_bootstrap_vm (void)
{
@@ -1137,6 +1100,8 @@ scm_bootstrap_vm (void)
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
+ boot_continuation = make_boot_program ();
+
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
GC_new_kind (GC_new_free_list (),
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 37f621b90..f2ceae598 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -32,8 +32,10 @@
frame-return-values))
(define (frame-bindings frame)
- (program-bindings-for-ip (frame-procedure frame)
- (frame-instruction-pointer frame)))
+ (let ((p (frame-procedure frame)))
+ (if (program? p)
+ (program-bindings-for-ip p (frame-instruction-pointer frame))
+ '())))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
@@ -72,9 +74,11 @@
(define (frame-next-source frame)
(let ((proc (frame-procedure frame)))
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources-pre-retire proc))))
+ (if (program? proc)
+ (program-source proc
+ (frame-instruction-pointer frame)
+ (program-sources-pre-retire proc))
+ '())))
;; Basically there are two cases to deal with here:
@@ -97,7 +101,8 @@
(cons
(or (procedure-name p) p)
(cond
- ((program-arguments-alist p (frame-instruction-pointer frame))
+ ((and (program? p)
+ (program-arguments-alist p (frame-instruction-pointer frame)))
;; case 1
=> (lambda (arguments)
(define (binding-ref sym i)