steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
core/threads/threads-tests.factor
View File

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

71
core/threads/threads.factor
View File

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

18
extra/ui/tools/interactor/interactor-tests.factor
View File

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

75
extra/ui/tools/interactor/interactor.factor
View File

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

19
extra/ui/tools/listener/listener-tests.factor
View File

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

61
extra/ui/tools/listener/listener.factor
View File

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