From 517671fad00035ca4b272d1128849974229e55be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 27 Apr 2008 03:16:12 -0500
Subject: [PATCH] Thread refactoring work in progress
---
core/threads/threads-tests.factor | 16 +++-
core/threads/threads.factor | 71 ++++++++++--------
.../tools/interactor/interactor-tests.factor | 18 ++++-
extra/ui/tools/interactor/interactor.factor | 75 ++++++++++---------
extra/ui/tools/listener/listener-tests.factor | 23 +++++-
extra/ui/tools/listener/listener.factor | 61 +++++++--------
6 files changed, 159 insertions(+), 105 deletions(-)
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index 0ac607f0ed..0e33ccd94c 100755
--- a/core/threads/threads-tests.factor
+++ b/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
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index 2f9c3a73de..fc3915e462 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -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 -- )
diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
index 99c005451d..509543a20a 100755
--- a/extra/ui/tools/interactor/interactor-tests.factor
+++ b/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
[
- \ <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
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 3837ce2de1..734f6cb4b8 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/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
-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 }
diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor
index cc218533d8..2fae62a8fc 100755
--- a/extra/ui/tools/listener/listener-tests.factor
+++ b/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
@@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
[ "dup" ] [
\ dup word-completion-string
] unit-test
-
+
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
@@ -28,9 +28,26 @@ IN: ui.tools.listener.tests
[ ] [
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
] unit-test
-
+
[ t ] [
"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
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index d96270075f..9057e1c4bd 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/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 )
- 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 ;