1(library (thread) 2 (export) 3 (import (rename (chezpart) 4 [define chez:define]) 5 (rename (rumble) 6 [rumble:break-enabled-key break-enabled-key] 7 ;; Remapped to place-local register operations: 8 [unsafe-make-place-local rumble:unsafe-make-place-local] 9 [unsafe-place-local-ref rumble:unsafe-place-local-ref] 10 [unsafe-place-local-set! rumble:unsafe-place-local-set!] 11 ;; These are extracted via `#%linklet`: 12 [make-engine rumble:make-engine] 13 [engine-timeout rumble:engine-timeout] 14 [engine-return rumble:engine-return] 15 [engine-roots rumble:engine-roots] 16 [call-with-engine-completion rumble:call-with-engine-completion] 17 [call-with-current-continuation-roots rumble:call-with-current-continuation-roots] 18 [make-condition rumble:make-condition] 19 [condition-wait rumble:condition-wait] 20 [condition-signal rumble:condition-signal] 21 [condition-broadcast rumble:condition-broadcast] 22 [make-mutex rumble:make-mutex] 23 [mutex-acquire rumble:mutex-acquire] 24 [mutex-release rumble:mutex-release] 25 [pthread? rumble:thread?] 26 [fork-place rumble:fork-place] 27 [place-get-inherit rumble:place-get-inherit] 28 [start-place rumble:start-place] 29 [fork-pthread rumble:fork-thread] 30 [threaded? rumble:threaded?] 31 [get-thread-id rumble:get-thread-id] 32 [get-initial-pthread rumble:get-initial-pthread] 33 [current-place-roots rumble:current-place-roots] 34 [call-as-asynchronous-callback rumble:call-as-asynchronous-callback] 35 [post-as-asynchronous-callback rumble:post-as-asynchronous-callback] 36 [set-ctl-c-handler! rumble:set-ctl-c-handler!] 37 [set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!] 38 [set-reachable-size-increments-callback! rumble:set-reachable-size-increments-callback!] 39 [set-custodian-memory-use-proc! rumble:set-custodian-memory-use-proc!] 40 [set-immediate-allocation-check-proc! rumble:set-immediate-allocation-check-proc!] 41 [continuation-current-primitive rumble:continuation-current-primitive])) 42 43 (include "place-register.ss") 44 (define-place-register-define place:define thread-register-start thread-register-count) 45 46 ;; Special handling of `current-atomic` to use the last virtual register, and 47 ;; similarr for other. We rely on the fact that the register's default value is 0 48 ;; or the rumble layer installs a suitable default. Also, force inline a few 49 ;; functions and handle other special cases. Note that the implementation of 50 ;; `start-atomic` and `end-atomic` rely on some specific parameters being thread 51 ;; registers so that the functions can be safely called from any Scheme thread. 52 (define-syntax (define stx) 53 (let ([define-as-virtual-register 54 (lambda (stx n) 55 (with-syntax ([(_ id _) stx] 56 [n (datum->syntax #'here n)]) 57 #'(define-syntax id 58 (syntax-rules () 59 [(_) (virtual-register n)] 60 [(_ v) (set-virtual-register! n v)]))))]) 61 (syntax-case stx (current-atomic end-atomic-callback current-future$1 62 lambda make-pthread-parameter unsafe-make-place-local) 63 ;; Recognize definition of `current-atomic`: 64 [(_ current-atomic (make-pthread-parameter 0)) 65 (define-as-virtual-register stx current-atomic-virtual-register)] 66 ;; Recognize definition of `end-atomic-callback`: 67 [(_ end-atomic-callback (make-pthread-parameter 0)) 68 (define-as-virtual-register stx end-atomic-virtual-register)] 69 ;; Recognize definition of `current-future`: 70 [(_ current-future$1 (make-pthread-parameter #f)) 71 (define-as-virtual-register stx current-future-virtual-register)] 72 ;; Force-inline `start-atomic`, `end-atomic`, and `future-barrier`, 73 ;; at least within the core layers: 74 [(_ id (lambda () expr ...)) 75 (#%memq (syntax->datum #'id) '(start-atomic end-atomic future-barrier)) 76 #'(begin 77 (define proc (let ([id (lambda () expr ...)]) id)) 78 (define-syntax (id stx) 79 (syntax-case stx () 80 [(_) #'(let () expr ...)] 81 [_ #'proc])))] 82 ;; Workaround for redirected access of `unsafe-make-place-local` from #%pthread: 83 [(_ alias-id unsafe-make-place-local) #'(begin)] 84 ;; Chain to place-register handling: 85 [(_ . rest) #'(place:define . rest)]))) 86 87 ;; This implementation of `sleep`, `get-wakeup-handle`, and `wakeup` is relevant 88 ;; only for running the places part of the thread demo. The relevant callbacks get 89 ;; replaced by the "io" layer to use rktio-based functions. 90 (define sleep-interrupted (rumble:unsafe-make-place-local #f)) 91 (define (sleep secs) 92 (let ([isecs (inexact->exact (floor secs))] 93 [zero-secs (make-time 'time-duration 0 0)] 94 [pause-secs (make-time 'time-duration 100000 0)]) 95 (let loop ([all-secs (make-time 'time-duration 96 (inexact->exact (floor (* (- secs isecs) 1e9))) 97 isecs)]) 98 (unless (or (time<=? all-secs zero-secs) 99 (let ([b (rumble:unsafe-place-local-ref sleep-interrupted)]) 100 (and b (unbox b)))) 101 (#%sleep pause-secs) 102 (loop (subtract-duration all-secs pause-secs)))) 103 (let ([b (rumble:unsafe-place-local-ref sleep-interrupted)]) 104 (when b 105 (set-box! b #f))))) 106 (define (get-wakeup-handle) 107 (let ([b (rumble:unsafe-place-local-ref sleep-interrupted)]) 108 (or b 109 (begin 110 ;; There's a race condition here.. Avoid triggering it 111 ;; in the thread demo. 112 (rumble:unsafe-place-local-set! sleep-interrupted (box #f)) 113 (get-wakeup-handle))))) 114 (define (wakeup b) 115 (set-box! b #t)) 116 117 (define (primitive-table key) 118 (case key 119 [(|#%pthread|) 120 ;; Entries in the `#%pthread` table are referenced more 121 ;; directly in "compiled/thread.scm". To make that work, the 122 ;; entries need to be either primitives in all Racket 123 ;; implemenations or registered as built-in names with the 124 ;; expander and listed in "primitive/internal.ss". 125 (hasheq 126 'make-pthread-parameter make-pthread-parameter 127 'unsafe-root-continuation-prompt-tag unsafe-root-continuation-prompt-tag 128 'break-enabled-key break-enabled-key 129 'engine-block engine-block 130 ;; These are actually redirected by "place-register.ss", but 131 ;; we list them here for compatibility with the bootstrapping 132 ;; variant of `#%pthread` 133 'unsafe-make-place-local rumble:unsafe-make-place-local 134 'unsafe-place-local-ref rumble:unsafe-place-local-ref 135 'unsafe-place-local-set! rumble:unsafe-place-local-set!)] 136 [(|#%engine|) 137 (hasheq 138 'make-engine rumble:make-engine 139 'engine-timeout rumble:engine-timeout 140 'engine-return rumble:engine-return 141 'engine-roots rumble:engine-roots 142 'call-with-engine-completion rumble:call-with-engine-completion 143 'set-ctl-c-handler! rumble:set-ctl-c-handler! 144 'poll-will-executors poll-will-executors 145 'make-will-executor rumble:make-will-executor 146 'make-late-will-executor rumble:make-late-will-executor 147 'will-executor? rumble:will-executor? 148 'will-register rumble:will-register 149 'will-try-execute rumble:will-try-execute 150 'set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook! 151 'continuation-marks rumble:continuation-marks 152 'set-reachable-size-increments-callback! rumble:set-reachable-size-increments-callback! 153 'set-custodian-memory-use-proc! rumble:set-custodian-memory-use-proc! 154 'set-immediate-allocation-check-proc! rumble:set-immediate-allocation-check-proc! 155 'exn:break/non-engine exn:break 156 'exn:break:hang-up/non-engine exn:break:hang-up 157 'exn:break:terminate/non-engine exn:break:terminate 158 'current-process-milliseconds cpu-time 159 'poll-async-callbacks poll-async-callbacks 160 'disable-interrupts disable-interrupts 161 'enable-interrupts enable-interrupts 162 'sleep sleep 163 'get-wakeup-handle get-wakeup-handle 164 'wakeup wakeup 165 'fork-place rumble:fork-place 166 'place-get-inherit rumble:place-get-inherit 167 'start-place rumble:start-place 168 'fork-pthread rumble:fork-thread 169 'get-initial-place rumble:get-initial-pthread 170 'current-place-roots rumble:current-place-roots 171 'call-with-current-continuation-roots rumble:call-with-current-continuation-roots 172 'exit place-exit 173 'pthread? rumble:thread? 174 'call-as-asynchronous-callback rumble:call-as-asynchronous-callback 175 'post-as-asynchronous-callback rumble:post-as-asynchronous-callback 176 'get-thread-id rumble:get-thread-id 177 'make-condition rumble:make-condition 178 'condition-wait rumble:condition-wait 179 'condition-signal rumble:condition-signal 180 'condition-broadcast rumble:condition-broadcast 181 'make-mutex rumble:make-mutex 182 'mutex-acquire rumble:mutex-acquire 183 'mutex-release rumble:mutex-release 184 'threaded? rumble:threaded? 185 'continuation-current-primitive rumble:continuation-current-primitive 186 'prop:unsafe-authentic-override prop:unsafe-authentic-override)] 187 [else #f])) 188 189 ;; Tie knots: 190 (define (check-for-break) (1/check-for-break)) 191 (define (break-enabled) (1/break-enabled)) 192 193 (include "include.ss") 194 (include-generated "thread.scm") 195 196 (set-engine-exit-handler! 197 (lambda (v) 198 (|#%app| (|#%app| 1/exit-handler) v))) 199 200 (set-scheduler-lock-callbacks! (lambda () (1/make-semaphore 1)) 201 unsafe-semaphore-wait 202 unsafe-semaphore-post) 203 204 (set-scheduler-atomicity-callbacks! (lambda () 205 (current-atomic (fx+ (current-atomic) 1))) 206 (lambda () 207 (current-atomic (fx- (current-atomic) 1)))) 208 209 (set-future-callbacks! future-block future-sync current-future-prompt)) 210