1 ! Copyright (C) 2004, 2009 Slava Pestov.
2 ! Copyright (C) 2005 Mackenzie Straight.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays hashtables heaps kernel kernel.private math
5 namespaces sequences vectors continuations continuations.private
6 dlists assocs system combinators combinators.private init boxes
7 accessors math.order deques strings quotations fry ;
10 SYMBOL: initial-thread
14 { quot callable initial: [ ] }
15 { exit-handler callable initial: [ ] }
24 : self ( -- thread ) 63 getenv ; inline
26 ! Thread-local storage
27 : tnamespace ( -- assoc )
28 self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
30 : tget ( key -- value )
33 : tset ( value key -- )
36 : tchange ( key quot -- )
37 tnamespace swap change-at ; inline
39 : threads ( -- assoc ) 64 getenv ;
41 : thread ( id -- thread ) threads at ;
43 : thread-registered? ( thread -- ? )
46 ERROR: already-stopped thread ;
48 : check-unregistered ( thread -- thread )
49 dup thread-registered? [ already-stopped ] when ;
51 ERROR: not-running thread ;
53 : check-registered ( thread -- thread )
54 dup thread-registered? [ not-running ] unless ;
58 : register-thread ( thread -- )
59 check-unregistered dup id>> threads set-at ;
61 : unregister-thread ( thread -- )
62 check-registered id>> threads delete-at ;
64 : set-self ( thread -- ) 63 setenv ; inline
68 : new-thread ( quot name class -- thread )
73 <box> >>continuation ; inline
75 : <thread> ( quot name -- thread )
78 : run-queue ( -- dlist ) 65 getenv ;
80 : sleep-queue ( -- heap ) 66 getenv ;
82 : resume ( thread -- )
84 check-registered run-queue push-front ;
86 : resume-now ( thread -- )
88 check-registered run-queue push-back ;
90 : resume-with ( obj thread -- )
92 check-registered 2array run-queue push-front ;
94 : sleep-time ( -- us/f )
96 { [ run-queue deque-empty? not ] [ 0 ] }
97 { [ sleep-queue heap-empty? ] [ f ] }
98 [ sleep-queue heap-peek nip micros [-] ]
105 : schedule-sleep ( thread dt -- )
106 [ check-registered dup ] dip sleep-queue heap-push*
109 : expire-sleep? ( heap -- ? )
111 [ drop f ] [ heap-peek nip micros <= ] if ;
113 : expire-sleep ( thread -- )
114 f >>sleep-entry resume ;
116 : expire-sleep-loop ( -- )
118 [ dup expire-sleep? ]
119 [ dup heap-pop drop expire-sleep ]
123 : start ( namestack thread -- * )
130 self quot>> [ call stop ] call-clear
131 ] (( namestack thread -- * )) call-effect-unsafe ;
135 : no-runnable-threads ( -- * )
136 ! We should never be in a state where the only threads
137 ! are sleeping; the I/O wait thread is always runnable.
138 ! However, if it dies, we handle this case
141 ! And if sleep-time outputs f, there are no sleeping
142 ! threads either... so WTF.
143 sleep-time [ die 0 ] unless* (sleep) next ;
145 : (next) ( arg thread -- * )
149 continuation>> box> continue-with
156 run-queue dup deque-empty? [
157 drop no-runnable-threads
159 pop-back dup array? [ first2 ] [ f swap ] if (next)
165 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ;
167 : suspend ( quot state -- obj )
169 [ [ self swap call ] dip self (>>state) ] dip
170 self continuation>> >box
172 ] callcc1 2nip ; inline
174 : yield ( -- ) [ resume ] f suspend drop ;
176 GENERIC: sleep-until ( time/f -- )
178 M: integer sleep-until
179 '[ _ schedule-sleep ] "sleep" suspend drop ;
182 drop [ drop ] "interrupt" suspend drop ;
184 GENERIC: sleep ( dt -- )
187 micros + >integer sleep-until ;
189 : interrupt ( thread -- )
191 dup sleep-entry>> [ sleep-queue heap-delete ] when*
196 : (spawn) ( thread -- )
197 [ register-thread ] [ namestack swap resume-with ] bi ;
199 : spawn ( quot name -- thread )
200 <thread> [ (spawn) ] keep ;
202 : spawn-server ( quot name -- thread )
203 [ '[ _ loop ] ] dip spawn ;
205 : in-thread ( quot -- )
207 '[ _ set-datastack _ call ]
208 "Thread" spawn drop ;
210 GENERIC: error-in-thread ( error thread -- )
214 : init-threads ( -- )
218 initial-thread global
219 [ drop [ ] "Initial" <thread> ] cache
228 [ init-threads ] "threads" add-init-hook