1
2;; The vector of place locals is similar to the set of virtual
3;; registers, but the array can be shared by multiple Scheme threads
4;; that are all in the same place.
5
6;; The first slot in the vector holds a hash table for allocated
7;; place-local values, the last is used by "async-callback.ss", and
8;; the rest are used by the thread, io, etc., layers for directly
9;; accessed variables.
10
11(define NUM-PLACE-REGISTERS 128) ; 3 through 126 available for subsystems
12
13(define LOCAL_TABLE-INDEX 0)
14(define ASYNC-CALLBACK-REGISTER-INDEX 1)
15;; index 2 is available
16
17(define-virtual-register place-registers (#%make-vector NUM-PLACE-REGISTERS 0))
18(define place-register-inits (#%make-vector NUM-PLACE-REGISTERS 0))
19
20(define (init-place-locals!)
21  (#%vector-set! (place-registers) LOCAL_TABLE-INDEX (make-weak-hasheq)))
22
23(define-record place-local (default-v))
24
25(define (unsafe-make-place-local v)
26  (make-place-local v))
27
28(define (unsafe-place-local-ref pl)
29  (let ([v (hash-ref (#%vector-ref (place-registers) LOCAL_TABLE-INDEX) pl none)])
30    (if (eq? v none)
31        (place-local-default-v pl)
32        v)))
33
34(define (unsafe-place-local-set! pl v)
35  (hash-set! (#%vector-ref (place-registers) LOCAL_TABLE-INDEX) pl v))
36
37(define (place-local-register-ref i)
38  (#%vector-ref (place-registers) i))
39
40(define (place-local-register-set! i v)
41  (#%vector-set! (place-registers) i v))
42
43(define (place-local-register-init! i v)
44  (place-local-register-set! i v)
45  (#%vector-set! place-register-inits i v))
46
47(define (get-place-registers)
48  (place-registers))
49
50(define (set-place-registers! vec)
51  (place-registers vec))
52
53;; ----------------------------------------
54
55(define place-async-callback-queue
56  (case-lambda
57   [() (let ([v (#%vector-ref (place-registers) ASYNC-CALLBACK-REGISTER-INDEX)])
58         (if (eqv? v 0)
59             #f
60             v))]
61   [(v) (#%vector-set! (place-registers) ASYNC-CALLBACK-REGISTER-INDEX v)]))
62
63;; ----------------------------------------
64
65(define place-specific-table (unsafe-make-place-local #f))
66
67(define (unsafe-get-place-table)
68  (with-interrupts-disabled
69   (or (unsafe-place-local-ref place-specific-table)
70       (let ([ht (make-hasheq)])
71         (unsafe-place-local-set! place-specific-table ht)
72         ht))))
73
74;; ----------------------------------------
75
76(define-thread-local place-esc-box (box #f))
77
78(meta-cond
79 [(threaded?)
80  (define (place-enabled?) #t)
81  (define (fork-place thunk finish-proc)
82    (do-prepare-for-place)
83    (fork-thread (lambda ()
84                   (collect-trip-for-allocating-places! +1)
85                   (thread-preserve-ownership!) ; encourages parallel GC
86                   (init-virtual-registers)
87                   (place-registers (vector-copy place-register-inits))
88                   (root-thread-cell-values (make-empty-thread-cell-values))
89                   (init-place-locals!)
90                   (register-as-place-main!)
91                   (async-callback-place-init!)
92                   (let ([result (call/cc
93                                  (lambda (esc)
94                                    (set-box! place-esc-box esc)
95                                    (thunk)
96                                    0))])
97                     (finish-proc result)
98                     (collect-trip-for-allocating-places! -1)
99                     (do-destroy-place)))))
100  ;; Must be called within an engine, used for memory accounting:
101  (define (current-place-roots)
102    (list (place-registers)
103          (current-engine-thread-cell-values)))]
104 [else
105  (define (place-enabled?) #f)
106  (define (fork-place thunk finish-proc) #f)
107  (define (current-place-roots) '())])
108
109(define do-prepare-for-place void)
110(define (set-prepare-for-place! proc)
111  (set! do-prepare-for-place proc))
112
113(define do-place-get-inherit (lambda () (list)))
114(define (set-place-get-inherit! proc)
115  (set! do-place-get-inherit proc))
116
117(define do-start-place void)
118(define (set-start-place! proc)
119  (set! do-start-place proc))
120
121(define do-destroy-place void)
122(define (set-destroy-place! proc)
123  (set! do-destroy-place proc))
124
125(define (place-get-inherit)
126  (do-place-get-inherit))
127
128(define (start-place pch path sym in out err cust plumber inh)
129  (let ([finish (do-start-place pch path sym in out err cust plumber inh)])
130    (reset-async-callback-poll-wakeup!)
131    finish))
132
133(define (place-exit v)
134  (let ([esc (unbox place-esc-box)])
135    (if esc
136        (esc v)
137        (#%exit v))))
138
139(define place-shared (make-weak-eq-hashtable))
140
141(define (place-shared? v)
142  (with-global-lock
143   (hashtable-ref place-shared v #f)))
144
145(define (register-place-shared v)
146  (with-global-lock
147   (hashtable-set! place-shared v #t))
148  v)
149