basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / threads / threads.factor

diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor
index 27eb8cfaad9b347f9b0760020be40e64564af555..d56a7928ad3bb98037a875a1980999e74489b4e9 100644 (file)
--- a/basis/threads/threads.factor
+++ b/basis/threads/threads.factor
@@ -1,20 +1,23 @@
 ! Copyright (C) 2004, 2011 Slava Pestov.
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.private 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 ;
-FROM: assocs => change-at ;
+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
-: context ( -- context )
-    2 context-object ; inline
-
 : set-context ( obj context -- obj' )
     (set-context) ; inline
 
@@ -29,10 +32,10 @@ IN: threads
 
 ! 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 )
     {
@@ -48,19 +51,19 @@ PRIVATE>
 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 ;
@@ -79,7 +82,7 @@ sleep-entry ;
     [ 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? ;
@@ -92,18 +95,19 @@ sleep-entry ;
 : unregister-thread ( thread -- )
     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 { min-heap } declare ; inline
+    OBJ-SLEEP-QUEUE special-object { min-heap } declare ; inline
 
 : waiting-callbacks ( -- assoc )
-    68 special-object { hashtable } declare ; inline
+    OBJ-WAITING-CALLBACKS special-object { hashtable } declare ; inline
 
 : new-thread ( quot name class -- thread )
     new
@@ -135,9 +139,9 @@ PRIVATE>
 
 : 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
@@ -167,8 +171,6 @@ CONSTANT: [start]
         stop
     ]
 
-: no-runnable-threads ( -- ) die ;
-
 GENERIC: (next) ( obj thread -- obj' )
 
 M: thread (next)
@@ -204,7 +206,8 @@ PRIVATE>
     [ context ] dip context>> >box
     next (next) ;
 
-: yield ( -- ) self resume f suspend drop ;
+: yield ( -- )
+    self resume f suspend drop ;
 
 GENERIC: sleep-until ( n/f -- )
 
@@ -220,7 +223,7 @@ M: real sleep
     >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 ;
@@ -229,17 +232,17 @@ M: real sleep
     [ '[ _ loop ] ] dip spawn ;
 
 : in-thread ( quot -- )
-    [ datastack ] dip
+    [ get-datastack ] dip
     '[ _ set-datastack @ ]
     "Thread" spawn drop ;
 
 <PRIVATE
 
 : init-thread-state ( -- )
-    H{ } clone 64 set-special-object
-    <dlist> 65 set-special-object
-    <min-heap> 66 set-special-object
-    H{ } clone 68 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>
@@ -259,4 +262,4 @@ M: real sleep
 
 PRIVATE>
 
-[ init-threads ] "threads" add-startup-hook
+STARTUP-HOOK: init-threads