1 ! Copyright (C) 2004, 2010 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 init boxes accessors math.order
7 deques strings quotations fry ;
12 ! Wrap sub-primitives; we don't want them inlined into callers
13 ! since their behavior depends on what frames are on the callstack
14 : set-context ( obj context -- obj' )
17 : start-context ( obj quot: ( obj -- * ) -- obj' )
20 : set-context-and-delete ( obj context -- * )
21 (set-context-and-delete) ;
23 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
24 (start-context-and-delete) ;
26 ! Context introspection
27 : namestack-for ( context -- namestack )
28 [ 0 ] dip context-object-for ;
30 : catchstack-for ( context -- catchstack )
31 [ 1 ] dip context-object-for ;
33 : continuation-for ( context -- continuation )
40 } cleave <continuation> ;
44 SYMBOL: initial-thread
48 { quot callable initial: [ ] }
49 { exit-handler callable initial: [ ] }
55 { variables hashtable }
59 63 special-object { thread } declare ; inline
61 : thread-continuation ( thread -- continuation )
62 context>> check-box value>> continuation-for ;
64 ! Thread-local storage
65 : tnamespace ( -- assoc )
66 self variables>> ; inline
68 : tget ( key -- value )
71 : tset ( value key -- )
74 : tchange ( key quot -- )
75 [ tnamespace ] dip change-at ; inline
77 : threads ( -- assoc )
78 64 special-object { hashtable } declare ; inline
80 : thread-registered? ( thread -- ? )
83 ERROR: already-stopped thread ;
85 : check-unregistered ( thread -- thread )
86 dup thread-registered? [ already-stopped ] when ;
88 ERROR: not-running thread ;
90 : check-registered ( thread -- thread )
91 dup thread-registered? [ not-running ] unless ;
95 : register-thread ( thread -- )
96 check-unregistered dup id>> threads set-at ;
98 : unregister-thread ( thread -- )
99 check-registered id>> threads delete-at ;
101 : set-self ( thread -- ) 63 set-special-object ; inline
105 : run-queue ( -- dlist )
106 65 special-object { dlist } declare ; inline
108 : sleep-queue ( -- heap )
109 66 special-object { dlist } declare ; inline
111 : new-thread ( quot name class -- thread )
115 \ thread counter >>id
116 H{ } clone >>variables
117 <box> >>context ; inline
119 : <thread> ( quot name -- thread )
120 \ thread new-thread ;
122 : resume ( thread -- )
124 check-registered run-queue push-front ;
126 : resume-now ( thread -- )
128 check-registered run-queue push-back ;
130 : resume-with ( obj thread -- )
132 check-registered 2array run-queue push-front ;
134 : sleep-time ( -- nanos/f )
136 { [ run-queue deque-empty? not ] [ 0 ] }
137 { [ sleep-queue heap-empty? ] [ f ] }
138 [ sleep-queue heap-peek nip nano-count [-] ]
141 : interrupt ( thread -- )
143 dup sleep-entry>> [ sleep-queue heap-delete ] when*
152 : schedule-sleep ( thread dt -- )
153 [ check-registered dup ] dip sleep-queue heap-push*
156 : expire-sleep? ( heap -- ? )
158 [ drop f ] [ heap-peek nip nano-count <= ] if ;
160 : expire-sleep ( thread -- )
161 f >>sleep-entry resume ;
163 : expire-sleep-loop ( -- )
165 [ dup expire-sleep? ]
166 [ dup heap-pop drop expire-sleep ]
178 : no-runnable-threads ( -- ) die ;
180 : (next) ( obj thread -- obj' )
182 [ context>> box> set-context ]
183 [ t >>runnable drop [start] start-context ] if ;
185 : (stop) ( obj thread -- * )
187 [ context>> box> set-context-and-delete ]
188 [ t >>runnable drop [start] start-context-and-delete ] if ;
190 : next ( -- obj thread )
193 dup array? [ first2 ] [ [ f ] dip ] if
200 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
203 : suspend ( state -- obj )
205 [ context ] dip context>> >box
208 : yield ( -- ) self resume f suspend drop ;
210 GENERIC: sleep-until ( n/f -- )
212 M: integer sleep-until
213 [ self ] dip schedule-sleep "sleep" suspend drop ;
216 drop "standby" suspend drop ;
218 GENERIC: sleep ( dt -- )
221 >integer nano-count + sleep-until ;
223 : (spawn) ( thread -- )
224 [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
226 : spawn ( quot name -- thread )
227 <thread> [ (spawn) ] keep ;
229 : spawn-server ( quot name -- thread )
230 [ '[ _ loop ] ] dip spawn ;
232 : in-thread ( quot -- )
234 '[ _ set-datastack @ ]
235 "Thread" spawn drop ;
237 GENERIC: error-in-thread ( error thread -- )
241 : init-thread-state ( -- )
242 H{ } clone 64 set-special-object
243 <dlist> 65 set-special-object
244 <min-heap> 66 set-special-object ;
246 : init-initial-thread ( -- )
247 [ ] "Initial" <thread>
249 [ initial-thread set-global ]
254 : init-threads ( -- )
256 init-initial-thread ;
260 [ init-threads ] "threads" add-startup-hook