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.

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

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,
+#define VM_REMOVE_HOOK(n, f)                            \
-	    (void),
+{							\
+  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,
+SCM_DEFINE (scm_vm_remove_apply_hook_x, "vm-remove-apply-hook!", 1, 0, 0,
-	    (void),
+	    (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,
+SCM_DEFINE (scm_vm_add_return_hook_x, "vm-add-return-hook!", 1, 0, 0,
-	    (void),
+	    (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,
+SCM_DEFINE (scm_vm_remove_return_hook_x, "vm-remove-return-hook!", 1, 0, 0,
-	    (void),
+	    (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

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_INTERNAL SCM scm_vm_add_apply_hook_x (SCM);
-SCM_API SCM scm_vm_return_hook (void);
+SCM_INTERNAL SCM scm_vm_add_return_hook_x (SCM);
-SCM_API SCM scm_vm_abort_continuation_hook (void);
+SCM_INTERNAL SCM scm_vm_add_abort_hook_x (SCM);
-SCM_API SCM scm_vm_next_hook (void);
+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);

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)))

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))
+                      (let ((level   (vm-trace-level)))
-                            (hook    (vm-next-hook)))
                         (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))))
 

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)
+       (vm-add-apply-hook! apply-hook)
-       (add-hook! (vm-return-hook) return-hook)
+       (vm-add-return-hook! return-hook)
-       (add-hook! (vm-abort-continuation-hook) abort-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)
+       (vm-remove-apply-hook! apply-hook)
-       (remove-hook! (vm-return-hook) return-hook)
+       (vm-remove-return-hook! return-hook)
-       (remove-hook! (vm-abort-continuation-hook) abort-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)
+       (vm-add-return-hook! return-hook)
-       (add-hook! (vm-abort-continuation-hook) abort-hook))
+       (vm-add-abort-hook! abort-hook))
      (lambda (frame)
        (set! fp #f)
-       (remove-hook! (vm-return-hook) return-hook)
+       (vm-remove-return-hook! return-hook)
-       (remove-hook! (vm-abort-continuation-hook) abort-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)
+      (vm-add-return-hook! trace-return)
-      (add-hook! (vm-apply-hook) trace-apply))
+      (vm-add-apply-hook! trace-apply))
   
     (define (leave frame)
-      (remove-hook! (vm-return-hook) trace-return)
+      (vm-remove-return-hook! trace-return)
-      (remove-hook! (vm-apply-hook) trace-apply))
+      (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)))))

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-add-apply-hook! vm-add-return-hook!
-            vm-next-hook
+            vm-add-next-hook! vm-add-abort-hook!
-            vm-abort-continuation-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")