-! Copyright (C) 2004, 2010 Slava Pestov.
+! Copyright (C) 2004, 2011 Slava Pestov.
! Copyright (C) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables heaps kernel kernel.private math
-namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes accessors math.order
-deques strings quotations fry ;
+USING: accessors alien.private arrays assocs boxes combinators
+continuations continuations.private deques dlists hashtables
+heaps kernel kernel.private math math.order namespaces
+quotations sequences strings system ;
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
: set-context ( obj context -- obj' )
- (set-context) ;
+ (set-context) ; inline
: start-context ( obj quot: ( obj -- * ) -- obj' )
- (start-context) ;
+ (start-context) ; inline
: set-context-and-delete ( obj context -- * )
- (set-context-and-delete) ;
+ (set-context-and-delete) ; inline
: start-context-and-delete ( obj quot: ( obj -- * ) -- * )
- (start-context-and-delete) ;
+ (start-context-and-delete) ; inline
! Context introspection
: namestack-for ( context -- namestack )
- [ 0 ] dip context-object-for ;
+ [ CONTEXT-OBJ-NAMESTACK ] dip context-object-for ;
: catchstack-for ( context -- catchstack )
- [ 1 ] dip context-object-for ;
+ [ CONTEXT-OBJ-CATCHSTACK ] dip context-object-for ;
: continuation-for ( context -- continuation )
{
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 )
- 63 special-object { thread } declare ; inline
+ OBJ-CURRENT-THREAD special-object { thread } declare ; inline
: thread-continuation ( thread -- continuation )
context>> check-box value>> continuation-for ;
: tset ( value key -- )
tnamespace set-at ;
-: tchange ( key quot -- )
+: tchange ( ..a key quot: ( ..a value -- ..b newvalue ) -- ..b )
[ tnamespace ] dip change-at ; inline
: threads ( -- assoc )
- 64 special-object { hashtable } declare ; inline
+ OBJ-THREADS special-object { hashtable } declare ; inline
: thread-registered? ( thread -- ? )
id>> threads key? ;
-ERROR: already-stopped thread ;
-
-: check-unregistered ( thread -- thread )
- dup thread-registered? [ already-stopped ] when ;
-
-ERROR: not-running thread ;
-
-: check-registered ( thread -- thread )
- dup thread-registered? [ not-running ] unless ;
-
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup id>> threads set-at ;
+ dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered id>> threads delete-at ;
+ id>> threads delete-at ;
-: set-self ( thread -- ) 63 set-special-object ; inline
+: set-self ( thread -- )
+ OBJ-CURRENT-THREAD set-special-object ; inline
PRIVATE>
: run-queue ( -- dlist )
- 65 special-object { dlist } declare ; inline
+ OBJ-RUN-QUEUE special-object { dlist } declare ; inline
: sleep-queue ( -- heap )
- 66 special-object { dlist } declare ; inline
+ OBJ-SLEEP-QUEUE special-object { min-heap } declare ; inline
+
+: waiting-callbacks ( -- assoc )
+ OBJ-WAITING-CALLBACKS special-object { hashtable } declare ; inline
: new-thread ( quot name class -- thread )
new
\ thread new-thread ;
: resume ( thread -- )
- f >>state
- check-registered run-queue push-front ;
+ f >>state run-queue push-front ;
: resume-now ( thread -- )
- f >>state
- check-registered run-queue push-back ;
+ f >>state run-queue push-back ;
: resume-with ( obj thread -- )
- f >>state
- check-registered 2array run-queue push-front ;
+ f >>state 2array run-queue push-front ;
: sleep-time ( -- nanos/f )
{
+ { [ current-callback waiting-callbacks key? ] [ 0 ] }
{ [ run-queue deque-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
[ sleep-queue heap-peek nip nano-count [-] ]
: interrupt ( thread -- )
dup state>> [
- dup sleep-entry>> [ sleep-queue heap-delete ] when*
- f >>sleep-entry
- dup resume
+ [
+ [ sleep-queue heap-delete ] when* f
+ ] change-sleep-entry dup resume
] when drop ;
DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
- [ check-registered dup ] dip sleep-queue heap-push*
- >>sleep-entry drop ;
+ dupd sleep-queue heap-push* >>sleep-entry drop ;
-: expire-sleep? ( heap -- ? )
- dup heap-empty?
+: expire-sleep? ( -- ? )
+ sleep-queue dup heap-empty?
[ drop f ] [ heap-peek nip nano-count <= ] if ;
: expire-sleep ( thread -- )
f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
- sleep-queue
- [ dup expire-sleep? ]
- [ dup heap-pop drop expire-sleep ]
- while
- drop ;
+ [ expire-sleep? ]
+ [ sleep-queue heap-pop drop expire-sleep ]
+ while ;
CONSTANT: [start]
[
stop
]
-: no-runnable-threads ( -- ) die ;
+GENERIC: (next) ( obj thread -- obj' )
-: (next) ( obj thread -- obj' )
+M: thread (next)
dup runnable>>
[ context>> box> set-context ]
[ t >>runnable drop [start] start-context ] if ;
[ context>> box> set-context-and-delete ]
[ t >>runnable drop [start] start-context-and-delete ] if ;
+: wake-up-callbacks ( -- )
+ current-callback waiting-callbacks delete-at*
+ [ resume-now ] [ drop ] if ;
+
: next ( -- obj thread )
expire-sleep-loop
+ wake-up-callbacks
run-queue pop-back
dup array? [ first2 ] [ [ f ] dip ] if
f >>state
[ context ] dip context>> >box
next (next) ;
-: yield ( -- ) self resume f suspend drop ;
+: yield ( -- )
+ self resume f suspend drop ;
GENERIC: sleep-until ( n/f -- )
>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 ;
-GENERIC: error-in-thread ( error thread -- )
-
<PRIVATE
: init-thread-state ( -- )
- H{ } clone 64 set-special-object
- <dlist> 65 set-special-object
- <min-heap> 66 set-special-object ;
+ H{ } clone OBJ-THREADS set-special-object
+ <dlist> OBJ-RUN-QUEUE set-special-object
+ <min-heap> OBJ-SLEEP-QUEUE set-special-object
+ H{ } clone OBJ-WAITING-CALLBACKS set-special-object ;
: init-initial-thread ( -- )
[ ] "Initial" <thread>
init-thread-state
init-initial-thread ;
+: wait-for-callback ( callback -- )
+ self swap waiting-callbacks set-at
+ "Callback return" suspend drop ;
+
PRIVATE>
-[ init-threads ] "threads" add-startup-hook
+STARTUP-HOOK: init-threads
projects / factor.git / blobdiff