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 fry 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 -- * )
16 PRIMITIVE: callstack-for ( context -- array )
17 PRIMITIVE: context-object-for ( n context -- obj )
18 PRIMITIVE: datastack-for ( context -- array )
19 PRIMITIVE: retainstack-for ( context -- array )
21 ! Wrap sub-primitives; we don't want them inlined into callers
22 ! since their behavior depends on what frames are on the callstack
23 : context ( -- context )
24 CONTEXT-OBJ-CONTEXT context-object ; inline
26 : set-context ( obj context -- obj' )
27 (set-context) ; inline
29 : start-context ( obj quot: ( obj -- * ) -- obj' )
30 (start-context) ; inline
32 : set-context-and-delete ( obj context -- * )
33 (set-context-and-delete) ; inline
35 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
36 (start-context-and-delete) ; inline
38 ! Context introspection
39 : namestack-for ( context -- namestack )
40 [ CONTEXT-OBJ-NAMESTACK ] dip context-object-for ;
42 : catchstack-for ( context -- catchstack )
43 [ CONTEXT-OBJ-CATCHSTACK ] dip context-object-for ;
45 : continuation-for ( context -- continuation )
52 } cleave <continuation> ;
56 SYMBOL: initial-thread
60 { quot callable initial: [ ] }
61 { exit-handler callable initial: [ ] }
67 { variables hashtable }
71 OBJ-CURRENT-THREAD special-object { thread } declare ; inline
73 : thread-continuation ( thread -- continuation )
74 context>> check-box value>> continuation-for ;
76 ! Thread-local storage
77 : tnamespace ( -- assoc )
78 self variables>> ; inline
80 : tget ( key -- value )
83 : tset ( value key -- )
86 : tchange ( ..a key quot: ( ..a value -- ..b newvalue ) -- ..b )
87 [ tnamespace ] dip change-at ; inline
89 : threads ( -- assoc )
90 OBJ-THREADS special-object { hashtable } declare ; inline
92 : thread-registered? ( thread -- ? )
97 : register-thread ( thread -- )
98 dup id>> threads set-at ;
100 : unregister-thread ( thread -- )
101 id>> threads delete-at ;
103 : set-self ( thread -- )
104 OBJ-CURRENT-THREAD set-special-object ; inline
108 : run-queue ( -- dlist )
109 OBJ-RUN-QUEUE special-object { dlist } declare ; inline
111 : sleep-queue ( -- heap )
112 OBJ-SLEEP-QUEUE special-object { min-heap } declare ; inline
114 : waiting-callbacks ( -- assoc )
115 OBJ-WAITING-CALLBACKS special-object { hashtable } declare ; inline
117 : new-thread ( quot name class -- thread )
121 \ thread counter >>id
122 H{ } clone >>variables
123 <box> >>context ; inline
125 : <thread> ( quot name -- thread )
126 \ thread new-thread ;
128 : resume ( thread -- )
129 f >>state run-queue push-front ;
131 : resume-now ( thread -- )
132 f >>state run-queue push-back ;
134 : resume-with ( obj thread -- )
135 f >>state 2array run-queue push-front ;
137 : sleep-time ( -- nanos/f )
139 { [ current-callback waiting-callbacks key? ] [ 0 ] }
140 { [ run-queue deque-empty? not ] [ 0 ] }
141 { [ sleep-queue heap-empty? ] [ f ] }
142 [ sleep-queue heap-peek nip nano-count [-] ]
145 : interrupt ( thread -- )
148 [ sleep-queue heap-delete ] when* f
149 ] change-sleep-entry dup resume
156 : schedule-sleep ( thread dt -- )
157 dupd sleep-queue heap-push* >>sleep-entry drop ;
159 : expire-sleep? ( -- ? )
160 sleep-queue dup heap-empty?
161 [ drop f ] [ heap-peek nip nano-count <= ] if ;
163 : expire-sleep ( thread -- )
164 f >>sleep-entry resume ;
166 : expire-sleep-loop ( -- )
168 [ sleep-queue heap-pop drop expire-sleep ]
179 GENERIC: (next) ( obj thread -- obj' )
183 [ context>> box> set-context ]
184 [ t >>runnable drop [start] start-context ] if ;
186 : (stop) ( obj thread -- * )
188 [ context>> box> set-context-and-delete ]
189 [ t >>runnable drop [start] start-context-and-delete ] if ;
191 : wake-up-callbacks ( -- )
192 current-callback waiting-callbacks delete-at*
193 [ resume-now ] [ drop ] if ;
195 : next ( -- obj thread )
199 dup array? [ first2 ] [ [ f ] dip ] if
206 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
209 : suspend ( state -- obj )
211 [ context ] dip context>> >box
215 self resume f suspend drop ;
217 GENERIC: sleep-until ( n/f -- )
219 M: integer sleep-until
220 [ self ] dip schedule-sleep "sleep" suspend drop ;
223 drop "standby" suspend drop ;
225 GENERIC: sleep ( dt -- )
228 >integer nano-count + sleep-until ;
230 : (spawn) ( thread -- )
231 [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
233 : spawn ( quot name -- thread )
234 <thread> [ (spawn) ] keep ;
236 : spawn-server ( quot name -- thread )
237 [ '[ _ loop ] ] dip spawn ;
239 : in-thread ( quot -- )
241 '[ _ set-datastack @ ]
242 "Thread" spawn drop ;
246 : init-thread-state ( -- )
247 H{ } clone OBJ-THREADS set-special-object
248 <dlist> OBJ-RUN-QUEUE set-special-object
249 <min-heap> OBJ-SLEEP-QUEUE set-special-object
250 H{ } clone OBJ-WAITING-CALLBACKS set-special-object ;
252 : init-initial-thread ( -- )
253 [ ] "Initial" <thread>
255 [ initial-thread set-global ]
260 : init-threads ( -- )
262 init-initial-thread ;
264 : wait-for-callback ( callback -- )
265 self swap waiting-callbacks set-at
266 "Callback return" suspend drop ;
270 [ init-threads ] "threads" add-startup-hook