Thread refactoring work in progress
parent
7a7d7be324
commit
517671fad0
|
@ -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
|
||||
|
|
|
@ -90,6 +90,8 @@ PRIVATE>
|
|||
[ sleep-queue heap-peek nip millis [-] ]
|
||||
} cond ;
|
||||
|
||||
DEFER: stop
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: schedule-sleep ( thread ms -- )
|
||||
|
@ -110,36 +112,54 @@ PRIVATE>
|
|||
[ ] while
|
||||
drop ;
|
||||
|
||||
: start ( namestack thread -- )
|
||||
[
|
||||
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
|
||||
! semi-gracefully.
|
||||
!
|
||||
! And if sleep-time outputs f, there are no sleeping
|
||||
! threads either... so WTF.
|
||||
sleep-time [ die 0 ] unless* (sleep) next ;
|
||||
|
||||
: (next) ( arg thread -- * )
|
||||
f >>state
|
||||
dup set-self
|
||||
dup continuation>> ?box
|
||||
[ nip continue-with ] [ drop start ] if ;
|
||||
|
||||
: next ( -- * )
|
||||
expire-sleep-loop
|
||||
run-queue dup dlist-empty? [
|
||||
! 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
|
||||
! semi-gracefully.
|
||||
!
|
||||
! And if sleep-time outputs f, there are no sleeping
|
||||
! threads either... so WTF.
|
||||
drop sleep-time [ die 0 ] unless* (sleep) next
|
||||
drop no-runnable-threads
|
||||
] [
|
||||
pop-back
|
||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||
f >>state
|
||||
continuation>> box>
|
||||
continue-with
|
||||
pop-back dup array? [ first2 ] [ f swap ] if (next)
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stop ( -- )
|
||||
self dup exit-handler>> call
|
||||
unregister-thread next ;
|
||||
self [ exit-handler>> call ] [ unregister-thread ] bi next ;
|
||||
|
||||
: suspend ( quot state -- obj )
|
||||
[
|
||||
self continuation>> >box
|
||||
self (>>state)
|
||||
self swap call next
|
||||
>r
|
||||
>r self swap call
|
||||
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 -- )
|
||||
[
|
||||
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 ;
|
||||
[ register-thread ] [ namestack swap resume-with ] bi ;
|
||||
|
||||
: 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 set-namestack set-datastack r> call ] 3curry
|
||||
>r datastack r>
|
||||
[ >r set-datastack r> call ] 2curry
|
||||
"Thread" spawn drop ;
|
||||
|
||||
GENERIC: error-in-thread ( error thread -- )
|
||||
|
|
|
@ -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
|
||||
|
||||
[
|
||||
\ <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
|
||||
|
|
|
@ -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
|
||||
math.vectors models namespaces parser prettyprint quotations
|
||||
sequences strings threads listener
|
||||
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
definitions boxes calendar concurrency.flags ui.tools.workspace
|
||||
accessors ;
|
||||
hashtables io io.styles kernel math math.vectors models
|
||||
namespaces parser prettyprint quotations sequences strings
|
||||
threads listener classes.tuple ui.commands ui.gadgets
|
||||
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
|
||||
ui.gestures definitions calendar concurrency.flags
|
||||
ui.tools.workspace 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 box-value ;
|
||||
thread>> continuation>> 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 -- )
|
||||
dup 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 ;
|
||||
: <help-model> ( interactor -- model )
|
||||
editor-caret 1/3 seconds <delay> ;
|
||||
|
||||
: <interactor> ( output -- gadget )
|
||||
<source-editor>
|
||||
interactor construct-editor
|
||||
tuck set-interactor-output
|
||||
dup init-interactor-history
|
||||
dup init-interactor-state
|
||||
dup init-caret-help ;
|
||||
V{ } clone >>history
|
||||
<flag> >>flag
|
||||
dup <help-model> >>help
|
||||
swap >>output ;
|
||||
|
||||
M: interactor graft*
|
||||
dup delegate graft*
|
||||
dup interactor-help add-connection ;
|
||||
[ delegate graft* ] [ dup help>> add-connection ] bi ;
|
||||
|
||||
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 )
|
||||
[
|
||||
[ interactor-thread >box ] keep
|
||||
interactor-flag raise-flag
|
||||
] curry "input" suspend ;
|
||||
dup thread>> self eq? [
|
||||
t >>waiting
|
||||
[ [ flag>> raise-flag ] curry "input" suspend ] keep
|
||||
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 }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
dup listener-gadget-input
|
||||
swap listener-gadget-output <pane-stream>
|
||||
<duplex-stream> ;
|
||||
: <listener-stream> ( listener -- stream )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi <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
|
||||
workspace-listener
|
||||
listener-gadget-input set-editor-string ;
|
||||
get-workspace listener>> 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-gadget-input [ set-editor-string ] keep
|
||||
listener>> 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 [ ui-listener-hook ] curry listener-hook set
|
||||
dup [ ui-error-hook ] curry error-hook set
|
||||
[ ui-inspector-hook ] curry inspector-hook set
|
||||
dup <listener-stream> [
|
||||
[ [ ui-listener-hook ] curry listener-hook set ]
|
||||
[ [ ui-error-hook ] curry error-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
|
||||
wait-for-listener ;
|
||||
{
|
||||
[ com-end ]
|
||||
[ 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*
|
||||
dup listener-gadget-input interactor-thread ?box 2drop
|
||||
restart-listener ;
|
||||
[ delegate graft* ] [ restart-listener ] bi ;
|
||||
|
||||
M: listener-gadget ungraft*
|
||||
dup com-end
|
||||
delegate ungraft* ;
|
||||
[ com-end ] [ delegate ungraft* ] bi ;
|
||||
|
|
Loading…
Reference in New Issue