1 ! Copyright (C) 2004, 2011 Slava Pestov.
2 ! Copyright (C) 2005 Mackenzie Straight.
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors alien.private arrays assocs boxes combinators
5 continuations continuations.private deques dlists hashtables
6 heaps init kernel kernel.private math math.order namespaces
7 quotations sequences strings system ;
11 PRIMITIVE: (set-context) ( obj context -- obj' )
12 PRIMITIVE: (set-context-and-delete) ( obj context -- * )
13 PRIMITIVE: (sleep) ( nanos -- )
14 PRIMITIVE: (start-context) ( obj quot -- obj' )
15 PRIMITIVE: (start-context-and-delete) ( obj quot -- * )
17 PRIMITIVE: context-object-for ( n context -- obj )
19 ! Wrap sub-primitives; we don't want them inlined into callers
20 ! since their behavior depends on what frames are on the callstack
21 : set-context ( obj context -- obj' )
22 (set-context) ; inline
24 : start-context ( obj quot: ( obj -- * ) -- obj' )
25 (start-context) ; inline
27 : set-context-and-delete ( obj context -- * )
28 (set-context-and-delete) ; inline
30 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
31 (start-context-and-delete) ; inline
33 ! Context introspection
34 : namestack-for ( context -- namestack )
35 [ CONTEXT-OBJ-NAMESTACK ] dip context-object-for ;
37 : catchstack-for ( context -- catchstack )
38 [ CONTEXT-OBJ-CATCHSTACK ] dip context-object-for ;
40 : continuation-for ( context -- continuation )
47 } cleave <continuation> ;
51 SYMBOL: initial-thread
55 { quot callable initial: [ ] }
56 { exit-handler callable initial: [ ] }
62 { variables hashtable }
66 OBJ-CURRENT-THREAD special-object { thread } declare ; inline
68 : thread-continuation ( thread -- continuation )
69 context>> check-box value>> continuation-for ;
71 ! Thread-local storage
72 : tnamespace ( -- assoc )
73 self variables>> ; inline
75 : tget ( key -- value )
78 : tset ( value key -- )
81 : tchange ( ..a key quot: ( ..a value -- ..b newvalue ) -- ..b )
82 [ tnamespace ] dip change-at ; inline
84 : threads ( -- assoc )
85 OBJ-THREADS special-object { hashtable } declare ; inline
87 : thread-registered? ( thread -- ? )
92 : register-thread ( thread -- )
93 dup id>> threads set-at ;
95 : unregister-thread ( thread -- )
96 id>> threads delete-at ;
98 : set-self ( thread -- )
99 OBJ-CURRENT-THREAD set-special-object ; inline
103 : run-queue ( -- dlist )
104 OBJ-RUN-QUEUE special-object { dlist } declare ; inline
106 : sleep-queue ( -- heap )
107 OBJ-SLEEP-QUEUE special-object { min-heap } declare ; inline
109 : waiting-callbacks ( -- assoc )
110 OBJ-WAITING-CALLBACKS special-object { hashtable } declare ; inline
112 : new-thread ( quot name class -- thread )
116 \ thread counter >>id
117 H{ } clone >>variables
118 <box> >>context ; inline
120 : <thread> ( quot name -- thread )
121 \ thread new-thread ;
123 : resume ( thread -- )
124 f >>state run-queue push-front ;
126 : resume-now ( thread -- )
127 f >>state run-queue push-back ;
129 : resume-with ( obj thread -- )
130 f >>state 2array run-queue push-front ;
132 : sleep-time ( -- nanos/f )
134 { [ current-callback waiting-callbacks key? ] [ 0 ] }
135 { [ run-queue deque-empty? not ] [ 0 ] }
136 { [ sleep-queue heap-empty? ] [ f ] }
137 [ sleep-queue heap-peek nip nano-count [-] ]
140 : interrupt ( thread -- )
143 [ sleep-queue heap-delete ] when* f
144 ] change-sleep-entry dup resume
151 : schedule-sleep ( thread dt -- )
152 dupd sleep-queue heap-push* >>sleep-entry drop ;
154 : expire-sleep? ( -- ? )
155 sleep-queue dup heap-empty?
156 [ drop f ] [ heap-peek nip nano-count <= ] if ;
158 : expire-sleep ( thread -- )
159 f >>sleep-entry resume ;
161 : expire-sleep-loop ( -- )
163 [ sleep-queue heap-pop drop expire-sleep ]
174 GENERIC: (next) ( obj thread -- obj' )
178 [ context>> box> set-context ]
179 [ t >>runnable drop [start] start-context ] if ;
181 : (stop) ( obj thread -- * )
183 [ context>> box> set-context-and-delete ]
184 [ t >>runnable drop [start] start-context-and-delete ] if ;
186 : wake-up-callbacks ( -- )
187 current-callback waiting-callbacks delete-at*
188 [ resume-now ] [ drop ] if ;
190 : next ( -- obj thread )
194 dup array? [ first2 ] [ [ f ] dip ] if
201 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
204 : suspend ( state -- obj )
206 [ context ] dip context>> >box
210 self resume f suspend drop ;
212 GENERIC: sleep-until ( n/f -- )
214 M: integer sleep-until
215 [ self ] dip schedule-sleep "sleep" suspend drop ;
218 drop "standby" suspend drop ;
220 GENERIC: sleep ( dt -- )
223 >integer nano-count + sleep-until ;
225 : (spawn) ( thread -- )
226 [ register-thread ] [ [ get-namestack ] dip resume-with ] bi ;
228 : spawn ( quot name -- thread )
229 <thread> [ (spawn) ] keep ;
231 : spawn-server ( quot name -- thread )
232 [ '[ _ loop ] ] dip spawn ;
234 : in-thread ( quot -- )
235 [ get-datastack ] dip
236 '[ _ set-datastack @ ]
237 "Thread" spawn drop ;
241 : init-thread-state ( -- )
242 H{ } clone OBJ-THREADS set-special-object
243 <dlist> OBJ-RUN-QUEUE set-special-object
244 <min-heap> OBJ-SLEEP-QUEUE set-special-object
245 H{ } clone OBJ-WAITING-CALLBACKS set-special-object ;
247 : init-initial-thread ( -- )
248 [ ] "Initial" <thread>
250 [ initial-thread set-global ]
255 : init-threads ( -- )
257 init-initial-thread ;
259 : wait-for-callback ( callback -- )
260 self swap waiting-callbacks set-at
261 "Callback return" suspend drop ;
265 STARTUP-HOOK: init-threads