Thread refactoring work in progress

core/threads/threads-tests.factor

@@ -1,5 +1,6 @@
 USING: namespaces io tools.test threads kernel
-concurrency.combinators math ;
+concurrency.combinators concurrency.promises locals math
+words ;
 IN: threads.tests
 
 3 "x" set
@@ -27,3 +28,16 @@ yield
         "i" tget
     ] parallel-map
 ] unit-test
+
+[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
+
+:: spawn-namespace-test ( -- )
+    [let | p [ <promise> ] g [ gensym ] |
+        [
+            g "x" set
+            [ "x" get p fulfill ] "B" spawn drop
+        ] with-scope
+        p ?promise g eq?
+    ] ;
+
+[ t ] [ spawn-namespace-test ] unit-test

core/threads/threads.factor

@@ -90,6 +90,8 @@ PRIVATE>
         [ sleep-queue heap-peek nip millis [-] ]
     } cond ;
 
+DEFER: stop
+
 <PRIVATE
 
 : schedule-sleep ( thread ms -- )
@@ -110,9 +112,19 @@ PRIVATE>
     [ ] while
     drop ;
 
-: next ( -- * )
+: start ( namestack thread -- )
-    expire-sleep-loop
+    [
-    run-queue dup dlist-empty? [
+        set-self
+        set-namestack
+        V{ } set-catchstack
+        { } set-retainstack
+        { } set-datastack
+        self quot>> [ call stop ] call-clear
+    ] 2 (throw) ;
+
+DEFER: next
+
+: no-runnable-threads ( -- * )
     ! We should never be in a state where the only threads
     ! are sleeping; the I/O wait thread is always runnable.
     ! However, if it dies, we handle this case
@@ -120,26 +132,34 @@ PRIVATE>
     !
     ! And if sleep-time outputs f, there are no sleeping
     ! threads either... so WTF.
-        drop sleep-time [ die 0 ] unless* (sleep) next
+    sleep-time [ die 0 ] unless* (sleep) next ;
-    ] [
+
-        pop-back
+: (next) ( arg thread -- * )
-        dup array? [ first2 ] [ f swap ] if dup set-self
     f >>state
-        continuation>> box>
+    dup set-self
-        continue-with
+    dup continuation>> ?box
+    [ nip continue-with ] [ drop start ] if ;
+
+: next ( -- * )
+    expire-sleep-loop
+    run-queue dup dlist-empty? [
+        drop no-runnable-threads
+    ] [
+        pop-back dup array? [ first2 ] [ f swap ] if (next)
     ] if ;
 
 PRIVATE>
 
 : stop ( -- )
-    self dup exit-handler>> call
+    self [ exit-handler>> call ] [ unregister-thread ] bi next ;
-    unregister-thread next ;
 
 : suspend ( quot state -- obj )
     [
-        self continuation>> >box
+        >r
-        self (>>state)
+        >r self swap call
-        self swap call next
+        r> self (>>state)
+        r> self continuation>> >box
+        next
     ] callcc1 2nip ; inline
 
 : yield ( -- ) [ resume ] f suspend drop ;
@@ -165,16 +185,7 @@ M: real sleep
     ] when drop ;
 
 : (spawn) ( thread -- )
-    [
+    [ register-thread ] [ namestack swap resume-with ] bi ;
-        resume-now [
-            dup set-self
-            dup register-thread
-            V{ } set-catchstack
-            { } set-retainstack
-            >r { } set-datastack r>
-            quot>> [ call stop ] call-clear
-        ] 1 (throw)
-    ] "spawn" suspend 2drop ;
 
 : spawn ( quot name -- thread )
     <thread> [ (spawn) ] keep ;
@@ -183,8 +194,8 @@ M: real sleep
     >r [ [ ] [ ] while ] curry r> spawn ;
 
 : in-thread ( quot -- )
-    >r datastack namestack r>
+    >r datastack r>
-    [ >r set-namestack set-datastack r> call ] 3curry
+    [ >r set-datastack r> call ] 2curry
     "Thread" spawn drop ;
 
 GENERIC: error-in-thread ( error thread -- )

extra/ui/tools/interactor/interactor-tests.factor

@@ -1,11 +1,11 @@
 IN: ui.tools.interactor.tests
 USING: ui.tools.interactor ui.gadgets.panes namespaces
 ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser ;
+tools.test kernel calendar parser accessors ;
 
-[
 \ <interactor> must-infer
 
+[
     [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
 
     [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
@@ -13,6 +13,7 @@ tools.test kernel calendar parser ;
     [ ] [ <promise> "promise" set ] unit-test
 
     [
+        self "interactor" get (>>thread)
         "interactor" get stream-read-quot "promise" get fulfill
     ] "Interactor test" spawn drop
 
@@ -27,3 +28,14 @@ tools.test kernel calendar parser ;
 
     [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
 ] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test

extra/ui/tools/interactor/interactor.factor

@@ -1,53 +1,53 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators continuations documents
- hashtables io io.styles kernel math
+hashtables io io.styles kernel math math.vectors models
-math.vectors models namespaces parser prettyprint quotations
+namespaces parser prettyprint quotations sequences strings
-sequences strings threads listener
+threads listener classes.tuple ui.commands ui.gadgets
-classes.tuple ui.commands ui.gadgets ui.gadgets.editors
+ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
+ui.gestures definitions calendar concurrency.flags
-definitions boxes calendar concurrency.flags ui.tools.workspace
+ui.tools.workspace accessors ;
-accessors ;
 IN: ui.tools.interactor
 
-TUPLE: interactor history output flag thread help ;
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor output history flag thread waiting help ;
+
+: register-self ( interactor -- )
+    self >>thread drop ;
 
 : interactor-continuation ( interactor -- continuation )
-    interactor-thread box-value
+    thread>> continuation>> value>> ;
-    thread-continuation box-value ;
 
 : interactor-busy? ( interactor -- ? )
-    interactor-thread box-full? not ;
+    #! We're busy if there's no thread to resume.
+    [ waiting>> ]
+    [ thread>> dup [ thread-registered? ] when ]
+    bi and not ;
 
 : interactor-use ( interactor -- seq )
     dup interactor-busy? [ drop f ] [
         use swap
-        interactor-continuation continuation-name
+        interactor-continuation name>>
         assoc-stack
     ] if ;
 
-: init-caret-help ( interactor -- )
+: <help-model> ( interactor -- model )
-    dup editor-caret 1/3 seconds <delay>
+    editor-caret 1/3 seconds <delay> ;
-    swap set-interactor-help ;
-
-: init-interactor-history ( interactor -- )
-    V{ } clone swap set-interactor-history ;
-
-: init-interactor-state ( interactor -- )
-    <flag> over set-interactor-flag
-    <box> swap set-interactor-thread ;
 
 : <interactor> ( output -- gadget )
     <source-editor>
     interactor construct-editor
-    tuck set-interactor-output
+        V{ } clone >>history
-    dup init-interactor-history
+        <flag> >>flag
-    dup init-interactor-state
+        dup <help-model> >>help
-    dup init-caret-help ;
+        swap >>output ;
 
 M: interactor graft*
-    dup delegate graft*
+    [ delegate graft* ] [ dup help>> add-connection ] bi ;
-    dup interactor-help add-connection ;
+
+M: interactor ungraft*
+    [ dup help>> remove-connection ] [ delegate ungraft ] bi ;
 
 : word-at-loc ( loc interactor -- word )
     over [
@@ -58,7 +58,7 @@ M: interactor graft*
     ] if ;
 
 M: interactor model-changed
-    2dup interactor-help eq? [
+    2dup help>> eq? [
         swap model-value over word-at-loc swap show-summary
     ] [
         delegate model-changed
@@ -69,7 +69,7 @@ M: interactor model-changed
     [ H{ { font-style bold } } format ] with-nesting ;
 
 : interactor-input. ( string interactor -- )
-    interactor-output [
+    output>> [
         dup string? [ dup write-input nl ] [ short. ] if
     ] with-stream* ;
 
@@ -77,7 +77,7 @@ M: interactor model-changed
     over empty? [ 2drop ] [ interactor-history push-new ] if ;
 
 : interactor-continue ( obj interactor -- )
-    interactor-thread box> resume-with ;
+    thread>> resume-with ;
 
 : clear-input ( interactor -- ) gadget-model clear-doc ;
 
@@ -99,10 +99,12 @@ M: interactor model-changed
     ] unless drop ;
 
 : interactor-yield ( interactor -- obj )
-    [
+    dup thread>> self eq? [
-        [ interactor-thread >box ] keep
+        t >>waiting
-        interactor-flag raise-flag
+        [ [ flag>> raise-flag ] curry "input" suspend ] keep
-    ] curry "input" suspend ;
+        f >>waiting
+        drop
+    ] [ drop f ] if ;
 
 M: interactor stream-readln
     [ interactor-yield ] keep interactor-finish
@@ -161,7 +163,8 @@ M: interactor stream-read-quot
     } cond ;
 
 M: interactor pref-dim*
-    0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
+    [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
+    vmax ;
 
 interactor "interactor" f {
     { T{ key-down f f "RET" } evaluate-input }

extra/ui/tools/listener/listener-tests.factor

@@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 tools.test ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic ;
+threads arrays generic threads accessors listener ;
 IN: ui.tools.listener.tests
 
 [ f ] [ "word" source-editor command-map empty? ] unit-test
@@ -33,4 +33,21 @@ IN: ui.tools.listener.tests
         "i" get gadget-model doc-end
         "i" get editor-caret* =
     ] unit-test
+
+    ! Race condition discovered by SimonRC
+    [ ] [
+        [
+            "listener" get input>>
+            [ stream-read-quot drop ]
+            [ stream-read-quot drop ] bi
+        ] "OH, HAI" spawn drop
+    ] unit-test
+
+    [ ] [ "listener" get clear-output ] unit-test
+
+    [ ] [ "listener" get restart-listener ] unit-test
+
+    [ ] [ 1000 sleep ] unit-test
+
+    [ ] [ "listener" get com-end ] unit-test
 ] with-grafted-gadget

extra/ui/tools/listener/listener.factor

@@ -16,13 +16,11 @@ TUPLE: listener-gadget input output stack ;
     <scrolling-pane> g-> set-listener-gadget-output
     <scroller> "Output" <labelled-gadget> 1 track, ;
 
-: listener-stream ( listener -- stream )
+: <listener-stream> ( listener -- stream )
-    dup listener-gadget-input
+    [ input>> ] [ output>> <pane-stream> ] bi <duplex-stream> ;
-    swap listener-gadget-output <pane-stream>
-    <duplex-stream> ;
 
 : <listener-input> ( listener -- gadget )
-    listener-gadget-output <pane-stream> <interactor> ;
+    output>> <pane-stream> <interactor> ;
 
 : listener-input, ( -- )
     g <listener-input> g-> set-listener-gadget-input
@@ -34,31 +32,29 @@ TUPLE: listener-gadget input output stack ;
    "cookbook" ($link) "." print nl ;
 
 M: listener-gadget focusable-child*
-    listener-gadget-input ;
+    input>> ;
 
 M: listener-gadget call-tool* ( input listener -- )
-    >r input-string r> listener-gadget-input set-editor-string ;
+    >r string>> r> input>> set-editor-string ;
 
 M: listener-gadget tool-scroller
-    listener-gadget-output find-scroller ;
+    output>> find-scroller ;
 
 : wait-for-listener ( listener -- )
     #! Wait for the listener to start.
-    listener-gadget-input interactor-flag wait-for-flag ;
+    input>> flag>> wait-for-flag ;
 
 : workspace-busy? ( workspace -- ? )
-    workspace-listener listener-gadget-input interactor-busy? ;
+    listener>> input>> interactor-busy? ;
 
 : listener-input ( string -- )
-    get-workspace
+    get-workspace listener>> input>> set-editor-string ;
-    workspace-listener
-    listener-gadget-input set-editor-string ;
 
 : (call-listener) ( quot listener -- )
-    listener-gadget-input interactor-call ;
+    input>> interactor-call ;
 
 : call-listener ( quot -- )
-    [ workspace-busy? not ] get-workspace* workspace-listener
+    [ workspace-busy? not ] get-workspace* listener>>
     [ dup wait-for-listener (call-listener) ] 2curry
     "Listener call" spawn drop ;
 
@@ -70,8 +66,7 @@ M: listener-operation invoke-command ( target command -- )
 
 : eval-listener ( string -- )
     get-workspace
-    workspace-listener
+    listener>> input>> [ set-editor-string ] keep
-    listener-gadget-input [ set-editor-string ] keep
     evaluate-input ;
 
 : listener-run-files ( seq -- )
@@ -82,10 +77,10 @@ M: listener-operation invoke-command ( target command -- )
     ] if ;
 
 : com-end ( listener -- )
-    listener-gadget-input interactor-eof ;
+    input>> interactor-eof ;
 
 : clear-output ( listener -- )
-    listener-gadget-output pane-clear ;
+    output>> pane-clear ;
 
 \ clear-output H{ { +listener+ t } } define-command
 
@@ -148,22 +143,27 @@ M: stack-display tool-scroller
     swap show-tool inspect-object ;
 
 : listener-thread ( listener -- )
-    dup listener-stream [
+    dup <listener-stream> [
-        dup [ ui-listener-hook ] curry listener-hook set
+        [ [  ui-listener-hook ] curry  listener-hook set ]
-        dup [ ui-error-hook ] curry error-hook set
+        [ [     ui-error-hook ] curry     error-hook set ]
-        [ ui-inspector-hook ] curry inspector-hook set
+        [ [ ui-inspector-hook ] curry inspector-hook set ] tri
         welcome.
         listener
     ] with-stream* ;
 
 : start-listener-thread ( listener -- )
-    [ listener-thread ] curry "Listener" spawn drop ;
+    [
+        [ input>> register-self ] [ listener-thread ] bi
+    ] curry "Listener" spawn drop ;
 
 : restart-listener ( listener -- )
     #! Returns when listener is ready to receive input.
-    dup com-end dup clear-output
+    {
-    dup start-listener-thread
+        [ com-end ]
-    wait-for-listener ;
+        [ clear-output ]
+        [ start-listener-thread ]
+        [ wait-for-listener ]
+    } cleave ;
 
 : init-listener ( listener -- )
     f <model> swap set-listener-gadget-stack ;
@@ -189,10 +189,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
     [ default-gesture-handler ] [ 3drop f ] if ;
 
 M: listener-gadget graft*
-    dup delegate graft*
+    [ delegate graft* ] [ restart-listener ] bi ;
-    dup listener-gadget-input interactor-thread ?box 2drop
-    restart-listener ;
 
 M: listener-gadget ungraft*
-    dup com-end
+    [ com-end ] [ delegate ungraft* ] bi ;
-    delegate ungraft* ;