[Guile-commits] 14/41: VM traps don't match on value of slot 0

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 3582787cb032da4d3a722bfb00882e6d992b0c87
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 27 15:38:30 2015 +0100

    VM traps don't match on value of slot 0
    
    * module/system/vm/traps.scm (frame-matcher): Always match on a
      procedure's code, instead of the value in slot 0.  Prevents confusion
      with closure-optimized procedures, re-use of slot 0, and untagged
      values in slot 0.
      (trap-at-procedure-call, trap-in-procedure)
      (trap-instructions-in-procedure, trap-at-procedure-ip-in-range)
      (trap-at-source-location, trap-in-dynamic-extent)
      (trap-calls-in-dynamic-extent, trap-instructions-in-dynamic-extent):
      Update to adapt to frame-matcher change and remove #:closure?
      argument, effectively changing the default behavior to #:closure? #t.
    
    * doc/ref/api-debug.texi (Low-Level Traps): Update documentation.
---
 doc/ref/api-debug.texi     |   19 +++++---------
 module/system/vm/traps.scm |   57 ++++++++++++++++++++-----------------------
 2 files changed, 34 insertions(+), 42 deletions(-)

diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index bf25c74..958c927 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -1088,11 +1088,6 @@ separately, we discuss them all together here:
 @table @code
 @item #:vm
 The VM to instrument. Defaults to the current thread's VM.
address@hidden #:closure?
-For traps that depend on the current frame's procedure, this argument
-specifies whether to trap on the only the specific procedure given, or
-on any closure that has the given procedure's code. Defaults to
address@hidden
 @item #:current-frame
 For traps that enable more hooks depending on their dynamic context,
 this argument gives the current frame that the trap is running in.
@@ -1107,12 +1102,12 @@ To have access to these procedures, you'll need to have 
imported the
 @end lisp
 
 @deffn {Scheme Procedure} trap-at-procedure-call proc handler @
-       [#:vm] [#:closure?]
+       [#:vm]
 A trap that calls @var{handler} when @var{proc} is applied.
 @end deffn                
 
 @deffn {Scheme Procedure} trap-in-procedure proc @
-       enter-handler exit-handler [#:current-frame] [#:vm] [#:closure?]
+       enter-handler exit-handler [#:current-frame] [#:vm]
 A trap that calls @var{enter-handler} when control enters @var{proc},
 and @var{exit-handler} when control leaves @var{proc}.
 
@@ -1140,13 +1135,13 @@ An abort.
 @end deffn
 
 @deffn {Scheme Procedure} trap-instructions-in-procedure proc @
-       next-handler exit-handler [#:current-frame] [#:vm] [#:closure?]
+       next-handler exit-handler [#:current-frame] [#:vm]
 A trap that calls @var{next-handler} for every instruction executed in
 @var{proc}, and @var{exit-handler} when execution leaves @var{proc}.
 @end deffn
 
 @deffn {Scheme Procedure} trap-at-procedure-ip-in-range proc range @
-       handler [#:current-frame] [#:vm] [#:closure?]
+       handler [#:current-frame] [#:vm]
 A trap that calls @var{handler} when execution enters a range of
 instructions in @var{proc}. @var{range} is a simple of pairs,
 @code{((@var{start} . @var{end}) ...)}. The @var{start} addresses are
@@ -1169,7 +1164,7 @@ exit.
 @end deffn
 
 @deffn {Scheme Procedure} trap-in-dynamic-extent proc @
-       enter-handler return-handler abort-handler [#:vm] [#:closure?]
+       enter-handler return-handler abort-handler [#:vm]
 A more traditional dynamic-wind trap, which fires @var{enter-handler}
 when control enters @var{proc}, @var{return-handler} on a normal return,
 and @var{abort-handler} on a nonlocal exit.
@@ -1178,14 +1173,14 @@ Note that rewinds are not handled, so there is no 
rewind handler.
 @end deffn
 
 @deffn {Scheme Procedure} trap-calls-in-dynamic-extent proc @
-       apply-handler return-handler [#:current-frame] [#:vm] [#:closure?]
+       apply-handler return-handler [#:current-frame] [#:vm]
 A trap that calls @var{apply-handler} every time a procedure is applied,
 and @var{return-handler} for returns, but only during the dynamic extent
 of an application of @var{proc}.
 @end deffn
 
 @deffn {Scheme Procedure} trap-instructions-in-dynamic-extent proc @
-       next-handler [#:current-frame] [#:vm] [#:closure?]
+       next-handler [#:current-frame] [#:vm]
 A trap that calls @var{next-handler} for all retired instructions within
 the dynamic extent of a call to @var{proc}.
 @end deffn
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index ca6acdd..db82a0a 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -112,25 +112,26 @@
   (let ((pdi (find-program-debug-info (program-code prog))))
     (and pdi (program-debug-info-size pdi))))
 
-(define (frame-matcher proc match-code?)
+(define (frame-matcher proc)
   (let ((proc (if (struct? proc)
                   (procedure proc)
                   proc)))
-    (if match-code?
-        (if (program? proc)
-            (let ((start (program-code proc))
-                  (end (program-last-ip proc)))
-              (lambda (frame)
-                (let ((ip (frame-instruction-pointer frame)))
-                  (and (<= start ip) (< ip end)))))
-            (lambda (frame) #f))
+    (cond
+     ((program? proc)
+      (let ((start (program-code proc))
+            (end (program-last-ip proc)))
         (lambda (frame)
-          (eq? (frame-procedure frame) proc)))))
+          (let ((ip (frame-instruction-pointer frame)))
+            (and (<= start ip) (< ip end))))))
+     ((struct? proc)
+      (frame-matcher (procedure proc)))
+     (else
+      (error "Not a VM program" proc)))))
 
 ;; A basic trap, fires when a procedure is called.
 ;;
-(define* (trap-at-procedure-call proc handler #:key (closure? #f)
-                                 (our-frame? (frame-matcher proc closure?)))
+(define* (trap-at-procedure-call proc handler #:key
+                                 (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check handler procedure?)
   (let ()
@@ -160,8 +161,8 @@
 ;;  * An abort.
 ;;
 (define* (trap-in-procedure proc enter-handler exit-handler
-                            #:key current-frame (closure? #f)
-                            (our-frame? (frame-matcher proc closure?)))
+                            #:key current-frame
+                            (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check enter-handler procedure?)
   (arg-check exit-handler procedure?)
@@ -216,9 +217,8 @@
 ;; Building on trap-in-procedure, we have trap-instructions-in-procedure
 ;;
 (define* (trap-instructions-in-procedure proc next-handler exit-handler
-                                         #:key current-frame (closure? #f)
-                                         (our-frame?
-                                          (frame-matcher proc closure?)))
+                                         #:key current-frame
+                                         (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check next-handler procedure?)
   (arg-check exit-handler procedure?)
@@ -263,9 +263,8 @@
 ;; trap-at-procedure-ip-in-range.
 ;;
 (define* (trap-at-procedure-ip-in-range proc range handler
-                                        #:key current-frame (closure? #f)
-                                        (our-frame?
-                                         (frame-matcher proc closure?)))
+                                        #:key current-frame
+                                        (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check range range?)
   (arg-check handler procedure?)
@@ -376,8 +375,8 @@
                   (lambda (proc)
                     (let ((range (source->ip-range proc file (1- user-line))))
                       (trap-at-procedure-ip-in-range proc range handler
-                                                     #:current-frame 
current-frame
-                                                     #:closure? closures?)))
+                                                     #:current-frame
+                                                     current-frame)))
                   procs))
            (if (null? traps)
                (error "No procedures found at ~a:~a." file user-line)))
@@ -424,8 +423,8 @@
 ;; based on the above trap-frame-finish?
 ;;
 (define* (trap-in-dynamic-extent proc enter-handler return-handler 
abort-handler
-                                 #:key current-frame (closure? #f)
-                                 (our-frame? (frame-matcher proc closure?)))
+                                 #:key current-frame
+                                 (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check enter-handler procedure?)
   (arg-check return-handler procedure?)
@@ -462,9 +461,8 @@
 ;; depth of the call stack relative to the original procedure.
 ;;
 (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
-                                       #:key current-frame (closure? #f)
-                                       (our-frame?
-                                        (frame-matcher proc closure?)))
+                                       #:key current-frame
+                                       (our-frame? (frame-matcher proc)))
   (arg-check proc procedure?)
   (arg-check apply-handler procedure?)
   (arg-check return-handler procedure?)
@@ -504,9 +502,8 @@
 ;; Trapping all retired intructions within a dynamic extent.
 ;;
 (define* (trap-instructions-in-dynamic-extent proc next-handler
-                                              #:key current-frame (closure? #f)
-                                              (our-frame?
-                                               (frame-matcher proc closure?)))
+                                              #:key current-frame
+                                              (our-frame? (frame-matcher 
proc)))
   (arg-check proc procedure?)
   (arg-check next-handler procedure?)
   (let ()