mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

VM manages hook sets itself

Browse source 
* libguile/vm.h (SCM_VM_ABORT_HOOK): Rename from
  SCM_VM_ABORT_CONTINUATION_HOOK.
* libguile/vm-engine.c (ABORT_HOOK):
* libguile/vm.c (invoke_abort_hook): Adapt to SCM_VM_ABORT_HOOK name
change.
(reset_vm_hook_enabled): New helper.
(VM_ADD_HOOK, VM_REMOVE_HOOK): New helper macros, replacing
VM_DEFINE_HOOK.
(scm_vm_add_abort_hook_x, scm_vm_remove_abort_hook_x)
(scm_vm_add_apply_hook_x, scm_vm_remove_apply_hook_x)
(scm_vm_add_return_hook_x, scm_vm_remove_return_hook_x)
(scm_vm_add_next_hook_x, scm_vm_remove_next_hook_x): New functions,
replacing direct access to the hooks.  Allows us to know in a more
fine-grained way when to enable hooks.
(scm_set_vm_trace_level_x): Use reset_vm_hook_enabled to update the
individual hook_enabled flags.
* module/statprof.scm:
* module/system/vm/coverage.scm:
* module/system/vm/traps.scm:
* module/system/vm/vm.scm: Adapt VM hook users to the new API.
This commit is contained in:
Andy Wingo 2018-09-14 08:42:41 +02:00
parent ce5c05ac4a
commit bf31fe4cf6
7 changed files with 130 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

6
libguile/vm-engine.c
View file

@ -126,7 +126,7 @@
#define APPLY_HOOK() RUN_HOOK (apply)
#define RETURN_HOOK() RUN_HOOK (return)
#define NEXT_HOOK() RUN_HOOK (next)
#define ABORT_CONTINUATION_HOOK() RUN_HOOK (abort)
#define ABORT_HOOK() RUN_HOOK (abort)
@ -780,7 +780,7 @@ VM_NAME (scm_thread *thread)
intervening C frames to jump over, so we just continue
directly. */
ABORT_CONTINUATION_HOOK ();
ABORT_HOOK ();
if (mcode)
scm_jit_enter_mcode (thread, mcode);
@ -3025,7 +3025,7 @@ VM_NAME (scm_thread *thread)
}
#undef ABORT_CONTINUATION_HOOK
#undef ABORT_HOOK
#undef ALIGNED_P
#undef APPLY_HOOK
#undef BEGIN_DISPATCH_SWITCH

103
libguile/vm.c
View file

@ -278,7 +278,7 @@ invoke_next_hook (scm_thread *thread)
static void
invoke_abort_hook (scm_thread *thread)
{
return invoke_hook (thread, SCM_VM_ABORT_CONTINUATION_HOOK);
return invoke_hook (thread, SCM_VM_ABORT_HOOK);
}
@ -1491,47 +1491,105 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
/* Scheme interface */
#define VM_DEFINE_HOOK(n) \
static void
reset_vm_hook_enabled (scm_thread *thread, int i)
{
SCM hook = thread->vm.hooks[i];
int empty = scm_is_false (hook) || scm_is_true (scm_hook_empty_p (hook));
if (thread->vm.trace_level > 0)
thread->vm.hooks_enabled[i] = !empty;
else
thread->vm.hooks_enabled[i] = 0;
}
#define VM_ADD_HOOK(n, f) \
{ \
scm_thread *t = SCM_I_CURRENT_THREAD; \
if (scm_is_false (t->vm.hooks[n])) \
t->vm.hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return t->vm.hooks[n]; \
scm_add_hook_x (t->vm.hooks[n], f, SCM_UNDEFINED); \
reset_vm_hook_enabled (t, n); \
return SCM_UNSPECIFIED; \
}
SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
(void),
#define VM_REMOVE_HOOK(n, f) \
{ \
scm_thread *t = SCM_I_CURRENT_THREAD; \
scm_remove_hook_x (t->vm.hooks[n], f); \
reset_vm_hook_enabled (t, n); \
return SCM_UNSPECIFIED; \
}
SCM_DEFINE (scm_vm_add_apply_hook_x, "vm-add-apply-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_apply_hook
#define FUNC_NAME s_scm_vm_add_apply_hook_x
{
VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
VM_ADD_HOOK (SCM_VM_APPLY_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 0, 0, 0,
(void),
SCM_DEFINE (scm_vm_remove_apply_hook_x, "vm-remove-apply-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_return_hook
#define FUNC_NAME s_scm_vm_remove_apply_hook_x
{
VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
VM_REMOVE_HOOK (SCM_VM_APPLY_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
(void),
SCM_DEFINE (scm_vm_add_return_hook_x, "vm-add-return-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_next_hook
#define FUNC_NAME s_scm_vm_add_return_hook_x
{
VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
VM_ADD_HOOK (SCM_VM_RETURN_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0,
(void),
SCM_DEFINE (scm_vm_remove_return_hook_x, "vm-remove-return-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_abort_continuation_hook
#define FUNC_NAME s_scm_vm_remove_return_hook_x
{
VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK);
VM_REMOVE_HOOK (SCM_VM_RETURN_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_add_next_hook_x, "vm-add-next-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_add_next_hook_x
{
VM_ADD_HOOK (SCM_VM_NEXT_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_remove_next_hook_x, "vm-remove-next-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_remove_next_hook_x
{
VM_REMOVE_HOOK (SCM_VM_NEXT_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_add_abort_hook_x, "vm-add-abort-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_add_abort_hook_x
{
VM_ADD_HOOK (SCM_VM_ABORT_HOOK, f);
}
#undef FUNC_NAME
SCM_DEFINE (scm_vm_remove_abort_hook_x, "vm-remove-abort-hook!", 1, 0, 0,
(SCM f),
"")
#define FUNC_NAME s_scm_vm_remove_abort_hook_x
{
VM_REMOVE_HOOK (SCM_VM_ABORT_HOOK, f);
}
#undef FUNC_NAME
@ -1549,7 +1607,12 @@ SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
"")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
SCM_I_CURRENT_THREAD->vm.trace_level = scm_to_int (level);
scm_thread *thread = SCM_I_CURRENT_THREAD;
int i;
thread->vm.trace_level = scm_to_int (level);
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
reset_vm_hook_enabled (thread, i);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

15
libguile/vm.h
View file

@ -29,7 +29,7 @@ enum {
SCM_VM_APPLY_HOOK,
SCM_VM_RETURN_HOOK,
SCM_VM_NEXT_HOOK,
SCM_VM_ABORT_CONTINUATION_HOOK,
SCM_VM_ABORT_HOOK,
SCM_VM_NUM_HOOKS,
};
@ -57,6 +57,7 @@ struct scm_vm {
union scm_vm_stack_element *stack_top; /* highest address in allocated stack */
SCM overflow_handler_stack; /* alist of max-stack-size -> thunk */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
uint8_t hooks_enabled[SCM_VM_NUM_HOOKS]; /* if corresponding hook is enabled */
jmp_buf *registers; /* registers captured at latest vm entry */
uint8_t *mra_after_abort; /* mra to resume after nonlocal exit, or NULL */
int engine; /* which vm engine we're using */
@ -67,10 +68,14 @@ SCM_API SCM scm_call_with_vm (SCM proc, SCM args);
SCM_API SCM scm_call_with_stack_overflow_handler (SCM limit, SCM thunk,
SCM handler);
SCM_API SCM scm_vm_apply_hook (void);
SCM_API SCM scm_vm_return_hook (void);
SCM_API SCM scm_vm_abort_continuation_hook (void);
SCM_API SCM scm_vm_next_hook (void);
SCM_INTERNAL SCM scm_vm_add_apply_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_add_return_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_add_abort_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_add_next_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_remove_apply_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_remove_return_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_remove_abort_hook_x (SCM);
SCM_INTERNAL SCM scm_vm_remove_next_hook_x (SCM);
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);

4
module/statprof.scm
View file

@ -313,7 +313,7 @@ than @code{statprof-stop}, @code{#f} otherwise."
(set-prev-sigprof-handler! state (car prev)))
(reset-sigprof-timer (if (zero? rpt) (sampling-period state) rpt))
(when (call-counts state)
(add-hook! (vm-apply-hook) count-call)
(vm-add-apply-hook! count-call)
(set-vm-trace-level! (1+ (vm-trace-level))))
#t)))
@ -326,7 +326,7 @@ than @code{statprof-stop}, @code{#f} otherwise."
(when (zero? (profile-level state))
(when (call-counts state)
(set-vm-trace-level! (1- (vm-trace-level)))
(remove-hook! (vm-apply-hook) count-call))
(vm-remove-apply-hook! count-call))
(set-gc-time-taken! state
(- (assq-ref (gc-stats) 'gc-time-taken)
(gc-time-taken state)))

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

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;; Copyright (C) 2010, 2013, 2018 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
@ -70,17 +70,16 @@ by THUNK."
;; VM is different from the current one, continuations will not be
;; resumable.
(call-with-values (lambda ()
(let ((level (vm-trace-level))
(hook (vm-next-hook)))
(let ((level (vm-trace-level)))
(dynamic-wind
(lambda ()
(set-vm-trace-level! (+ level 1))
(add-hook! hook collect!))
(vm-add-next-hook! collect!))
(lambda ()
(call-with-vm thunk))
(lambda ()
(set-vm-trace-level! level)
(remove-hook! hook collect!)))))
(vm-remove-next-hook! collect!)))))
(lambda args
(apply values (make-coverage-data ip-counts) args))))

48
module/system/vm/traps.scm
View file

@ -145,9 +145,9 @@
(new-enabled-trap
#f
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook))
(vm-add-apply-hook! apply-hook))
(lambda (frame)
(remove-hook! (vm-apply-hook) apply-hook)))))
(vm-remove-apply-hook! apply-hook)))))
;; A more complicated trap, traps when control enters a procedure.
;;
@ -206,17 +206,17 @@
(new-enabled-trap
current-frame
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook)
(add-hook! (vm-return-hook) return-hook)
(add-hook! (vm-abort-continuation-hook) abort-hook)
(vm-add-apply-hook! apply-hook)
(vm-add-return-hook! return-hook)
(vm-add-abort-hook! abort-hook)
(if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
(exit-proc frame))
(remove-hook! (vm-apply-hook) apply-hook)
(remove-hook! (vm-return-hook) return-hook)
(remove-hook! (vm-abort-continuation-hook) abort-hook)))))
(vm-remove-apply-hook! apply-hook)
(vm-remove-return-hook! return-hook)
(vm-remove-abort-hook! abort-hook)))))
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
@ -232,12 +232,12 @@
(next-handler frame)))
(define (enter frame)
(add-hook! (vm-next-hook) next-hook)
(vm-add-next-hook! next-hook)
(if frame (next-hook frame)))
(define (exit frame)
(exit-handler frame)
(remove-hook! (vm-next-hook) next-hook))
(vm-remove-next-hook! next-hook))
(trap-in-procedure proc enter exit
#:current-frame current-frame
@ -413,12 +413,12 @@
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
(add-hook! (vm-return-hook) return-hook)
(add-hook! (vm-abort-continuation-hook) abort-hook))
(vm-add-return-hook! return-hook)
(vm-add-abort-hook! abort-hook))
(lambda (frame)
(set! fp #f)
(remove-hook! (vm-return-hook) return-hook)
(remove-hook! (vm-abort-continuation-hook) abort-hook)))))
(vm-remove-return-hook! return-hook)
(vm-remove-abort-hook! abort-hook)))))
;; A more traditional dynamic-wind trap. Perhaps this should not be
;; based on the above trap-frame-finish?
@ -451,12 +451,12 @@
(new-enabled-trap
current-frame
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook))
(vm-add-apply-hook! apply-hook))
(lambda (frame)
(if exit-trap
(abort-hook frame))
(set! exit-trap #f)
(remove-hook! (vm-apply-hook) apply-hook)))))
(vm-remove-apply-hook! apply-hook)))))
;; Trapping all procedure calls within a dynamic extent, recording the
;; depth of the call stack relative to the original procedure.
@ -500,12 +500,12 @@
(apply-handler frame (length *stack*)))
(define (enter frame)
(add-hook! (vm-return-hook) trace-return)
(add-hook! (vm-apply-hook) trace-apply))
(vm-add-return-hook! trace-return)
(vm-add-apply-hook! trace-apply))
(define (leave frame)
(remove-hook! (vm-return-hook) trace-return)
(remove-hook! (vm-apply-hook) trace-apply))
(vm-remove-return-hook! trace-return)
(vm-remove-apply-hook! trace-apply))
(define (return frame)
(leave frame))
@ -529,10 +529,10 @@
(next-handler frame))
(define (enter frame)
(add-hook! (vm-next-hook) trace-next))
(vm-add-next-hook! trace-next))
(define (leave frame)
(remove-hook! (vm-next-hook) trace-next))
(vm-remove-next-hook! trace-next))
(define (return frame)
(leave frame))
@ -618,6 +618,6 @@
(new-enabled-trap
#f
(lambda (frame)
(add-hook! (vm-next-hook) next-hook))
(vm-add-next-hook! next-hook))
(lambda (frame)
(remove-hook! (vm-next-hook) next-hook)))))
(vm-remove-next-hook! next-hook)))))

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

@ -23,9 +23,10 @@
call-with-stack-overflow-handler
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-apply-hook vm-return-hook
vm-next-hook
vm-abort-continuation-hook))
vm-add-apply-hook! vm-add-return-hook!
vm-add-next-hook! vm-add-abort-hook!
vm-remove-apply-hook! vm-remove-return-hook!
vm-remove-next-hook! vm-remove-abort-hook!))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_vm")