Fix a race condition
parent
86221d57f3
commit
296a20767f
|
@ -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 [ <promise> ]
|
||||
s [ f <model> ]
|
||||
c [ f <model> ] |
|
||||
[let | p [ <promise> ] |
|
||||
[
|
||||
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
|
||||
] ;
|
||||
|
|
|
@ -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 <model>
|
||||
f <model>
|
||||
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 ] }
|
||||
|
|
|
@ -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 <filter> <label-control> ;
|
||||
|
||||
: <walker-gadget> ( status continuation thread -- gadget )
|
||||
over <traceback-gadget> walker-gadget construct-boa [
|
||||
over <traceback-gadget> f walker-gadget construct-boa [
|
||||
toolbar,
|
||||
g walker-gadget-status self <thread-status> 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 <model> f <model> 2dup start-walker-thread
|
||||
[ <walker-gadget> ] 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 -- )
|
||||
[ <walker-gadget> ] [ 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
|
||||
|
|
Loading…
Reference in New Issue