basis/threads/threads.factor

   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 ;
   8 IN: threads
   9
  10 <PRIVATE
  11
  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
  16
  17 : set-context ( obj context -- obj' )
  18     (set-context) ; inline
  19
  20 : start-context ( obj quot: ( obj -- * ) -- obj' )
  21     (start-context) ; inline
  22
  23 : set-context-and-delete ( obj context -- * )
  24     (set-context-and-delete) ; inline
  25
  26 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
  27     (start-context-and-delete) ; inline
  28
  29 ! Context introspection
  30 : namestack-for ( context -- namestack )
  31     [ 0 ] dip context-object-for ;
  32
  33 : catchstack-for ( context -- catchstack )
  34     [ 1 ] dip context-object-for ;
  35
  36 : continuation-for ( context -- continuation )
  37     {
  38         [ datastack-for ]
  39         [ callstack-for ]
  40         [ retainstack-for ]
  41         [ namestack-for ]
  42         [ catchstack-for ]
  43     } cleave <continuation> ;
  44
  45 PRIVATE>
  46
  47 SYMBOL: initial-thread
  48
  49 TUPLE: thread
  50 { name string }
  51 { quot callable initial: [ ] }
  52 { exit-handler callable initial: [ ] }
  53 { id integer }
  54 { context box }
  55 state
  56 runnable
  57 mailbox
  58 { variables hashtable }
  59 sleep-entry ;
  60
  61 : self ( -- thread )
  62     63 special-object { thread } declare ; inline
  63
  64 : thread-continuation ( thread -- continuation )
  65     context>> check-box value>> continuation-for ;
  66
  67 ! Thread-local storage
  68 : tnamespace ( -- assoc )
  69     self variables>> ; inline
  70
  71 : tget ( key -- value )
  72     tnamespace at ;
  73
  74 : tset ( value key -- )
  75     tnamespace set-at ;
  76
  77 : tchange ( key quot -- )
  78     [ tnamespace ] dip change-at ; inline
  79
  80 : threads ( -- assoc )
  81     64 special-object { hashtable } declare ; inline
  82
  83 : thread-registered? ( thread -- ? )
  84     id>> threads key? ;
  85
  86 <PRIVATE
  87
  88 : register-thread ( thread -- )
  89     dup id>> threads set-at ;
  90
  91 : unregister-thread ( thread -- )
  92     id>> threads delete-at ;
  93
  94 : set-self ( thread -- ) 63 set-special-object ; inline
  95
  96 PRIVATE>
  97
  98 : run-queue ( -- dlist )
  99     65 special-object { dlist } declare ; inline
 100
 101 : sleep-queue ( -- heap )
 102     66 special-object { min-heap } declare ; inline
 103
 104 : new-thread ( quot name class -- thread )
 105     new
 106         swap >>name
 107         swap >>quot
 108         \ thread counter >>id
 109         H{ } clone >>variables
 110         <box> >>context ; inline
 111
 112 : <thread> ( quot name -- thread )
 113     \ thread new-thread ;
 114
 115 : resume ( thread -- )
 116     f >>state run-queue push-front ;
 117
 118 : resume-now ( thread -- )
 119     f >>state run-queue push-back ;
 120
 121 : resume-with ( obj thread -- )
 122     f >>state 2array run-queue push-front ;
 123
 124 : sleep-time ( -- nanos/f )
 125     {
 126         { [ run-queue deque-empty? not ] [ 0 ] }
 127         { [ sleep-queue heap-empty? ] [ f ] }
 128         [ sleep-queue heap-peek nip nano-count [-] ]
 129     } cond ;
 130
 131 : interrupt ( thread -- )
 132     dup state>> [
 133         dup sleep-entry>> [ sleep-queue heap-delete ] when*
 134         f >>sleep-entry
 135         dup resume
 136     ] when drop ;
 137
 138 DEFER: stop
 139
 140 <PRIVATE
 141
 142 : schedule-sleep ( thread dt -- )
 143     dupd sleep-queue heap-push* >>sleep-entry drop ;
 144
 145 : expire-sleep? ( -- ? )
 146     sleep-queue dup heap-empty?
 147     [ drop f ] [ heap-peek nip nano-count <= ] if ;
 148
 149 : expire-sleep ( thread -- )
 150     f >>sleep-entry resume ;
 151
 152 : expire-sleep-loop ( -- )
 153     [ expire-sleep? ]
 154     [ sleep-queue heap-pop drop expire-sleep ]
 155     while ;
 156
 157 CONSTANT: [start]
 158     [
 159         set-namestack
 160         init-catchstack
 161         self quot>> call
 162         stop
 163     ]
 164
 165 : no-runnable-threads ( -- ) die ;
 166
 167 GENERIC: (next) ( obj thread -- obj' )
 168
 169 M: thread (next)
 170     dup runnable>>
 171     [ context>> box> set-context ]
 172     [ t >>runnable drop [start] start-context ] if ;
 173
 174 : (stop) ( obj thread -- * )
 175     dup runnable>>
 176     [ context>> box> set-context-and-delete ]
 177     [ t >>runnable drop [start] start-context-and-delete ] if ;
 178
 179 : next ( -- obj thread )
 180     expire-sleep-loop
 181     run-queue pop-back
 182     dup array? [ first2 ] [ [ f ] dip ] if
 183     f >>state
 184     dup set-self ;
 185
 186 PRIVATE>
 187
 188 : stop ( -- * )
 189     self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi
 190     next (stop) ;
 191
 192 : suspend ( state -- obj )
 193     [ self ] dip >>state
 194     [ context ] dip context>> >box
 195     next (next) ;
 196
 197 : yield ( -- ) self resume f suspend drop ;
 198
 199 GENERIC: sleep-until ( n/f -- )
 200
 201 M: integer sleep-until
 202     [ self ] dip schedule-sleep "sleep" suspend drop ;
 203
 204 M: f sleep-until
 205     drop "standby" suspend drop ;
 206
 207 GENERIC: sleep ( dt -- )
 208
 209 M: real sleep
 210     >integer nano-count + sleep-until ;
 211
 212 : (spawn) ( thread -- )
 213     [ register-thread ] [ [ namestack ] dip resume-with ] bi ;
 214
 215 : spawn ( quot name -- thread )
 216     <thread> [ (spawn) ] keep ;
 217
 218 : spawn-server ( quot name -- thread )
 219     [ '[ _ loop ] ] dip spawn ;
 220
 221 : in-thread ( quot -- )
 222     [ datastack ] dip
 223     '[ _ set-datastack @ ]
 224     "Thread" spawn drop ;
 225
 226 GENERIC: error-in-thread ( error thread -- )
 227
 228 <PRIVATE
 229
 230 : init-thread-state ( -- )
 231     H{ } clone 64 set-special-object
 232     <dlist> 65 set-special-object
 233     <min-heap> 66 set-special-object ;
 234
 235 : init-initial-thread ( -- )
 236     [ ] "Initial" <thread>
 237     t >>runnable
 238     [ initial-thread set-global ]
 239     [ register-thread ]
 240     [ set-self ]
 241     tri ;
 242
 243 : init-threads ( -- )
 244     init-thread-state
 245     init-initial-thread ;
 246
 247 PRIVATE>
 248
 249 [ init-threads ] "threads" add-startup-hook