diff options
-rw-r--r-- | libguile/frames.c | 7 | ||||
-rw-r--r-- | libguile/vm-engine.c | 74 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 145 | ||||
-rw-r--r-- | libguile/vm.c | 95 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 19 |
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) |