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: alien.private arrays hashtables heaps kernel kernel.private
5 math 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 : context ( -- context )
15 2 context-object ; inline
17 : set-context ( obj context -- obj' )
18 (set-context) ; inline
20 : start-context ( obj quot: ( obj -- * ) -- obj' )
21 (start-context) ; inline
23 : set-context-and-delete ( obj context -- * )
24 (set-context-and-delete) ; inline
26 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
27 (start-context-and-delete) ; inline
29 ! Context introspection
30 : namestack-for ( context -- namestack )
31 [ 0 ] dip context-object-for ;
33 : catchstack-for ( context -- catchstack )
34 [ 1 ] dip context-object-for ;
36 : continuation-for ( context -- continuation )
43 } cleave <continuation> ;
47 SYMBOL: initial-thread
51 { quot callable initial: [ ] }
52 { exit-handler callable initial: [ ] }
58 { variables hashtable }
62 63 special-object { thread } declare ; inline
64 : thread-continuation ( thread -- continuation )
65 context>> check-box value>> continuation-for ;
67 ! Thread-local storage
68 : tnamespace ( -- assoc )
69 self variables>> ; inline
71 : tget ( key -- value )
74 : tset ( value key -- )
77 : tchange ( key quot -- )
78 [ tnamespace ] dip change-at ; inline
80 : threads ( -- assoc )
81 64 special-object { hashtable } declare ; inline
83 : thread-registered? ( thread -- ? )
88 : register-thread ( thread -- )
89 dup id>> threads set-at ;
91 : unregister-thread ( thread -- )
92 id>> threads delete-at ;
94 : set-self ( thread -- ) 63 set-special-object ; inline
98 : run-queue ( -- dlist )
99 65 special-object { dlist } declare ; inline
101 : sleep-queue ( -- heap )
102 66 special-object { min-heap } declare ; inline
104 : waiting-callbacks ( -- assoc )
105 68 special-object { hashtable } declare ; inline
107 : new-thread ( quot name class -- thread )
111 \ thread counter >>id
112 H{ } clone >>variables
113 <box> >>context ; inline
115 : <thread> ( quot name -- thread )
116 \ thread new-thread ;
118 : resume ( thread -- )
119 f >>state run-queue push-front ;
121 : resume-now ( thread -- )
122 f >>state run-queue push-back ;
124 : resume-with ( obj thread -- )
125 f >>state 2array run-queue push-front ;
127 : sleep-time ( -- nanos/f )
129 { [ current-callback waiting-callbacks key? ] [ 0 ] }
130 { [ run-queue deque-empty? not ] [ 0 ] }
131 { [ sleep-queue heap-empty? ] [ f ] }
132 [ sleep-queue heap-peek nip nano-count [-] ]
135 : interrupt ( thread -- )
137 dup sleep-entry>> [ sleep-queue heap-delete ] when*
146 : schedule-sleep ( thread dt -- )
147 dupd sleep-queue heap-push* >>sleep-entry drop ;
149 : expire-sleep? ( -- ? )
150 sleep-queue dup heap-empty?
151 [ drop f ] [ heap-peek nip nano-count <= ] if ;
153 : expire-sleep ( thread -- )
154 f >>sleep-entry resume ;
156 : expire-sleep-loop ( -- )
158 [ sleep-queue heap-pop drop expire-sleep ]
169 : no-runnable-threads ( -- ) die ;
171 GENERIC: (next) ( obj thread -- obj' )
175 [ context>> box> set-context ]
176 [ t >>runnable drop [start] start-context ] if ;
178 : (stop) ( obj thread -- * )
180 [ context>> box> set-context-and-delete ]
181 [ t >>runnable drop [start] start-context-and-delete ] if ;
183 : wake-up-callbacks ( -- )
184 current-callback waiting-callbacks delete-at*
185 [ resume-now ] [ drop ] if ;
187 : next ( -- obj thread )
191 dup array? [ first2 ] [ [ f ] dip ] if
198 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
201 : suspend ( state -- obj )
203 [ context ] dip context>> >box
206 : yield ( -- ) self resume f suspend drop ;
208 GENERIC: sleep-until ( n/f -- )
210 M: integer sleep-until
211 [ self ] dip schedule-sleep "sleep" suspend drop ;
214 drop "standby" suspend drop ;
216 GENERIC: sleep ( dt -- )
219 >integer nano-count + sleep-until ;
221 : (spawn) ( thread -- )
222 [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
224 : spawn ( quot name -- thread )
225 <thread> [ (spawn) ] keep ;
227 : spawn-server ( quot name -- thread )
228 [ '[ _ loop ] ] dip spawn ;
230 : in-thread ( quot -- )
232 '[ _ set-datastack @ ]
233 "Thread" spawn drop ;
235 GENERIC: error-in-thread ( error thread -- )
239 : init-thread-state ( -- )
240 H{ } clone 64 set-special-object
241 <dlist> 65 set-special-object
242 <min-heap> 66 set-special-object
243 H{ } clone 68 set-special-object ;
245 : init-initial-thread ( -- )
246 [ ] "Initial" <thread>
248 [ initial-thread set-global ]
253 : init-threads ( -- )
255 init-initial-thread ;
257 : wait-for-callback ( callback -- )
258 self swap waiting-callbacks set-at
259 "Callback return" suspend drop ;
263 [ init-threads ] "threads" add-startup-hook