dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add call-with-vm; remove thread-vm bits; remove vm-apply; engines settable.

Browse source 
* libguile/vm.h (scm_c_vm_run): Make internal.
* libguile/vm.c (vm_default_engine): New static global variable.
  (make_vm): Set vp->engine based on
  (scm_vm_apply): Remove in favor of call-with-vm.
  (scm_thread_vm, scm_set_thread_vm_x): Remove these, as they did not
  have a well-defined meaning, and were dangerous to call on other
  threads.
  (scm_the_vm): Reinstate previous definition.
  (symbol_to_vm_engine, vm_engine_to_symbol)
  (vm_has_pending_computation): New helpers.
  (scm_vm_engine, scm_set_vm_engine_x, scm_c_set_vm_engine_x): New
  accessors for VM engines.
  (scm_c_set_default_vm_engine_x, scm_set_default_vm_engine_x): New
  setters for the default VM engine.
  (scm_call_with_vm): New function, applies a procedure to arguments in
  a context in which a given VM is current.

* libguile/eval.c (eval, scm_apply): VM dispatch goes through
  scm_call_with_vm.

* test-suite/tests/control.test ("the-vm"):
* module/system/vm/coverage.scm (with-code-coverage): Use call-with-vm.

* module/system/vm/vm.scm: Update exports.

* test-suite/vm/run-vm-tests.scm (run-vm-program):
* test-suite/tests/compiler.test ("current-reader"): Just rely on the
  result of make-program being an applicable.

* test-suite/tests/eval.test ("stack overflow"): Add a note that this
  test does not test what it should.
This commit is contained in:
Andy Wingo 2010-09-27 21:06:24 +02:00
commit ea9f4f4b15
9 changed files with 205 additions and 110 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/eval.c
View file

@ -287,7 +287,7 @@ eval (SCM x, SCM env)
goto loop;
}
else
return scm_vm_apply (scm_the_vm (), proc, args);
return scm_call_with_vm (scm_the_vm (), proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
@ -322,7 +322,7 @@ eval (SCM x, SCM env)
producer = eval (CAR (mx), env);
proc = eval (CDR (mx), env); /* proc is the consumer. */
v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
@ -824,7 +824,7 @@ scm_apply (SCM proc, SCM arg1, SCM args)
else
args = scm_cons_star (arg1, args);
return scm_vm_apply (scm_the_vm (), proc, args);
return scm_call_with_vm (scm_the_vm (), proc, args);
}
static void

255
libguile/vm.c
View file

@ -36,12 +36,15 @@
#include "programs.h"
#include "vm.h"
/* I sometimes use this for debugging. */
#define vm_puts(OBJ) \
{ \
scm_display (OBJ, scm_current_error_port ()); \
scm_newline (scm_current_error_port ()); \
}
static int vm_default_engine = SCM_VM_DEBUG_ENGINE;
/* Unfortunately we can't snarf these: snarfed things are only loaded up from
(system vm vm), which might not be loaded before an error happens. */
static SCM sym_vm_run;
static SCM sym_vm_error;
static SCM sym_keyword_argument_error;
static SCM sym_regular;
static SCM sym_debug;
/* The VM has a number of internal assertions that shouldn't normally be
necessary, but might be if you think you found a bug in the VM. */
@ -340,10 +343,6 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
* VM Internal functions
*/
/* Unfortunately we can't snarf these: snarfed things are only loaded up from
(system vm vm), which might not be loaded before an error happens. */
static SCM sym_vm_run, sym_vm_error, sym_keyword_argument_error, sym_debug;
void
scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
{
@ -517,7 +516,7 @@ make_vm (void)
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->engine = SCM_VM_DEBUG_ENGINE;
vp->engine = vm_default_engine;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
@ -564,80 +563,19 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
return vm_engines[vp->engine](vm, program, argv, nargs);
}
SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
(SCM vm, SCM program, SCM args),
"")
#define FUNC_NAME s_scm_vm_apply
{
SCM *argv;
int i, nargs;
SCM_VALIDATE_VM (1, vm);
SCM_VALIDATE_PROC (2, program);
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
argv = alloca(nargs * sizeof(SCM));
for (i = 0; i < nargs; i++)
{
argv[i] = SCM_CAR (args);
args = SCM_CDR (args);
}
return scm_c_vm_run (vm, program, argv, nargs);
}
#undef FUNC_NAME
/* Scheme interface */
/* Return T's VM. */
static inline SCM
thread_vm (scm_i_thread *t)
{
if (SCM_UNLIKELY (scm_is_false (t->vm)))
t->vm = make_vm ();
return t->vm;
}
SCM_DEFINE (scm_thread_vm, "thread-vm", 1, 0, 0,
(SCM thread),
"Return @var{thread}'s VM.")
#define FUNC_NAME s_scm_thread_vm
{
SCM_VALIDATE_THREAD (1, thread);
return thread_vm (SCM_I_THREAD_DATA (thread));
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_thread_vm_x, "set-thread-vm!", 2, 0, 0,
(SCM thread, SCM vm),
"Set @var{thread}'s VM to @var{vm}. Warning: Code being\n"
"executed by @var{thread}'s current VM won't automatically\n"
"switch to @var{vm}.")
#define FUNC_NAME s_scm_set_thread_vm_x
{
scm_i_thread *t;
SCM_VALIDATE_THREAD (1, thread);
SCM_VALIDATE_VM (2, vm);
t = SCM_I_THREAD_DATA (thread);
t->vm = vm;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
(void),
"Return the current thread's VM.")
#define FUNC_NAME s_scm_the_vm
{
return thread_vm (SCM_I_CURRENT_THREAD);
scm_i_thread *t = SCM_I_CURRENT_THREAD;
if (SCM_UNLIKELY (scm_is_false (t->vm)))
t->vm = make_vm ();
return t->vm;
}
#undef FUNC_NAME
@ -775,6 +713,166 @@ SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
}
#undef FUNC_NAME
/*
* VM engines
*/
static int
symbol_to_vm_engine (SCM engine, const char *FUNC_NAME)
{
if (scm_is_eq (engine, sym_regular))
return SCM_VM_REGULAR_ENGINE;
else if (scm_is_eq (engine, sym_debug))
return SCM_VM_DEBUG_ENGINE;
else
SCM_MISC_ERROR ("Unknown VM engine: ~a", scm_list_1 (engine));
}
static SCM
vm_engine_to_symbol (int engine, const char *FUNC_NAME)
{
switch (engine)
{
case SCM_VM_REGULAR_ENGINE:
return sym_regular;
case SCM_VM_DEBUG_ENGINE:
return sym_debug;
default:
/* ? */
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
}
}
static int
vm_has_pending_computation (SCM vm)
{
struct scm_vm *vp = SCM_VM_DATA (vm);
return vp->sp >= vp->stack_base;
}
SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
(SCM vm),
"")
#define FUNC_NAME s_scm_vm_engine
{
SCM_VALIDATE_VM (1, vm);
return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
}
#undef FUNC_NAME
void
scm_c_set_vm_engine_x (SCM vm, int engine)
#define FUNC_NAME "set-vm-engine!"
{
SCM_VALIDATE_VM (1, vm);
if (vm_has_pending_computation (vm))
SCM_MISC_ERROR ("VM engine may only be changed while there are no "
"pending computations.",
SCM_EOL);
if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
SCM_VM_DATA (vm)->engine = engine;
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
(SCM vm, SCM engine),
"")
#define FUNC_NAME s_scm_set_vm_engine_x
{
scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
scm_c_set_default_vm_engine_x (int engine)
#define FUNC_NAME "set-default-vm-engine!"
{
if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
vm_default_engine = engine;
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
(SCM engine),
"")
#define FUNC_NAME s_scm_set_default_vm_engine_x
{
scm_c_set_default_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static void reinstate_vm (SCM vm)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
t->vm = vm;
}
SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
(SCM vm, SCM proc, SCM args),
"Apply @var{proc} to @var{args} in a dynamic extent in which\n"
"@var{vm} is the current VM.\n\n"
"As an implementation restriction, if @var{vm} is not the same\n"
"as the current thread's VM, continuations captured within the\n"
"call to @var{proc} may not be reinstated once control leaves\n"
"@var{proc}.")
#define FUNC_NAME s_scm_call_with_vm
{
SCM prev_vm, ret;
SCM *argv;
int i, nargs;
scm_t_wind_flags flags;
scm_i_thread *t = SCM_I_CURRENT_THREAD;
SCM_VALIDATE_VM (1, vm);
SCM_VALIDATE_PROC (2, proc);
nargs = scm_ilength (args);
if (SCM_UNLIKELY (nargs < 0))
scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
argv = alloca (nargs * sizeof(SCM));
for (i = 0; i < nargs; i++)
{
argv[i] = SCM_CAR (args);
args = SCM_CDR (args);
}
prev_vm = t->vm;
/* Reentry can happen via invokation of a saved continuation, but
continuations only save the state of the VM that they are in at
capture-time, which might be different from this one. So, in the
case that the VMs are different, set up a non-rewindable frame to
prevent reinstating an incomplete continuation. */
flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
if (flags)
{
scm_dynwind_begin (0);
scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
t->vm = vm;
}
ret = scm_c_vm_run (vm, proc, argv, nargs);
if (flags)
scm_dynwind_end ();
return ret;
}
#undef FUNC_NAME
/*
* Initialize
@ -798,6 +896,7 @@ scm_bootstrap_vm (void)
sym_vm_run = scm_from_locale_symbol ("vm-run");
sym_vm_error = scm_from_locale_symbol ("vm-error");
sym_keyword_argument_error = scm_from_locale_symbol ("keyword-argument-error");
sym_regular = scm_from_locale_symbol ("regular");
sym_debug = scm_from_locale_symbol ("debug");
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN

13
libguile/vm.h
View file

@ -61,12 +61,10 @@ SCM_API SCM scm_the_vm_fluid;
SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
SCM_API SCM scm_thread_vm (SCM t);
SCM_API SCM scm_set_thread_vm_x (SCM t, SCM vm);
SCM_API SCM scm_the_vm (void);
SCM_API SCM scm_call_with_vm (SCM vm, SCM proc, SCM args);
SCM_API SCM scm_vm_p (SCM obj);
SCM_API SCM scm_vm_ip (SCM vm);
SCM_API SCM scm_vm_sp (SCM vm);
@ -79,6 +77,11 @@ SCM_API SCM scm_vm_restore_continuation_hook (SCM vm);
SCM_API SCM scm_vm_next_hook (SCM vm);
SCM_API SCM scm_vm_trace_level (SCM vm);
SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
SCM_API SCM scm_vm_engine (SCM vm);
SCM_API SCM scm_set_vm_engine_x (SCM vm, SCM engine);
SCM_API SCM scm_set_default_vm_engine_x (SCM engine);
SCM_API void scm_c_set_vm_engine_x (SCM vm, int engine);
SCM_API void scm_c_set_default_vm_engine_x (int engine);
#define SCM_F_VM_CONT_PARTIAL 0x1
#define SCM_F_VM_CONT_REWINDABLE 0x2
@ -100,6 +103,8 @@ struct scm_vm_cont {
SCM_API SCM scm_load_compiled_with_vm (SCM file);
SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);

12
module/system/vm/coverage.scm
View file

@ -84,19 +84,19 @@ coverage data. Return code coverage data and the values returned by THUNK."
(set-cdr! proc-entry (make-hash-table))
(loop))))))
;; FIXME: It's unclear what the dynamic-wind is for, given that if the
;; VM is different from the current one, continuations will not be
;; resumable.
(call-with-values (lambda ()
(let ((level (vm-trace-level vm))
(hook (vm-next-hook vm))
(prev-vm (thread-vm (current-thread))))
(hook (vm-next-hook vm)))
(dynamic-wind
(lambda ()
(set-vm-trace-level! vm (+ level 1))
(add-hook! hook collect!)
(set-thread-vm! (current-thread) vm))
(add-hook! hook collect!))
(lambda ()
(vm-apply vm thunk '()))
(call-with-vm vm thunk))
(lambda ()
(set-thread-vm! (current-thread) prev-vm)
(set-vm-trace-level! vm level)
(remove-hook! hook collect!)))))
(lambda args

9
module/system/vm/vm.scm
View file

@ -19,13 +19,12 @@
;;; Code:
(define-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
#:export (vm? make-vm vm-version vm-apply
the-vm thread-vm set-thread-vm!
vm:ip vm:sp vm:fp vm:last-ip
#:export (vm?
make-vm the-vm call-with-vm
vm:ip vm:sp vm:fp
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook
vm-apply-hook
vm-next-hook

3
test-suite/tests/compiler.test
View file

@ -19,7 +19,6 @@
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
#:use-module ((system vm vm) #:select (the-vm vm-apply))
#:use-module ((system vm program) #:select (make-program
program-sources source:addr)))
@ -98,7 +97,7 @@
#f)
(install-reader!)
this-should-be-ignored")))
(and (eq? (vm-apply (the-vm) (make-program (read-and-compile input)) '())
(and (eq? ((make-program (read-and-compile input)))
'ok)
(eq? r (fluid-ref current-reader)))))

10
test-suite/tests/control.test
View file

@ -238,15 +238,7 @@
(p x y))))
(catch 'foo
(lambda ()
(dynamic-wind
(lambda ()
(set-thread-vm! (current-thread) new-vm))
(lambda ()
(vm-apply new-vm
(lambda () (throw 'foo (the-vm)))
'()))
(lambda ()
(set-thread-vm! (current-thread) prev-vm))))
(call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
(lambda (key vm)
(and (eq? key 'foo)
(eq? vm new-vm)

5
test-suite/tests/eval.test
View file

@ -18,7 +18,7 @@
(define-module (test-suite test-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
:use-module ((system vm vm) :select (make-vm vm-apply))
:use-module ((system vm vm) :select (make-vm call-with-vm))
:use-module (ice-9 documentation))
@ -439,10 +439,11 @@
(with-test-prefix "stack overflow"
;; FIXME: this test does not test what it is intending to test
(pass-if-exception "exception raised"
exception:vm-error
(let ((vm (make-vm))
(thunk (let loop () (cons 's (loop)))))
(vm-apply vm thunk))))
(call-with-vm vm thunk))))
;;; eval.test ends here

2
test-suite/vm/run-vm-tests.scm
View file

@ -42,7 +42,7 @@
(define (run-vm-program objcode)
"Run VM program contained into @var{objcode}."
(vm-apply (the-vm) (make-program objcode) '()))
((make-program objcode)))
(define (compile/run-test-from-file file)
"Run test from source file @var{file} and return a value indicating whether