diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor index c8c0ff28a6..1fded308b4 100755 --- a/extra/tools/walker/debug/debug.factor +++ b/extra/tools/walker/debug/debug.factor @@ -2,17 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.promises models tools.walker kernel sequences concurrency.messaging locals continuations -threads namespaces namespaces.private ; +threads namespaces namespaces.private assocs ; IN: tools.walker.debug :: test-walker ( quot -- data ) - [let | p [ ] - s [ f ] - c [ f ] | + [let | p [ ] | [ H{ } clone >n - [ s c start-walker-thread p fulfill ] new-walker-hook set - [ drop ] show-walker-hook set + + [ + p promise-fulfilled? + [ drop ] [ p fulfill ] if + 2drop + ] show-walker-hook set break @@ -23,9 +25,7 @@ IN: tools.walker.debug p ?promise send-synchronous drop - detach p ?promise - send-synchronous drop - - c model-value continuation-data + thread-variables walker-continuation swap at + model-value continuation-data ] ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index e86cee0c47..610d3db0a3 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,33 +3,51 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models ; +sequences.private assocs models combinators.cleave ; IN: tools.walker -SYMBOL: new-walker-hook ! ( -- ) -SYMBOL: show-walker-hook ! ( thread -- ) +SYMBOL: show-walker-hook ! ( status continuation thread -- ) -! Thread local +! Thread local in thread being walked SYMBOL: walker-thread -SYMBOL: walking-thread -: get-walker-thread ( -- thread ) +! Thread local in walker thread +SYMBOL: walking-thread +SYMBOL: walker-status +SYMBOL: walker-continuation +SYMBOL: walker-history + +DEFER: start-walker-thread + +: get-walker-thread ( -- status continuation thread ) walker-thread tget [ - dup show-walker-hook get call + [ thread-variables walker-status swap at ] + [ thread-variables walker-continuation swap at ] + [ ] tri ] [ - new-walker-hook get call - walker-thread tget + f + f + 2dup start-walker-thread ] if* ; -: break ( -- ) - continuation callstack over set-continuation-call +USING: io.streams.c prettyprint ; - get-walker-thread send-synchronous { +: show-walker ( -- thread ) + get-walker-thread + [ show-walker-hook get call ] keep ; + +: after-break ( object -- ) + { { [ dup continuation? ] [ (continue) ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ "Single stepping abandoned" throw ] } } cond ; +: break ( -- ) + continuation callstack over set-continuation-call + show-walker send-synchronous + after-break ; + \ break t "break?" set-word-prop : walk ( quot -- quot' ) @@ -71,15 +89,9 @@ SYMBOL: detach SYMBOL: abandon SYMBOL: call-in -! Thread locals -SYMBOL: walker-status -SYMBOL: walker-continuation -SYMBOL: walker-history - SYMBOL: +running+ SYMBOL: +suspended+ SYMBOL: +stopped+ -SYMBOL: +detached+ : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the @@ -145,34 +157,20 @@ SYMBOL: +detached+ : set-status ( symbol -- ) walker-status tget set-model ; -: unassociate-thread ( -- ) - walker-thread walking-thread tget thread-variables delete-at - [ ] walking-thread tget set-thread-exit-handler ; - -: detach-msg ( -- ) - +detached+ set-status - unassociate-thread ; - : keep-running ( -- ) +running+ set-status ; : walker-stopped ( -- ) +stopped+ set-status - [ status +stopped+ eq? ] [ - [ - { - { detach [ detach-msg ] } - [ drop ] - } case f - ] handle-synchronous - ] [ ] while ; + [ status +stopped+ eq? ] + [ [ drop f ] handle-synchronous ] + [ ] while ; : step-into-all-loop ( -- ) +running+ set-status [ status +running+ eq? ] [ [ { - { detach [ detach-msg f ] } { step [ f ] } { step-out [ f ] } { step-into [ f ] } @@ -201,10 +199,6 @@ SYMBOL: +detached+ { ! These are sent by the walker tool. We reply ! and keep cycling. - { detach [ detach-msg ] } - ! These change the state of the thread being - ! interpreted, so we modify the continuation and - ! output f. { step [ step-msg keep-running ] } { step-out [ step-out-msg keep-running ] } { step-into [ step-into-msg keep-running ] } @@ -221,10 +215,9 @@ SYMBOL: +detached+ : walker-loop ( -- ) +running+ set-status - [ status +detached+ eq? not ] [ + [ status +stopped+ eq? not ] [ [ { - { detach [ detach-msg f ] } ! ignore these commands while the thread is ! running { step [ f ] } diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index bc038cd244..a9fe38a14c 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -4,14 +4,18 @@ USING: kernel concurrency.messaging inspector ui.tools.listener ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets models ui.tools.workspace ui.gestures ui.gadgets.labels ui threads -namespaces tools.walker assocs ; +namespaces tools.walker assocs combinators combinators.cleave ; IN: ui.tools.walker -TUPLE: walker-gadget status continuation thread traceback ; +TUPLE: walker-gadget +status continuation thread +traceback +closing? ; : walker-command ( walker msg -- ) - over walker-gadget-thread thread-registered? - [ swap walker-gadget-thread send-synchronous drop ] + swap + dup walker-gadget-thread thread-registered? + [ walker-gadget-thread send-synchronous drop ] [ 2drop ] if ; : com-step ( walker -- ) step walker-command ; @@ -27,7 +31,9 @@ TUPLE: walker-gadget status continuation thread traceback ; : com-abandon ( walker -- ) abandon walker-command ; M: walker-gadget ungraft* - dup delegate ungraft* detach walker-command ; + [ t swap set-walker-gadget-closing? ] + [ com-continue ] + [ delegate ungraft* ] tri ; M: walker-gadget focusable-child* walker-gadget-traceback ; @@ -41,7 +47,6 @@ M: walker-gadget focusable-child* { +stopped+ "Stopped" } { +suspended+ "Suspended" } { +running+ "Running" } - { +detached+ "Detached" } } at % ")" % drop @@ -51,7 +56,7 @@ M: walker-gadget focusable-child* [ walker-state-string ] curry ; : ( status continuation thread -- gadget ) - over walker-gadget construct-boa [ + over f walker-gadget construct-boa [ toolbar, g walker-gadget-status self f track, g walker-gadget-traceback 1 track, @@ -72,16 +77,20 @@ walker-gadget "toolbar" f { { T{ key-down f f "F1" } walker-help } } define-command-map -: walker-window ( -- ) - f f 2dup start-walker-thread - [ ] keep thread-name open-status-window ; +: walker-for-thread? ( thread gadget -- ? ) + { + { [ dup walker-gadget? not ] [ 2drop f ] } + { [ dup walker-gadget-closing? ] [ 2drop f ] } + { [ t ] [ walker-gadget-thread eq? ] } + } cond ; -[ [ walker-window ] with-ui ] new-walker-hook set-global +: find-walker-window ( thread -- world/f ) + [ swap walker-for-thread? ] curry find-window ; + +: walker-window ( status continuation thread -- ) + [ ] [ thread-name ] bi open-status-window ; [ - [ - >r dup walker-gadget? - [ walker-gadget-thread r> eq? ] - [ r> 2drop f ] if - ] curry find-window raise-window + dup find-walker-window dup + [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if ] show-walker-hook set-global