mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +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

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