Fix a race condition

db4
Slava Pestov 2008-03-18 01:26:09 -05:00
parent 86221d57f3
commit 296a20767f
3 changed files with 69 additions and 67 deletions

View File

@ -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
] ;

View File

@ -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 ] }

View File

@ -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