blob: 1f255710a80c54331e11f39ceaa585327e25481e (
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
|
(define-module (guix-build-coordinator utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-60)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (gcrypt random)
#:use-module (fibers)
#:use-module (fibers channels)
#:export (make-worker-thread-channel
call-with-worker-thread
random-v4-uuid))
(define %worker-thread-args
(make-parameter #f))
(define* (make-worker-thread-channel initializer
#:key (parallelism 1))
"Return a channel used to offload work to a dedicated thread. ARGS are the
arguments of the worker thread procedure."
(parameterize (((@@ (fibers internal) current-fiber) #f))
(let ((channel (make-channel)))
(for-each
(lambda _
(let ((args (initializer)))
(call-with-new-thread
(lambda ()
(parameterize ((%worker-thread-args args))
(let loop ()
(match (get-message channel)
(((? channel? reply) . (? procedure? proc))
(put-message reply
(catch #t
(lambda ()
(apply proc args))
(lambda (key . args)
(cons* 'worker-thread-error key args))))))
(loop)))))))
(iota parallelism))
channel)))
(define (call-with-worker-thread channel proc)
"Send PROC to the worker thread through CHANNEL. Return the result of PROC.
If already in the worker thread, call PROC immediately."
(let ((args (%worker-thread-args)))
(if args
(apply proc args)
(let ((reply (make-channel)))
(put-message channel (cons reply proc))
(match (get-message reply)
(('worker-thread-error key args ...)
(apply throw key args))
(result result))))))
(define (random-v4-uuid)
;; https://tools.ietf.org/html/rfc4122#page-14
;;
;; The pattern in characters is: 8, 4, 4, 4, 12
;; The pattern in bytes is: 4, 2, 2, 2, 6
;;
;; time-low "-" time-mid "-" time-high-and-version "-"
;; clock-seq-and-reserved clock-seq-low "-" node
;;
;; - Set the two most significant bits (bits 6 and 7) of the
;; clock_seq_hi_and_reserved to zero and one, respectively.
;; - Set the four most significant bits (bits 12 through 15) of the
;; time_hi_and_version field to the 4-bit version number from
;; Section 4.1.3.
(let* ((bytes 16)
(bv (gen-random-bv bytes)))
(let ((version 4)
(6th-byte (array-ref bv 6)) ; Most significant byte in
; time_hi_and_version
(8th-byte (array-ref bv 8))) ; Most significant byte in
; clock_seq_hi_and_reserved
(array-set!
bv
(logior (logand #b00001111 6th-byte)
(rotate-bit-field version 4 0 8))
6)
(array-set!
bv
;; Set bits 6 and 7 to 0 and 1 respectively
(logior #b10000000
(logand #b00111111
8th-byte))
8))
(let* ((int
(bytevector-uint-ref bv 0 (endianness big) bytes))
(hex-string
(format #f "~32,'0x" int)))
(string-join
(fold (lambda (part-length result)
(let ((start (string-length
(string-join result ""))))
(append
result
(list (substring hex-string
start
(+ start part-length))))))
'()
(list 8 4 4 4 12))
"-"))))
|