! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.private arrays assocs boxes combinators
-continuations continuations.private deques dlists fry hashtables
-heaps init kernel kernel.private math math.order namespaces
+continuations continuations.private deques dlists hashtables
+heaps kernel kernel.private math math.order namespaces
quotations sequences strings system ;
-FROM: assocs => change-at ;
IN: threads
<PRIVATE
+PRIMITIVE: (set-context) ( obj context -- obj' )
+PRIMITIVE: (set-context-and-delete) ( obj context -- * )
+PRIMITIVE: (sleep) ( nanos -- )
+PRIMITIVE: (start-context) ( obj quot -- obj' )
+PRIMITIVE: (start-context-and-delete) ( obj quot -- * )
+
+PRIMITIVE: context-object-for ( n context -- obj )
! Wrap sub-primitives; we don't want them inlined into callers
! since their behavior depends on what frames are on the callstack
-: context ( -- context )
- CONTEXT-OBJ-CONTEXT context-object ; inline
-
: set-context ( obj context -- obj' )
(set-context) ; inline
SYMBOL: initial-thread
TUPLE: thread
-{ name string }
-{ quot callable initial: [ ] }
-{ exit-handler callable initial: [ ] }
-{ id integer }
-{ context box }
-state
-runnable
-mailbox
-{ variables hashtable }
-sleep-entry ;
+ { name string }
+ { quot callable initial: [ ] }
+ { exit-handler callable initial: [ ] }
+ { id integer }
+ { context box }
+ state
+ runnable
+ mailbox
+ { variables hashtable }
+ sleep-entry ;
: self ( -- thread )
OBJ-CURRENT-THREAD special-object { thread } declare ; inline
>integer nano-count + sleep-until ;
: (spawn) ( thread -- )
- [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
+ [ register-thread ] [ [ get-namestack ] dip resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
[ '[ _ loop ] ] dip spawn ;
: in-thread ( quot -- )
- [ datastack ] dip
+ [ get-datastack ] dip
'[ _ set-datastack @ ]
"Thread" spawn drop ;
PRIVATE>
-[ init-threads ] "threads" add-startup-hook
+STARTUP-HOOK: init-threads