diff options
author | Andy Wingo <wingo@pobox.com> | 2018-09-14 08:42:41 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-09-14 08:52:24 +0200 |
commit | bf31fe4cf6d75c96cc4ef29fea8808dd539da361 (patch) | |
tree | 31e180ad8951d60c87ae3f91b2cf0525f2a99f62 | |
parent | ce5c05ac4aa105a8a7b855c6cb5d811ef672cf5b (diff) | |
download | guile-bf31fe4cf6d75c96cc4ef29fea8808dd539da361.tar.gz |
VM manages hook sets itself
* 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.
-rw-r--r-- | libguile/vm-engine.c | 6 | ||||
-rw-r--r-- | libguile/vm.c | 103 | ||||
-rw-r--r-- | libguile/vm.h | 15 | ||||
-rw-r--r-- | module/statprof.scm | 4 | ||||
-rw-r--r-- | module/system/vm/coverage.scm | 9 | ||||
-rw-r--r-- | module/system/vm/traps.scm | 48 | ||||
-rw-r--r-- | module/system/vm/vm.scm | 7 |
7 files changed, 130 insertions, 62 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 06006a190..2d9be38ab 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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 diff --git a/libguile/vm.c b/libguile/vm.c index 76c3e90a6..c59c91b8f 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -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_remove_return_hook_x +{ + 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_abort_continuation_hook +#define FUNC_NAME s_scm_vm_add_next_hook_x { - VM_DEFINE_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK); + 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 diff --git a/libguile/vm.h b/libguile/vm.h index a4dc78029..8f528f63c 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -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); diff --git a/module/statprof.scm b/module/statprof.scm index a36c21540..a1e0efbd7 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -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))) diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm index f47e33f58..0d51e261a 100644 --- a/module/system/vm/coverage.scm +++ b/module/system/vm/coverage.scm @@ -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)))) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index 49569703e..76be8d7d3 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -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))))) diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm index 7da5d8cc2..91b862d20 100644 --- a/module/system/vm/vm.scm +++ b/module/system/vm/vm.scm @@ -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") |