@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.
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}.
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.
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
#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
{
}
#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
{
}
#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
{
}
#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
{
}
#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
{
}
#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
{
}
#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
}
}
-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
}
#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
#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
(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
;; 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
(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))
(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.
(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))
(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)
;; 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))))
(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)
(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)))
(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.
;;
(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
;;
(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
(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?
(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.
;; 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))
(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))
(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)))))
(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))))))))
;; 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
HCoop / bpt / guile.git / commitdiff