breakpoints from recursive prompts work

* module/system/vm/traps.scm (new-disabled-trap): Don't manipulate the
  VM trace level in the enable and disable handlers. Unfortunately, this
  makes traps not work unless you enable hooks, but given that
  vm_dispatch_hook has to set trace-level to 0, there needs to be an
  object with a broader view of what traps are enabled. That object is
  the hook state.

* module/system/vm/trap-state.scm (trap-state->trace-level): New
  procedure.
  (with-default-trap-handler): Add an optional trap-state argument. Now
  makes sure that the vm-trace-level is set appropriately during the
  execution of the thunk, allowing for breakpoints from recursive
  prompts.

diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 4277dd3..3264500 100644 (file)
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -22,6 +22,7 @@
 
 (define-module (system vm trap-state)
   #:use-module (system base syntax)
+  #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (system vm vm)
   #:use-module (system vm traps)
   #:export (list-traps
@@ -37,10 +38,6 @@
 
 (define %default-trap-handler (make-fluid))
 
-(define (with-default-trap-handler handler thunk)
-  (with-fluids ((%default-trap-handler handler))
-    (thunk)))
-
 (define (default-trap-handler frame idx trap-name)
   (let ((default-handler (fluid-ref %default-trap-handler)))
     (if default-handler
@@ -87,6 +84,14 @@
 (define (remove-trap-wrapper! trap-state wrapper)
   (delq wrapper (trap-state-wrappers trap-state)))
 
+(define (trap-state->trace-level trap-state)
+  (fold (lambda (wrapper level)
+          (if (trap-wrapper-enabled? wrapper)
+              (1+ level)
+              level))
+        0
+        (trap-state-wrappers trap-state)))
+
 (define (wrapper-at-index trap-state idx)
   (let lp ((wrappers (trap-state-wrappers trap-state)))
     (cond
@@ -135,6 +140,16 @@
 ;;; API
 ;;;
 
+(define* (with-default-trap-handler handler thunk
+                                    #:optional (trap-state (the-trap-state)))
+  (with-fluids ((%default-trap-handler handler))
+    (dynamic-wind
+      (lambda ()
+        (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state)))
+      thunk
+      (lambda ()
+        (set-vm-trace-level! (the-vm) 0)))))
+
 (define* (list-traps #:optional (trap-state (the-trap-state)))
   (map (lambda (wrapper)
          (cons (trap-wrapper-index wrapper)

diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 824e2a4..e568ad8 100644 (file)
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -87,14 +87,12 @@
     (define* (enable-trap #:optional frame)
       (if enabled? (error "trap already enabled"))
       (enable frame)
-      (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
       (set! enabled? #t)
       disable-trap)
     
     (define* (disable-trap #:optional frame)
       (if disabled? (error "trap already disabled"))
       (disable frame)
-      (set-vm-trace-level! vm (1- (vm-trace-level vm)))
       (set! disabled? #t)
       enable-trap)