Steps toward a richer debug facility by horribly abusing the runtime.
This commit is contained in:
parent
6fd0ad0451
commit
71ee3ac0b7
|
@ -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))))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue