From 71ee3ac0b7af83d58b114fc1119f30fffd002a24 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 23 Apr 2013 16:26:10 -0400 Subject: [PATCH] Steps toward a richer debug facility by horribly abusing the runtime. --- marketplace/support/debug.rkt | 34 ++++++++++------------ marketplace/support/gui.rkt | 53 +++++++++++++++++++++-------------- 2 files changed, 47 insertions(+), 40 deletions(-) diff --git a/marketplace/support/debug.rkt b/marketplace/support/debug.rkt index 15cf8a0..b2f502a 100644 --- a/marketplace/support/debug.rkt +++ b/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)))) diff --git a/marketplace/support/gui.rkt b/marketplace/support/gui.rkt index 061bbba..e36884c 100644 --- a/marketplace/support/gui.rkt +++ b/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