mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

refactor vm application of non-programs; boot continuation refactor

Browse source 
* libguile/frames.c (scm_frame_instruction_pointer):
* module/system/vm/frame.scm (frame-bindings):
  (frame-next-source, frame-call-representation): Fix a few locations
  that thought that the frame-procedure will always be a VM
  procedure.  This will not not be the case when traversing the stack of
  an application of a non-procedure.

* libguile/vm-i-system.c (call, tail-call, mv-call): Instead of
  special-casing structs and smobs at these call sites, just set up the
  stack, and jump to a generic apply loop if the proc is not a program.

* libguile/vm-engine.c: The generic apply loop is here.  Also, the boot
  program is now simply a boot continuation, and can handle any number
  of arguments.

* libguile/vm.c (make_boot_program): Update the code that makes the boot
  continuation.
This commit is contained in:
Andy Wingo 2012-05-10 12:43:33 +02:00
parent 0eba699d12
commit 67b699cc77
5 changed files with 139 additions and 197 deletions
Download patch file Download diff file Expand all files Collapse all files

7
libguile/frames.c
View file

@ -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)));
}

70
libguile/vm-engine.c
View file

@ -86,31 +86,55 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
jump_table = jump_table_pointer;
#endif
/* Initialization */
{
SCM prog = program;
/* 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));
/* Boot program */
program = vm_make_boot_program (nargs);
/* 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++);
/* 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++);
}
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;

145
libguile/vm-i-system.c
View file

@ -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;
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 ();
program = fp[-1];
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);
}
}
goto apply;
CACHE_PROGRAM ();
{
SCM *old_fp = fp;
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);
}
ip = SCM_C_OBJCODE_BASE (bp);
PUSH_CONTINUATION_HOOK ();
APPLY_HOOK ();
NEXT;
}

95
libguile/vm.c
View file

@ -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 (),

19
module/system/vm/frame.scm
View file

@ -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)