mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
VM accessors take VM as implicit argument, not explicit argument
* libguile/vm.h: * libguile/vm.c: (scm_vm_apply_hook, scm_vm_push_continuation_hook, scm_vm_pop_continuation_hook, scm_vm_abort_continuation_hook, scm_vm_restore_continuation_hook, scm_vm_next_hook, scm_vm_trace_level, scm_set_vm_trace_level_x, scm_vm_engine, scm_set_vm_engine_x, scm_c_set_vm_engine_x): The VM argument is now implicit: the VM for the current thread. * doc/ref/api-debug.texi (VM Hooks): Try to adapt. * module/ice-9/command-line.scm: * module/statprof.scm: * module/system/vm/coverage.scm: * module/system/vm/trace.scm: * module/system/vm/trap-state.scm: * module/system/vm/traps.scm: * test-suite/tests/control.test: * test-suite/tests/eval.test: Adapt users that set hooks or ensure that we have a debug engine.
This commit is contained in:
Andy Wingo
parent
6b4ba76d05
commit
972275eee5
11 changed files with 107 additions and 164 deletions
|
|
@ -816,28 +816,28 @@ The interface to hooks is provided by the @code{(system vm vm)} module:
|
|||
@end example
|
||||
|
||||
@noindent
|
||||
The result of calling @code{the-vm} is usually passed as the @var{vm}
|
||||
argument to all of these procedures.
|
||||
All of these functions implicitly act on the VM for the current thread
|
||||
only.
|
||||
|
||||
@deffn {Scheme Procedure} vm-next-hook vm
|
||||
@deffn {Scheme Procedure} vm-next-hook
|
||||
The hook that will be fired before an instruction is retired (and
|
||||
executed).
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} vm-push-continuation-hook vm
|
||||
@deffn {Scheme Procedure} vm-push-continuation-hook
|
||||
The hook that will be fired after preparing a new frame. Fires just
|
||||
before applying a procedure in a non-tail context, just before the
|
||||
corresponding apply-hook.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} vm-pop-continuation-hook vm
|
||||
@deffn {Scheme Procedure} vm-pop-continuation-hook
|
||||
The hook that will be fired before returning from a frame.
|
||||
|
||||
This hook fires with a variable number of arguments, corresponding to
|
||||
the values that the frame returns to its continuation.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} vm-apply-hook vm
|
||||
@deffn {Scheme Procedure} vm-apply-hook
|
||||
The hook that will be fired before a procedure is applied. The frame's
|
||||
procedure will have already been set to the new procedure.
|
||||
|
||||
|
|
@ -848,7 +848,7 @@ whereas a tail call will run without having fired a push-continuation
|
|||
hook.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} vm-abort-continuation-hook vm
|
||||
@deffn {Scheme Procedure} vm-abort-continuation-hook
|
||||
The hook that will be called after aborting to a
|
||||
prompt. @xref{Prompts}.
|
||||
|
||||
|
|
@ -857,7 +857,7 @@ of arguments, corresponding to the values that returned to the
|
|||
continuation.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} vm-restore-continuation-hook vm
|
||||
@deffn {Scheme Procedure} vm-restore-continuation-hook
|
||||
The hook that will be called after restoring an undelimited
|
||||
continuation. Unfortunately it's not currently possible to introspect on
|
||||
the values that were given to the continuation.
|
||||
|
|
@ -875,12 +875,12 @@ level temporarily set to 0. That way the hooks don't fire while you're
|
|||
handling a hook. The trace level is restored to whatever it was once the hook
|
||||
procedure finishes.
|
||||
|
||||
@deffn {Scheme Procedure} vm-trace-level vm
|
||||
@deffn {Scheme Procedure} vm-trace-level
|
||||
Retrieve the ``trace level'' of the VM. If positive, the trace hooks
|
||||
associated with @var{vm} will be run. The initial trace level is 0.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} set-vm-trace-level! vm level
|
||||
@deffn {Scheme Procedure} set-vm-trace-level! level
|
||||
Set the ``trace level'' of the VM.
|
||||
@end deffn
|
||||
|
||||
|
|
|
|||
120
libguile/vm.c
120
libguile/vm.c
|
|
@ -859,15 +859,14 @@ SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
|
|||
#define VM_DEFINE_HOOK(n) \
|
||||
{ \
|
||||
struct scm_vm *vp; \
|
||||
SCM_VALIDATE_VM (1, vm); \
|
||||
vp = SCM_VM_DATA (vm); \
|
||||
vp = SCM_VM_DATA (scm_the_vm ()); \
|
||||
if (scm_is_false (vp->hooks[n])) \
|
||||
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
|
||||
return vp->hooks[n]; \
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_apply_hook
|
||||
{
|
||||
|
|
@ -875,8 +874,8 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_push_continuation_hook
|
||||
{
|
||||
|
|
@ -884,8 +883,8 @@ SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_pop_continuation_hook
|
||||
{
|
||||
|
|
@ -893,8 +892,8 @@ SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_next_hook
|
||||
{
|
||||
|
|
@ -902,8 +901,8 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_abort_continuation_hook
|
||||
{
|
||||
|
|
@ -911,8 +910,8 @@ SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_restore_continuation_hook
|
||||
{
|
||||
|
|
@ -920,23 +919,21 @@ SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_trace_level
|
||||
{
|
||||
SCM_VALIDATE_VM (1, vm);
|
||||
return scm_from_int (SCM_VM_DATA (vm)->trace_level);
|
||||
return scm_from_int (SCM_VM_DATA (scm_the_vm ())->trace_level);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
|
||||
(SCM vm, SCM level),
|
||||
SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
|
||||
(SCM level),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_set_vm_trace_level_x
|
||||
{
|
||||
SCM_VALIDATE_VM (1, vm);
|
||||
SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
|
||||
SCM_VM_DATA (scm_the_vm ())->trace_level = scm_to_int (level);
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -973,36 +970,33 @@ vm_engine_to_symbol (int engine, const char *FUNC_NAME)
|
|||
}
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
|
||||
(SCM vm),
|
||||
SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
|
||||
(void),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_engine
|
||||
{
|
||||
SCM_VALIDATE_VM (1, vm);
|
||||
return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
|
||||
return vm_engine_to_symbol (SCM_VM_DATA (scm_the_vm ())->engine, FUNC_NAME);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
void
|
||||
scm_c_set_vm_engine_x (SCM vm, int engine)
|
||||
scm_c_set_vm_engine_x (int engine)
|
||||
#define FUNC_NAME "set-vm-engine!"
|
||||
{
|
||||
SCM_VALIDATE_VM (1, vm);
|
||||
|
||||
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;
|
||||
SCM_VM_DATA (scm_the_vm ())->engine = engine;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
|
||||
(SCM vm, SCM engine),
|
||||
SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
|
||||
(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));
|
||||
scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
|
@ -1029,63 +1023,15 @@ SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0,
|
|||
}
|
||||
#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),
|
||||
/* FIXME: This function makes no sense, but we keep it to make sure we
|
||||
have a way of switching to the debug or regular VM. */
|
||||
SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
|
||||
(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}.")
|
||||
"@var{vm} is the current VM.")
|
||||
#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;
|
||||
return scm_apply_0 (proc, args);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -57,21 +57,21 @@ SCM_API SCM scm_the_vm_fluid;
|
|||
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
|
||||
|
||||
SCM_API SCM scm_the_vm (void);
|
||||
SCM_API SCM scm_call_with_vm (SCM vm, SCM proc, SCM args);
|
||||
SCM_API SCM scm_call_with_vm (SCM proc, SCM args);
|
||||
|
||||
SCM_API SCM scm_vm_p (SCM obj);
|
||||
SCM_API SCM scm_vm_apply_hook (SCM vm);
|
||||
SCM_API SCM scm_vm_push_continuation_hook (SCM vm);
|
||||
SCM_API SCM scm_vm_pop_continuation_hook (SCM vm);
|
||||
SCM_API SCM scm_vm_abort_continuation_hook (SCM vm);
|
||||
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_vm_apply_hook (void);
|
||||
SCM_API SCM scm_vm_push_continuation_hook (void);
|
||||
SCM_API SCM scm_vm_pop_continuation_hook (void);
|
||||
SCM_API SCM scm_vm_abort_continuation_hook (void);
|
||||
SCM_API SCM scm_vm_restore_continuation_hook (void);
|
||||
SCM_API SCM scm_vm_next_hook (void);
|
||||
SCM_API SCM scm_vm_trace_level (void);
|
||||
SCM_API SCM scm_set_vm_trace_level_x (SCM level);
|
||||
SCM_API SCM scm_vm_engine (void);
|
||||
SCM_API SCM scm_set_vm_engine_x (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_vm_engine_x (int engine);
|
||||
SCM_API void scm_c_set_default_vm_engine_x (int engine);
|
||||
|
||||
#define SCM_F_VM_CONT_PARTIAL 0x1
|
||||
|
|
|
|||
|
|
@ -422,7 +422,7 @@ If FILE begins with `-' the -s switch is mandatory.
|
|||
(and interactive? (not turn-off-debugging?)))
|
||||
(begin
|
||||
(set-default-vm-engine! 'debug)
|
||||
(set-vm-engine! (the-vm) 'debug)))
|
||||
(set-vm-engine! 'debug)))
|
||||
|
||||
;; Return this value.
|
||||
`(;; It would be nice not to load up (ice-9 control), but the
|
||||
|
|
|
|||
|
|
@ -295,8 +295,7 @@
|
|||
;; confuse guile wrt re-enabling the trap when
|
||||
;; count-call finishes.
|
||||
(if %count-calls?
|
||||
(set-vm-trace-level! (the-vm)
|
||||
(1- (vm-trace-level (the-vm)))))
|
||||
(set-vm-trace-level! (1- (vm-trace-level))))
|
||||
(accumulate-time stop-time)))
|
||||
|
||||
(setitimer ITIMER_PROF
|
||||
|
|
@ -308,8 +307,7 @@
|
|||
(begin
|
||||
(set! last-start-time (get-internal-run-time))
|
||||
(if %count-calls?
|
||||
(set-vm-trace-level! (the-vm)
|
||||
(1+ (vm-trace-level (the-vm)))))))))
|
||||
(set-vm-trace-level! (1+ (vm-trace-level))))))))
|
||||
|
||||
(set! inside-profiler? #f))
|
||||
|
||||
|
|
@ -357,8 +355,8 @@ than @code{statprof-stop}, @code{#f} otherwise."
|
|||
(car sampling-frequency)
|
||||
(cdr sampling-frequency)))
|
||||
(if %count-calls?
|
||||
(add-hook! (vm-apply-hook (the-vm)) count-call))
|
||||
(set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
|
||||
(add-hook! (vm-apply-hook) count-call))
|
||||
(set-vm-trace-level! (1+ (vm-trace-level)))
|
||||
#t)))
|
||||
|
||||
;; Do not call this from statprof internal functions -- user only.
|
||||
|
|
@ -371,9 +369,9 @@ than @code{statprof-stop}, @code{#f} otherwise."
|
|||
(begin
|
||||
(set! gc-time-taken
|
||||
(- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
|
||||
(set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
|
||||
(set-vm-trace-level! (1- (vm-trace-level)))
|
||||
(if %count-calls?
|
||||
(remove-hook! (vm-apply-hook (the-vm)) count-call))
|
||||
(remove-hook! (vm-apply-hook) count-call))
|
||||
;; I believe that we need to do this before getting the time
|
||||
;; (unless we want to make things even more complicated).
|
||||
(set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
|
||||
|
|
@ -754,7 +752,7 @@ whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
|
|||
(set! last-start-time (get-internal-run-time))
|
||||
(set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
|
||||
(add-hook! after-gc-hook gc-callback)
|
||||
(set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
|
||||
(set-vm-trace-level! (1+ (vm-trace-level)))
|
||||
#t)))
|
||||
|
||||
(define (stop)
|
||||
|
|
|
|||
|
|
@ -69,16 +69,16 @@ coverage data. Return code coverage data and the values returned by THUNK."
|
|||
;; 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)))
|
||||
(let ((level (vm-trace-level))
|
||||
(hook (vm-next-hook)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-vm-trace-level! vm (+ level 1))
|
||||
(set-vm-trace-level! (+ level 1))
|
||||
(add-hook! hook collect!))
|
||||
(lambda ()
|
||||
(call-with-vm vm thunk))
|
||||
(call-with-vm thunk))
|
||||
(lambda ()
|
||||
(set-vm-trace-level! vm level)
|
||||
(set-vm-trace-level! level)
|
||||
(remove-hook! hook collect!)))))
|
||||
(lambda args
|
||||
(apply values (make-coverage-data ip-counts) args))))
|
||||
|
|
|
|||
|
|
@ -114,10 +114,10 @@
|
|||
(set! inst-trap
|
||||
(trace-instructions-in-procedure thunk #:vm vm #:width width
|
||||
#:max-indent max-indent)))
|
||||
(set-vm-trace-level! vm (1+ (vm-trace-level vm))))
|
||||
(set-vm-trace-level! (1+ (vm-trace-level))))
|
||||
thunk
|
||||
(lambda ()
|
||||
(set-vm-trace-level! vm (1- (vm-trace-level vm)))
|
||||
(set-vm-trace-level! (1- (vm-trace-level)))
|
||||
(if call-trap (call-trap))
|
||||
(if inst-trap (inst-trap))
|
||||
(set! call-trap #f)
|
||||
|
|
|
|||
|
|
@ -173,11 +173,11 @@
|
|||
(lambda ()
|
||||
;; Don't enable hooks if the handler is #f.
|
||||
(if handler
|
||||
(set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
|
||||
(set-vm-trace-level! (trap-state->trace-level trap-state))))
|
||||
thunk
|
||||
(lambda ()
|
||||
(if handler
|
||||
(set-vm-trace-level! (the-vm) 0))))))
|
||||
(set-vm-trace-level! 0))))))
|
||||
|
||||
(define* (list-traps #:optional (trap-state (the-trap-state)))
|
||||
(map trap-wrapper-index (trap-state-wrappers trap-state)))
|
||||
|
|
|
|||
|
|
@ -139,9 +139,9 @@
|
|||
(new-enabled-trap
|
||||
vm #f
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook vm) apply-hook))
|
||||
(add-hook! (vm-apply-hook) apply-hook))
|
||||
(lambda (frame)
|
||||
(remove-hook! (vm-apply-hook vm) apply-hook)))))
|
||||
(remove-hook! (vm-apply-hook) apply-hook)))))
|
||||
|
||||
;; A more complicated trap, traps when control enters a procedure.
|
||||
;;
|
||||
|
|
@ -210,21 +210,21 @@
|
|||
(new-enabled-trap
|
||||
vm current-frame
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook vm) apply-hook)
|
||||
(add-hook! (vm-push-continuation-hook vm) push-cont-hook)
|
||||
(add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
|
||||
(add-hook! (vm-abort-continuation-hook vm) abort-hook)
|
||||
(add-hook! (vm-restore-continuation-hook vm) restore-hook)
|
||||
(add-hook! (vm-apply-hook) apply-hook)
|
||||
(add-hook! (vm-push-continuation-hook) push-cont-hook)
|
||||
(add-hook! (vm-pop-continuation-hook) pop-cont-hook)
|
||||
(add-hook! (vm-abort-continuation-hook) abort-hook)
|
||||
(add-hook! (vm-restore-continuation-hook) restore-hook)
|
||||
(if (and frame (our-frame? frame))
|
||||
(enter-proc frame)))
|
||||
(lambda (frame)
|
||||
(if in-proc?
|
||||
(exit-proc frame))
|
||||
(remove-hook! (vm-apply-hook vm) apply-hook)
|
||||
(remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
|
||||
(remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
|
||||
(remove-hook! (vm-abort-continuation-hook vm) abort-hook)
|
||||
(remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
|
||||
(remove-hook! (vm-apply-hook) apply-hook)
|
||||
(remove-hook! (vm-push-continuation-hook) push-cont-hook)
|
||||
(remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
|
||||
(remove-hook! (vm-abort-continuation-hook) abort-hook)
|
||||
(remove-hook! (vm-restore-continuation-hook) restore-hook)))))
|
||||
|
||||
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
|
||||
;;
|
||||
|
|
@ -242,12 +242,12 @@
|
|||
(next-handler frame)))
|
||||
|
||||
(define (enter frame)
|
||||
(add-hook! (vm-next-hook vm) next-hook)
|
||||
(add-hook! (vm-next-hook) next-hook)
|
||||
(if frame (next-hook frame)))
|
||||
|
||||
(define (exit frame)
|
||||
(exit-handler frame)
|
||||
(remove-hook! (vm-next-hook vm) next-hook))
|
||||
(remove-hook! (vm-next-hook) next-hook))
|
||||
|
||||
(trap-in-procedure proc enter exit
|
||||
#:current-frame current-frame #:vm vm
|
||||
|
|
@ -431,14 +431,14 @@
|
|||
(lambda (frame)
|
||||
(if (not fp)
|
||||
(error "return-or-abort traps may only be enabled once"))
|
||||
(add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
|
||||
(add-hook! (vm-abort-continuation-hook vm) abort-hook)
|
||||
(add-hook! (vm-restore-continuation-hook vm) abort-hook))
|
||||
(add-hook! (vm-pop-continuation-hook) pop-cont-hook)
|
||||
(add-hook! (vm-abort-continuation-hook) abort-hook)
|
||||
(add-hook! (vm-restore-continuation-hook) abort-hook))
|
||||
(lambda (frame)
|
||||
(set! fp #f)
|
||||
(remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
|
||||
(remove-hook! (vm-abort-continuation-hook vm) abort-hook)
|
||||
(remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
|
||||
(remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
|
||||
(remove-hook! (vm-abort-continuation-hook) abort-hook)
|
||||
(remove-hook! (vm-restore-continuation-hook) abort-hook)))))
|
||||
|
||||
;; A more traditional dynamic-wind trap. Perhaps this should not be
|
||||
;; based on the above trap-frame-finish?
|
||||
|
|
@ -473,12 +473,12 @@
|
|||
(new-enabled-trap
|
||||
vm current-frame
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-apply-hook vm) apply-hook))
|
||||
(add-hook! (vm-apply-hook) apply-hook))
|
||||
(lambda (frame)
|
||||
(if exit-trap
|
||||
(abort-hook frame))
|
||||
(set! exit-trap #f)
|
||||
(remove-hook! (vm-apply-hook vm) apply-hook)))))
|
||||
(remove-hook! (vm-apply-hook) apply-hook)))))
|
||||
|
||||
;; Trapping all procedure calls within a dynamic extent, recording the
|
||||
;; depth of the call stack relative to the original procedure.
|
||||
|
|
@ -505,14 +505,14 @@
|
|||
;; FIXME: recalc depth on abort
|
||||
|
||||
(define (enter frame)
|
||||
(add-hook! (vm-push-continuation-hook vm) trace-push)
|
||||
(add-hook! (vm-pop-continuation-hook vm) trace-pop)
|
||||
(add-hook! (vm-apply-hook vm) trace-apply))
|
||||
(add-hook! (vm-push-continuation-hook) trace-push)
|
||||
(add-hook! (vm-pop-continuation-hook) trace-pop)
|
||||
(add-hook! (vm-apply-hook) trace-apply))
|
||||
|
||||
(define (leave frame)
|
||||
(remove-hook! (vm-push-continuation-hook vm) trace-push)
|
||||
(remove-hook! (vm-pop-continuation-hook vm) trace-pop)
|
||||
(remove-hook! (vm-apply-hook vm) trace-apply))
|
||||
(remove-hook! (vm-push-continuation-hook) trace-push)
|
||||
(remove-hook! (vm-pop-continuation-hook) trace-pop)
|
||||
(remove-hook! (vm-apply-hook) trace-apply))
|
||||
|
||||
(define (return frame)
|
||||
(leave frame))
|
||||
|
|
@ -538,10 +538,10 @@
|
|||
(next-handler frame))
|
||||
|
||||
(define (enter frame)
|
||||
(add-hook! (vm-next-hook vm) trace-next))
|
||||
(add-hook! (vm-next-hook) trace-next))
|
||||
|
||||
(define (leave frame)
|
||||
(remove-hook! (vm-next-hook vm) trace-next))
|
||||
(remove-hook! (vm-next-hook) trace-next))
|
||||
|
||||
(define (return frame)
|
||||
(leave frame))
|
||||
|
|
@ -629,6 +629,6 @@
|
|||
(new-enabled-trap
|
||||
vm #f
|
||||
(lambda (frame)
|
||||
(add-hook! (vm-next-hook vm) next-hook))
|
||||
(add-hook! (vm-next-hook) next-hook))
|
||||
(lambda (frame)
|
||||
(remove-hook! (vm-next-hook vm) next-hook)))))
|
||||
(remove-hook! (vm-next-hook) next-hook)))))
|
||||
|
|
|
|||
|
|
@ -369,7 +369,7 @@
|
|||
(p x y))))
|
||||
(catch 'foo
|
||||
(lambda ()
|
||||
(call-with-vm (the-vm) (lambda () (throw 'foo (the-vm)))))
|
||||
(call-with-vm (lambda () (throw 'foo (the-vm)))))
|
||||
(lambda (key vm)
|
||||
(and (eq? key 'foo)
|
||||
(eq? vm (the-vm))))))))
|
||||
|
|
|
|||
|
|
@ -437,9 +437,8 @@
|
|||
;; FIXME: this test does not test what it is intending to test
|
||||
(pass-if-exception "exception raised"
|
||||
exception:vm-error
|
||||
(let ((vm (the-vm))
|
||||
(thunk (let loop () (cons 's (loop)))))
|
||||
(call-with-vm vm thunk))))
|
||||
(let ((thunk (let loop () (cons 's (loop)))))
|
||||
(call-with-vm thunk))))
|
||||
|
||||
;;;
|
||||
;;; docstrings
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue