Steps toward a richer debug facility by horribly abusing the runtime.

marketplace/support/debug.rkt

@@ -9,13 +9,12 @@
 (require "../quasiqueue.rkt")
 
 (require/typed "gui.rkt"
-	       [opaque AnyState any-state?]
-	       [open-debugger (Any -> (Values (AnyState -> Void) (-> Void)))])
+	       [open-debugger (Any -> Debugger)])
+
+(define-type Debugger (All (S) (S -> S)))
 
 (provide debug)
 
-(struct: debugger ([out : (AnyState -> Void)] [in : (-> Void)]))
-
 (: debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState)))
 (define (debug spawn-child)
   (match-define (core:spawn child-spec parent-k debug-name) spawn-child)
@@ -27,9 +26,7 @@
       (define (wrapped-cotransition k)
 	(: receiver : (All (S) (Transition S) -> R))
 	(define (receiver child-transition)
-	  (define-values (send-to-debugger! receive-from-debugger!)
-	    (open-debugger debug-name))
-	  (define d (debugger send-to-debugger! receive-from-debugger!))
+	  (define d (open-debugger debug-name))
 	  ((inst k S) (wrap-transition d child-transition)))
 	((inst original-cotransition R) receiver))
       wrapped-cotransition))
@@ -37,12 +34,11 @@
    (list 'debug debug-name)))
 
 (: wrap-transition : (All (ChildState)
-			  debugger
+			  Debugger
 			  (Transition ChildState)
 			  -> (Transition ChildState)))
-(define (wrap-transition d child-transition)
-  ((debugger-out d) (cast child-transition AnyState))
-  ((debugger-in d))
+(define (wrap-transition d child-transition0)
+  (define child-transition ((inst d (Transition ChildState)) child-transition0))
   (match-define (core:transition child-state child-actions) child-transition)
   (core:transition child-state ((inst action-tree-map ChildState)
 				(wrap-action d)
@@ -57,7 +53,7 @@
    (quasiqueue->list (action-tree->quasiqueue actions))))
 
 (: wrap-action : (All (ChildState)
-		      debugger
+		      Debugger
 		      -> ((Action ChildState) -> (Action ChildState))))
 (define ((wrap-action d) action)
   (cond
@@ -70,7 +66,7 @@
 
 (: wrap-preaction : (All (ChildState)
 			 Boolean
-			 debugger
+			 Debugger
 			 (PreAction ChildState)
 			 -> (PreAction ChildState)))
 (define (wrap-preaction meta? d preaction)
@@ -87,7 +83,7 @@
      preaction]))
 
 (: wrap-interruptk : (All (ChildState)
-			  debugger
+			  Debugger
 			  (InterruptK ChildState)
 			  -> (InterruptK ChildState)))
 (define (wrap-interruptk d ik)
@@ -95,7 +91,7 @@
     (wrap-transition d (ik state))))
 
 (: wrap-spawnk : (All (ChildState)
-		      debugger
+		      Debugger
 		      (Option (PID -> (InterruptK ChildState)))
 		      -> (Option (PID -> (InterruptK ChildState)))))
 (define (wrap-spawnk d maybe-k)
@@ -104,10 +100,10 @@
 
 (: wrap-handler : (All (ChildState)
 		       Boolean
-		       debugger
+		       Debugger
 		       (Handler ChildState)
 		       -> (Handler ChildState)))
-(define (wrap-handler meta? d h)
-  (lambda (event)
-    ((debugger-out d) (cast (cons meta? event) AnyState))
+(define (wrap-handler meta?0 d h)
+  (lambda (event0)
+    (match-define (cons meta? event) ((inst d (Pairof Boolean EndpointEvent)) (cons meta?0 event0)))
     (wrap-interruptk d (h event))))

marketplace/support/gui.rkt

@@ -15,12 +15,13 @@
 (require images/icons/misc)
 (require images/icons/style)
 
+(require data/queue)
+
 (require racket/pretty)
 
 (require (prefix-in core: "../types.rkt"))
 
-(provide any-state?
-	 open-debugger)
+(provide open-debugger)
 
 ;; Frame
 ;;   Toolbar
@@ -45,18 +46,28 @@
 
 (struct historical-moment (alive? state endpoints) #:transparent)
 
-(define (any-state? x) #t)
-
 (define (open-debugger name)
   (define to-debugger (make-channel))
-  (define from-debugger (make-semaphore 0))
+  (define from-debugger (make-channel))
   (parameterize ((current-eventspace (make-eventspace)))
     (new debugger%
 	 [name name]
 	 [from-vm to-debugger]
 	 [to-vm from-debugger]))
-  (values (lambda (t) (channel-put to-debugger t))
-	  (lambda () (semaphore-wait from-debugger))))
+  (wrap/unwrapper
+   (lambda (v)
+     (channel-put to-debugger v)
+     (channel-get from-debugger))))
+
+;; This is utterly vile.
+(define (wrap/unwrapper thunk)
+  (local-require racket/unsafe/ops)
+  (lambda (wrapped-val)
+    ;; (pretty-print `(wrapped-val ,wrapped-val))
+    (define inner (unsafe-struct-ref wrapped-val 0))
+    ;; (pretty-print `(inner ,inner))
+    (unsafe-struct-set! wrapped-val 0 (thunk inner))
+    wrapped-val))
 
 (define debugger%
   (class object%
@@ -67,7 +78,13 @@
 
     (define mutex (make-semaphore 1))
     (define stepping? #t)
-    (define waiting? #f)
+    (define k-queue (make-queue))
+
+    (define (reply-to-vm reply)
+      (call-with-semaphore mutex
+       (lambda () (if stepping?
+		      (channel-put to-vm reply)
+		      (enqueue! k-queue reply)))))
 
     (define current-historical-moment (historical-moment #t (void) '()))
     (define displayed-endpoints '())
@@ -150,9 +167,8 @@
 			 mutex
 			 (lambda ()
 			   (set! stepping? #t)
-			   (when waiting?
-			     (set! waiting? #f)
-			     (semaphore-post to-vm)))))))
+			   (when (non-empty-queue? k-queue)
+			     (channel-put to-vm (dequeue! k-queue))))))))
     (toolbar-spacer)
     (define step-button
       (toolbar-button (step-icon #:color run-icon-color)
@@ -160,9 +176,8 @@
 			(call-with-semaphore
 			 mutex
 			 (lambda ()
-			   (when waiting?
-			     (set! waiting? #f)
-			     (semaphore-post to-vm)))))))
+			   (when (non-empty-queue? k-queue)
+			     (channel-put to-vm (dequeue! k-queue))))))))
 
     (send play-button enable #f)
     (send step-button enable #f)
@@ -335,12 +350,7 @@
 	    [else (define-values (type detail) (format-action a))
 		  (apply-action! a)
 		  (record-event! now "Act" type detail)]))
-	 (call-with-semaphore
-	  mutex
-	  (lambda ()
-	    (if stepping?
-		(semaphore-post to-vm)
-		(set! waiting? #t))))]
+	 (reply-to-vm x)]
 	[(cons meta? e)
 	 (define prefix (if meta? "Meta" ""))
 	 (match e
@@ -350,7 +360,8 @@
 	    (record-event! now "Evt" (string-append prefix "Absence")
 			   (string-append (format-role role) " " (~v reason)))]
 	   [(core:message-event _ message)
-	    (record-event! now "Evt" (string-append prefix "Recv") (~v message))])]))
+	    (record-event! now "Evt" (string-append prefix "Recv") (~v message))])
+	 (reply-to-vm x)]))
 
     (define (controller-thread-loop)
       (sync (handle-evt from-vm