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 : 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 : new-thread ( quot name class -- thread )
108 \ thread counter >>id
109 H{ } clone >>variables
110 <box> >>context ; inline
112 : <thread> ( quot name -- thread )
113 \ thread new-thread ;
115 : resume ( thread -- )
116 f >>state run-queue push-front ;
118 : resume-now ( thread -- )
119 f >>state run-queue push-back ;
121 : resume-with ( obj thread -- )
122 f >>state 2array run-queue push-front ;
124 : sleep-time ( -- nanos/f )
126 { [ run-queue deque-empty? not ] [ 0 ] }
127 { [ sleep-queue heap-empty? ] [ f ] }
128 [ sleep-queue heap-peek nip nano-count [-] ]
131 : interrupt ( thread -- )
133 dup sleep-entry>> [ sleep-queue heap-delete ] when*
142 : schedule-sleep ( thread dt -- )
143 dupd sleep-queue heap-push* >>sleep-entry drop ;
145 : expire-sleep? ( -- ? )
146 sleep-queue dup heap-empty?
147 [ drop f ] [ heap-peek nip nano-count <= ] if ;
149 : expire-sleep ( thread -- )
150 f >>sleep-entry resume ;
152 : expire-sleep-loop ( -- )
154 [ sleep-queue heap-pop drop expire-sleep ]
165 : no-runnable-threads ( -- ) die ;
167 GENERIC: (next) ( obj thread -- obj' )
171 [ context>> box> set-context ]
172 [ t >>runnable drop [start] start-context ] if ;
174 : (stop) ( obj thread -- * )
176 [ context>> box> set-context-and-delete ]
177 [ t >>runnable drop [start] start-context-and-delete ] if ;
179 : next ( -- obj thread )
182 dup array? [ first2 ] [ [ f ] dip ] if
189 self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
192 : suspend ( state -- obj )
194 [ context ] dip context>> >box
197 : yield ( -- ) self resume f suspend drop ;
199 GENERIC: sleep-until ( n/f -- )
201 M: integer sleep-until
202 [ self ] dip schedule-sleep "sleep" suspend drop ;
205 drop "standby" suspend drop ;
207 GENERIC: sleep ( dt -- )
210 >integer nano-count + sleep-until ;
212 : (spawn) ( thread -- )
213 [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
215 : spawn ( quot name -- thread )
216 <thread> [ (spawn) ] keep ;
218 : spawn-server ( quot name -- thread )
219 [ '[ _ loop ] ] dip spawn ;
221 : in-thread ( quot -- )
223 '[ _ set-datastack @ ]
224 "Thread" spawn drop ;
226 GENERIC: error-in-thread ( error thread -- )
230 : init-thread-state ( -- )
231 H{ } clone 64 set-special-object
232 <dlist> 65 set-special-object
233 <min-heap> 66 set-special-object ;
235 : init-initial-thread ( -- )
236 [ ] "Initial" <thread>
238 [ initial-thread set-global ]
243 : init-threads ( -- )
245 init-initial-thread ;
249 [ init-threads ] "threads" add-startup-hook