From df067433a537a5e12e2b06e5dc72e593b097316c Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 5 Oct 2010 21:53:29 +0200
Subject: [PATCH] (system vm trap-state): add-trap-at-frame-finish!

* module/system/vm/traps.scm: Fix a comment.

* module/system/vm/trap-state.scm (<trap-state>): Add next-ephemeral-idx
  slot.
  (wrapper-at-index): Use eqv? instead of = to avoid type errors in user
  inputs.
  (next-ephemeral-index!, ephemeral-handler-for-index): New functions,
  allocate ephemeral trap ids for functions to be called only once.
  (add-trap-at-frame-finish!): New export, traps when a frame finishes.
---
 module/system/vm/trap-state.scm | 35 +++++++++++++++++++++++++++++++--
 module/system/vm/traps.scm      |  2 +-
 2 files changed, 34 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 02a4c8818..f45f98121 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -38,7 +38,8 @@
 
             add-trap-at-procedure-call!
             add-trace-at-procedure-call!
-            add-trap-at-source-location!))
+            add-trap-at-source-location!
+            add-trap-at-frame-finish!))
 
 (define %default-trap-handler (make-fluid))
 
@@ -57,6 +58,7 @@
 (define-record <trap-state>
   (handler default-trap-handler)
   (next-idx 0)
+  (next-ephemeral-idx -1)
   (wrappers '()))
 
 (define (trap-wrapper<? t1 t2)
@@ -103,7 +105,7 @@
      ((null? wrappers)
       (warn "no wrapper found with index in trap-state" idx)
       #f)
-     ((= (trap-wrapper-index (car wrappers)) idx)
+     ((eqv? (trap-wrapper-index (car wrappers)) idx)
       (car wrappers))
      (else
       (lp (cdr wrappers))))))
@@ -113,6 +115,11 @@
     (set! (trap-state-next-idx trap-state) (1+ idx))
     idx))
 
+(define (next-ephemeral-index! trap-state)
+  (let ((idx (trap-state-next-ephemeral-idx trap-state)))
+    (set! (trap-state-next-ephemeral-idx trap-state) (1- idx))
+    idx))
+
 (define (handler-for-index trap-state idx)
   (lambda (frame)
     (let ((wrapper (wrapper-at-index trap-state idx))
@@ -122,6 +129,16 @@
                    (trap-wrapper-index wrapper)
                    (trap-wrapper-name wrapper))))))
 
+(define (ephemeral-handler-for-index trap-state idx handler)
+  (lambda (frame)
+    (let ((wrapper (wrapper-at-index trap-state idx)))
+      (if wrapper
+          (begin
+            (if (trap-wrapper-enabled? wrapper)
+                (disable-trap-wrapper! wrapper))
+            (remove-trap-wrapper! trap-state wrapper)
+            (handler frame))))))
+
 
 
 ;;;
@@ -221,6 +238,20 @@
       idx #t trap
       (format #f "Breakpoint at ~a:~a" file user-line)))))
 
+;; handler := frame -> nothing
+(define* (add-trap-at-frame-finish! frame handler
+                                    #:optional (trap-state (the-trap-state)))
+  (let* ((idx (next-ephemeral-index! trap-state))
+         (trap (trap-frame-finish
+                frame
+                (ephemeral-handler-for-index trap-state idx handler)
+                (lambda (frame) (delete-trap! idx trap-state)))))
+    (add-trap-wrapper!
+     trap-state
+     (make-trap-wrapper
+      idx #t trap
+      (format #f "Return from ~a" frame)))))
+
 (define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
   (let* ((idx (next-index! trap-state)))
     (add-trap-wrapper!
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index 3b2a43875..dfaedc584 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -268,7 +268,7 @@
           range))
 
 ;; Building on trap-instructions-in-procedure, we have
-;; trap-instructions-in-procedure.
+;; trap-at-procedure-ip-in-range.
 ;;
 (define* (trap-at-procedure-ip-in-range proc range handler
                                         #:key current-frame (vm (the-vm))