Thread refactoring work in progress

db4
Slava Pestov 2008-04-27 03:16:12 -05:00
parent 7a7d7be324
commit 517671fad0
6 changed files with 159 additions and 105 deletions

View File

@ -1,5 +1,6 @@
USING: namespaces io tools.test threads kernel USING: namespaces io tools.test threads kernel
concurrency.combinators math ; concurrency.combinators concurrency.promises locals math
words ;
IN: threads.tests IN: threads.tests
3 "x" set 3 "x" set
@ -27,3 +28,16 @@ yield
"i" tget "i" tget
] parallel-map ] parallel-map
] unit-test ] 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

View File

@ -90,6 +90,8 @@ PRIVATE>
[ sleep-queue heap-peek nip millis [-] ] [ sleep-queue heap-peek nip millis [-] ]
} cond ; } cond ;
DEFER: stop
<PRIVATE <PRIVATE
: schedule-sleep ( thread ms -- ) : schedule-sleep ( thread ms -- )
@ -110,9 +112,19 @@ PRIVATE>
[ ] while [ ] while
drop ; 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 ! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable. ! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case ! However, if it dies, we handle this case
@ -120,26 +132,34 @@ PRIVATE>
! !
! And if sleep-time outputs f, there are no sleeping ! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF. ! 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 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 ; ] if ;
PRIVATE> PRIVATE>
: stop ( -- ) : stop ( -- )
self dup exit-handler>> call self [ exit-handler>> call ] [ unregister-thread ] bi next ;
unregister-thread next ;
: suspend ( quot state -- obj ) : 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 ] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ; : yield ( -- ) [ resume ] f suspend drop ;
@ -165,16 +185,7 @@ M: real sleep
] when drop ; ] when drop ;
: (spawn) ( thread -- ) : (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 ) : spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ; <thread> [ (spawn) ] keep ;
@ -183,8 +194,8 @@ M: real sleep
>r [ [ ] [ ] while ] curry r> spawn ; >r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- ) : 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 ; "Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- ) GENERIC: error-in-thread ( error thread -- )

View File

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

View File

@ -1,53 +1,53 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents 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 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-continuation ( interactor -- continuation )
interactor-thread box-value thread>> continuation>> value>> ;
thread-continuation box-value ;
: interactor-busy? ( interactor -- ? ) : 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 ) : interactor-use ( interactor -- seq )
dup interactor-busy? [ drop f ] [ dup interactor-busy? [ drop f ] [
use swap use swap
interactor-continuation continuation-name interactor-continuation name>>
assoc-stack assoc-stack
] if ; ] 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 ) : <interactor> ( output -- gadget )
<source-editor> <source-editor>
interactor construct-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* 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 ) : word-at-loc ( loc interactor -- word )
over [ over [
@ -58,7 +58,7 @@ M: interactor graft*
] if ; ] if ;
M: interactor model-changed M: interactor model-changed
2dup interactor-help eq? [ 2dup help>> eq? [
swap model-value over word-at-loc swap show-summary swap model-value over word-at-loc swap show-summary
] [ ] [
delegate model-changed delegate model-changed
@ -69,7 +69,7 @@ M: interactor model-changed
[ H{ { font-style bold } } format ] with-nesting ; [ H{ { font-style bold } } format ] with-nesting ;
: interactor-input. ( string interactor -- ) : interactor-input. ( string interactor -- )
interactor-output [ output>> [
dup string? [ dup write-input nl ] [ short. ] if dup string? [ dup write-input nl ] [ short. ] if
] with-stream* ; ] with-stream* ;
@ -77,7 +77,7 @@ M: interactor model-changed
over empty? [ 2drop ] [ interactor-history push-new ] if ; over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- ) : interactor-continue ( obj interactor -- )
interactor-thread box> resume-with ; thread>> resume-with ;
: clear-input ( interactor -- ) gadget-model clear-doc ; : clear-input ( interactor -- ) gadget-model clear-doc ;
@ -99,10 +99,12 @@ M: interactor model-changed
] unless drop ; ] unless drop ;
: interactor-yield ( interactor -- obj ) : 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 M: interactor stream-readln
[ interactor-yield ] keep interactor-finish [ interactor-yield ] keep interactor-finish
@ -161,7 +163,8 @@ M: interactor stream-read-quot
} cond ; } cond ;
M: interactor pref-dim* 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 { interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input } { T{ key-down f f "RET" } evaluate-input }

View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic ; threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test [ 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 gadget-model doc-end
"i" get editor-caret* = "i" get editor-caret* =
] unit-test ] 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 ] with-grafted-gadget

View File

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