[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/03: VM manages hook sets itself
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/03: VM manages hook sets itself |
|
Date: |
Fri, 14 Sep 2018 04:14:28 -0400 (EDT) |
wingo pushed a commit to branch lightning
in repository guile.
commit bf31fe4cf6d75c96cc4ef29fea8808dd539da361
Author: Andy Wingo <address@hidden>
Date: Fri Sep 14 08:42:41 2018 +0200
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 | 6 +--
libguile/vm.c | 103 ++++++++++++++++++++++++++++++++++--------
libguile/vm.h | 15 ++++--
module/statprof.scm | 4 +-
module/system/vm/coverage.scm | 9 ++--
module/system/vm/traps.scm | 48 ++++++++++----------
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 06006a1..2d9be38 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 76c3e90..c59c91b 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 a4dc780..8f528f6 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 a36c215..a1e0efb 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 f47e33f..0d51e26 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 4956970..76be8d7 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 7da5d8c..91b862d 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")