blob: f99517710c30b3c078f912ebff5ea6d53ac47c4f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#lang racket
(require ffi/unsafe/atomic)
(require compatibility/mlist)
(require "../../shared/lists.rkt")
(define (parallel-execute ps)
(for-each
thread-wait
(map (lambda (thnk)
(thread thnk))
ps)))
(define (make-sleeper name)
(define (random-sleeper)
(let ((n 10))
(map
(lambda (i)
(display name)
(display " ")
(displayln i)
(sleep (random 0 2)))
(enumerate-interval 0 n))))
random-sleeper)
(define (clear! cell)
(set-mcar! cell false))
(define (test-and-set! cell)
(call-as-atomic
(lambda ()
(if (mcar cell)
true
(begin (set-mcar! cell true)
false)))))
(define (make-mutex-busy)
(let ((cell (mlist false)))
(define (the-mutex m)
(cond ((eq? m 'acquire)
(when (test-and-set! cell)
(the-mutex 'acquire)))
((eq? m 'release) (clear! cell))))
the-mutex))
(define (make-mutex)
(let ((the-mutex (make-semaphore 1)))
(define (dispatch m)
(cond ((eq? m 'acquire)
(semaphore-wait the-mutex))
((eq? m 'release)
(semaphore-post the-mutex))))
dispatch))
(define (make-serializer)
(let ((mutex (make-mutex)))
(lambda (p)
(define (serialized-p . args)
(mutex 'acquire)
(let ((val (apply p args)))
(mutex 'release)
val))
serialized-p)))
(when false
(let ((m (make-mutex)))
(parallel-execute
(lambda ()
(m 'acquire)
(println "acquired")
(sleep 5)
(m 'release)
(println "released"))
(lambda ()
(sleep 1)
(m 'acquire)
(println "acquired after other process")
(m 'release)))))
;; In the book there are only examples that mention that you can use atomic operations on a single processor and for multiple processors there are special instructions that are atomic.
;; But in the racket manual it seems like there is no mention of two processes sharing the same memory space (there is places which run as separate os processes, potentially on a different cpu native processor).
;; So we could get away with atomic mode instead of the n-mutex.
;; NOTE(): does this deadlock? There are two mutexes, but can two processes acquire one mutex and then get stuck waiting on the other?
(define (make-semaphore-retry-mutex n)
(let ((n-mutex (make-mutex))
(retry-mutex (make-mutex)))
(define (the-semaphore m)
(cond ((eq? m 'acquire)
(n-mutex 'acquire)
(if (<= n 0)
(begin
(n-mutex 'release)
(retry-mutex 'acquire)
(the-semaphore 'acquire))
(begin
(set! n (- n 1))
(n-mutex 'release))))
((eq? m 'release)
(n-mutex 'acquire)
(set! n (+ n 1))
(n-mutex 'release)
(retry-mutex 'release))))
the-semaphore))
(when false
(define s (make-semaphore-retry-mutex 3))
(parallel-execute (map (lambda (f) (lambda () (s 'acquire) (f) (s 'release)))
(map (lambda (n) (lambda () (for-each (lambda (i) (sleep 1) (print "thread: ") (print n) (print ", ") (println i)) (enumerate-interval 1 3))))
(enumerate-interval 1 10)))))
;; Assumes single time-sliced processor context
;; didn't feel like testing this one
(define (make-semaphore-test-and-set n)
(let ((retry-cell (mlist false))
(n-cell (mlist false)))
(define (the-semaphore m)
(cond ((eq? m 'acquire)
(cond ((test-and-set! retry-cell)
(the-semaphore 'acquire))
((> n 0)
(if (test-and-set! n-cell)
(begin
(the-semaphore 'acquire))
(begin
(set! n (- n 1))
(clear! n-cell)
(when (> n 0) (clear! retry-cell)))))
((<= n 0)
(clear! n-cell)
(the-semaphore 'acquire))))
((eq? m 'release)
(when (test-and-set! n-cell)
(the-semaphore 'release))
(set! n (+ n 1))
(clear! n-cell)
(clear! retry-cell))))
the-semaphore))
(when false
(define s (make-semaphore-test-and-set 3))
(parallel-execute (map (lambda (f) (lambda () (s 'acquire) (f) (s 'release)))
(map (lambda (n) (lambda () (for-each (lambda (i) (sleep 1) (print "thread: ") (print n) (print ", ") (println i)) (enumerate-interval 1 3))))
(enumerate-interval 1 5)))))
|
