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