Fix a race condition

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 [ <promise> ]
+    [let | p [ <promise> ] |
-           s [ f <model> ]
-           c [ f <model> ] |
         [
             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
+        thread-variables walker-continuation swap at
-
+        model-value continuation-data
-        c model-value continuation-data
     ] ;

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 ! ( status continuation thread -- )
-SYMBOL: show-walker-hook ! ( 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
+        f <model>
-        walker-thread tget
+        f <model>
+        2dup start-walker-thread
     ] if* ;
 
-: break ( -- )
+USING: io.streams.c prettyprint ;
-    continuation callstack over set-continuation-call
 
-    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? ] [
+    [ status +stopped+ eq? ]
-        [
+    [ [ drop f ] handle-synchronous ]
-            {
+    [ ] while ;
-                { detach [ detach-msg ] }
-                [ drop ]
-            } case 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 ] }

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
-    [ swap walker-gadget-thread send-synchronous drop ]
+    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 ( -- )
+: walker-for-thread? ( thread gadget -- ? )
-    f <model> f <model> 2dup start-walker-thread
+    {
-    [ <walker-gadget> ] keep thread-name open-status-window ;
+        { [ 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 ;
 
 [
-    [
+    dup find-walker-window dup
-        >r dup walker-gadget?
+    [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
-        [ walker-gadget-thread r> eq? ]
-        [ r> 2drop f ] if
-    ] curry find-window raise-window
 ] show-walker-hook set-global