summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/command-line.scm2
-rw-r--r--module/system/vm/coverage.scm7
-rw-r--r--module/system/vm/trace.scm21
-rw-r--r--module/system/vm/trap-state.scm16
-rw-r--r--module/system/vm/traps.scm67
-rw-r--r--module/system/vm/vm.scm3
6 files changed, 50 insertions, 66 deletions
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 6633e1810..7da0a6b15 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -32,7 +32,7 @@
;;;
(define-module (ice-9 command-line)
- #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+ #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
#:export (compile-shell-switches
version-etc
*GPLv3+*
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 311a23b7c..f47e33f58 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -50,9 +50,10 @@
;;; Gathering coverage data.
;;;
-(define (with-code-coverage vm thunk)
- "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
-coverage data. Return code coverage data and the values returned by THUNK."
+(define (with-code-coverage thunk)
+ "Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
+collect code coverage data. Return code coverage data and the values returned
+by THUNK."
(define ip-counts
;; A table mapping instruction pointers to the number of times they were
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 084c65a9a..30acba473 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -67,52 +67,49 @@
(format #f "~v:@y" width val))
values))))))
-(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-to-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values))
- (trap-calls-to-procedure proc apply-handler return-handler
- #:vm vm))
+ (trap-calls-to-procedure proc apply-handler return-handler))
-(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-in-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
(define (return-handler frame depth . values)
(print-return frame depth width prefix max-indent values))
- (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:vm vm))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler))
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-instructions-in-procedure proc #:key (width 80)
(max-indent (- width 40)))
(define (trace-next frame)
;; FIXME: We could disassemble this instruction here.
(let ((ip (frame-instruction-pointer frame)))
(format #t "0x~x\n" ip)))
- (trap-instructions-in-dynamic-extent proc trace-next
- #:vm vm))
+ (trap-instructions-in-dynamic-extent proc trace-next))
;; Note that because this procedure manipulates the VM trace level
;; directly, it doesn't compose well with traps at the REPL.
;;
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
- (width 80) (vm (the-vm)) (max-indent (- width 40)))
+ (width 80) (max-indent (- width 40)))
(let ((call-trap #f)
(inst-trap #f))
(dynamic-wind
(lambda ()
(if calls?
(set! call-trap
- (trace-calls-in-procedure thunk #:vm vm #:width width
+ (trace-calls-in-procedure thunk #:width width
#:max-indent max-indent)))
(if instructions?
(set! inst-trap
- (trace-instructions-in-procedure thunk #:vm vm #:width width
+ (trace-instructions-in-procedure thunk #:width width
#:max-indent max-indent)))
(set-vm-trace-level! (1+ (vm-trace-level))))
thunk
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 78ccb8d89..464740bcd 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -146,19 +146,19 @@
;;;
-;;; VM-local trap states
+;;; Per-thread trap states
;;;
-(define *trap-states* (make-weak-key-hash-table))
+;; FIXME: This should be thread-local -- not something you can inherit
+;; from a dynamic state.
-(define (trap-state-for-vm vm)
- (or (hashq-ref *trap-states* vm)
- (let ((ts (make-trap-state)))
- (hashq-set! *trap-states* vm ts)
- (trap-state-for-vm vm))))
+(define %trap-state (make-parameter #f))
(define (the-trap-state)
- (trap-state-for-vm (the-vm)))
+ (or (%trap-state)
+ (let ((ts (make-trap-state)))
+ (%trap-state ts)
+ ts)))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 1d42f1cc1..7fab208aa 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -83,7 +83,7 @@
(if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
-(define (new-disabled-trap vm enable disable)
+(define (new-disabled-trap enable disable)
(let ((enabled? #f))
(define-syntax disabled?
(identifier-syntax
@@ -104,8 +104,8 @@
enable-trap))
-(define (new-enabled-trap vm frame enable disable)
- ((new-disabled-trap vm enable disable) frame))
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
;; Returns an absolute IP.
(define (program-last-ip prog)
@@ -126,8 +126,7 @@
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
- (closure? #f)
+(define* (trap-at-procedure-call proc handler #:key (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
@@ -137,7 +136,7 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
@@ -158,8 +157,7 @@
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
@@ -208,7 +206,7 @@
(enter-proc frame)))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook)
(add-hook! (vm-push-continuation-hook) push-cont-hook)
@@ -229,8 +227,7 @@
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -250,7 +247,7 @@
(remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (non-negative-integer? x)
@@ -277,8 +274,7 @@
;; trap-at-procedure-ip-in-range.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -311,7 +307,7 @@
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (program-sources-by-line proc file)
@@ -375,8 +371,7 @@
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;;
-(define* (trap-at-source-location file user-line handler
- #:key current-frame (vm (the-vm)))
+(define* (trap-at-source-location file user-line handler #:key current-frame)
(arg-check file string?)
(arg-check user-line positive-integer?)
(arg-check handler procedure?)
@@ -385,7 +380,7 @@
(lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?)
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(set! traps
(map
@@ -393,7 +388,6 @@
(let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler
#:current-frame current-frame
- #:vm vm
#:closure? closures?)))
procs))
(if (null? traps)
@@ -408,8 +402,7 @@
;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns.
;;
-(define* (trap-frame-finish frame return-handler abort-handler
- #:key (vm (the-vm)))
+(define (trap-frame-finish frame return-handler abort-handler)
(arg-check frame frame?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
@@ -427,7 +420,7 @@
(apply abort-handler frame values))))
(new-enabled-trap
- vm frame
+ frame
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
@@ -444,8 +437,7 @@
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
@@ -467,11 +459,10 @@
(begin
(enter-handler frame)
(set! exit-trap
- (trap-frame-finish frame return-hook abort-hook
- #:vm vm)))))
+ (trap-frame-finish frame return-hook abort-hook)))))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
@@ -484,8 +475,7 @@
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -521,14 +511,13 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
@@ -550,13 +539,12 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call depth.
;;
-(define* (trap-calls-to-procedure proc apply-handler return-handler
- #:key (vm (the-vm)))
+(define (trap-calls-to-procedure proc apply-handler return-handler)
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
@@ -584,7 +572,7 @@
(frame-finished frame))
(set! finish-trap
- (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (trap-frame-finish frame return-hook abort-hook))
(set! pending-finish-traps
(cons finish-trap pending-finish-traps))))))
@@ -613,12 +601,11 @@
(with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers
- (trap-at-procedure-call proc apply-hook #:vm vm))))
+ (trap-at-procedure-call proc apply-hook))))
;; Trap when the source location changes.
;;
-(define* (trap-matching-instructions frame-pred handler
- #:key (vm (the-vm)))
+(define (trap-matching-instructions frame-pred handler)
(arg-check frame-pred procedure?)
(arg-check handler procedure?)
(let ()
@@ -627,7 +614,7 @@
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
(add-hook! (vm-next-hook) next-hook))
(lambda (frame)
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index f459f0ae8..ffed9073d 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -19,8 +19,7 @@
;;; Code:
(define-module (system vm vm)
- #:export (vm?
- the-vm call-with-vm
+ #:export (call-with-vm
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook