Commit | Line | Data |
---|---|---|
2d37a934 LC |
1 | ;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011, |
2 | ;;;; 2012 Free Software Foundation, Inc. | |
c7a813af | 3 | ;;;; |
73be1d9e MV |
4 | ;;;; This library is free software; you can redistribute it and/or |
5 | ;;;; modify it under the terms of the GNU Lesser General Public | |
6 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 7 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
8 | ;;;; |
9 | ;;;; This library is distributed in the hope that it will be useful, | |
1188fb05 | 10 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | ;;;; Lesser General Public License for more details. | |
13 | ;;;; | |
14 | ;;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 16 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
a482f2cc | 17 | ;;;; |
1188fb05 MD |
18 | ;;;; ---------------------------------------------------------------- |
19 | ;;;; threads.scm -- User-level interface to Guile's thread system | |
20 | ;;;; 4 March 1996, Anthony Green <green@cygnus.com> | |
21 | ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se> | |
c7a813af | 22 | ;;;; Modified 6 April 2001, ttn |
1188fb05 MD |
23 | ;;;; ---------------------------------------------------------------- |
24 | ;;;; | |
25 | \f | |
e7d82feb TTN |
26 | ;;; Commentary: |
27 | ||
28 | ;; This module is documented in the Guile Reference Manual. | |
29 | ;; Briefly, one procedure is exported: `%thread-handler'; | |
30 | ;; as well as four macros: `make-thread', `begin-thread', | |
31 | ;; `with-mutex' and `monitor'. | |
32 | ||
33 | ;;; Code: | |
1188fb05 | 34 | |
1a179b03 | 35 | (define-module (ice-9 threads) |
c21a5ddc | 36 | #:use-module (ice-9 futures) |
2d37a934 | 37 | #:use-module (ice-9 match) |
c21a5ddc LC |
38 | #:export (begin-thread |
39 | parallel | |
40 | letpar | |
41 | make-thread | |
42 | with-mutex | |
43 | monitor | |
7902c547 | 44 | |
c21a5ddc LC |
45 | par-map |
46 | par-for-each | |
47 | n-par-map | |
48 | n-par-for-each | |
49 | n-for-each-par-map | |
50 | %thread-handler)) | |
1188fb05 MD |
51 | |
52 | \f | |
53 | ||
7902c547 AW |
54 | ;;; Macros first, so that the procedures expand correctly. |
55 | ||
0c65f52c AW |
56 | (define-syntax-rule (begin-thread e0 e1 ...) |
57 | (call-with-new-thread | |
58 | (lambda () e0 e1 ...) | |
59 | %thread-handler)) | |
7902c547 AW |
60 | |
61 | (define-syntax parallel | |
62 | (lambda (x) | |
63 | (syntax-case x () | |
64 | ((_ e0 ...) | |
65 | (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) | |
c21a5ddc LC |
66 | #'(let ((tmp0 (future e0)) |
67 | ...) | |
68 | (values (touch tmp0) ...))))))) | |
7902c547 | 69 | |
0c65f52c AW |
70 | (define-syntax-rule (letpar ((v e) ...) b0 b1 ...) |
71 | (call-with-values | |
72 | (lambda () (parallel e ...)) | |
73 | (lambda (v ...) | |
74 | b0 b1 ...))) | |
7902c547 | 75 | |
0c65f52c AW |
76 | (define-syntax-rule (make-thread proc arg ...) |
77 | (call-with-new-thread | |
78 | (lambda () (proc arg ...)) | |
79 | %thread-handler)) | |
7902c547 | 80 | |
0c65f52c AW |
81 | (define-syntax-rule (with-mutex m e0 e1 ...) |
82 | (let ((x m)) | |
83 | (dynamic-wind | |
84 | (lambda () (lock-mutex x)) | |
85 | (lambda () (begin e0 e1 ...)) | |
86 | (lambda () (unlock-mutex x))))) | |
7902c547 | 87 | |
0c65f52c AW |
88 | (define-syntax-rule (monitor first rest ...) |
89 | (with-mutex (make-mutex) | |
90 | first rest ...)) | |
7902c547 | 91 | |
2d37a934 LC |
92 | (define (par-mapper mapper cons) |
93 | (lambda (proc . lists) | |
94 | (let loop ((lists lists)) | |
95 | (match lists | |
96 | (((heads tails ...) ...) | |
97 | (let ((tail (future (loop tails))) | |
98 | (head (apply proc heads))) | |
99 | (cons head (touch tail)))) | |
100 | (_ | |
101 | '()))))) | |
87623595 | 102 | |
2d37a934 LC |
103 | (define par-map (par-mapper map cons)) |
104 | (define par-for-each (par-mapper for-each (const *unspecified*))) | |
87623595 MD |
105 | |
106 | (define (n-par-map n proc . arglists) | |
abce330c | 107 | (let* ((m (make-mutex)) |
a64d0589 | 108 | (threads '()) |
87623595 MD |
109 | (results (make-list (length (car arglists)))) |
110 | (result results)) | |
111 | (do ((i 0 (+ 1 i))) | |
112 | ((= i n) | |
680d5140 | 113 | (for-each join-thread threads) |
87623595 | 114 | results) |
a64d0589 MV |
115 | (set! threads |
116 | (cons (begin-thread | |
f4719f31 MD |
117 | (let loop () |
118 | (lock-mutex m) | |
119 | (if (null? result) | |
120 | (unlock-mutex m) | |
121 | (let ((args (map car arglists)) | |
122 | (my-result result)) | |
123 | (set! arglists (map cdr arglists)) | |
124 | (set! result (cdr result)) | |
87623595 | 125 | (unlock-mutex m) |
f4719f31 MD |
126 | (set-car! my-result (apply proc args)) |
127 | (loop))))) | |
a64d0589 | 128 | threads))))) |
87623595 MD |
129 | |
130 | (define (n-par-for-each n proc . arglists) | |
131 | (let ((m (make-mutex)) | |
a64d0589 | 132 | (threads '())) |
87623595 MD |
133 | (do ((i 0 (+ 1 i))) |
134 | ((= i n) | |
5be9f729 | 135 | (for-each join-thread threads)) |
a64d0589 MV |
136 | (set! threads |
137 | (cons (begin-thread | |
f4719f31 MD |
138 | (let loop () |
139 | (lock-mutex m) | |
140 | (if (null? (car arglists)) | |
141 | (unlock-mutex m) | |
142 | (let ((args (map car arglists))) | |
143 | (set! arglists (map cdr arglists)) | |
87623595 | 144 | (unlock-mutex m) |
f4719f31 MD |
145 | (apply proc args) |
146 | (loop))))) | |
a64d0589 | 147 | threads))))) |
87623595 | 148 | |
359aab24 | 149 | ;;; The following procedure is motivated by the common and important |
ee2a6d99 | 150 | ;;; case where a lot of work should be done, (not too much) in parallel, |
359aab24 MD |
151 | ;;; but the results need to be handled serially (for example when |
152 | ;;; writing them to a file). | |
153 | ;;; | |
154 | (define (n-for-each-par-map n s-proc p-proc . arglists) | |
155 | "Using N parallel processes, apply S-PROC in serial order on the results | |
156 | of applying P-PROC on ARGLISTS." | |
157 | (let* ((m (make-mutex)) | |
a64d0589 | 158 | (threads '()) |
359aab24 MD |
159 | (no-result '(no-value)) |
160 | (results (make-list (length (car arglists)) no-result)) | |
161 | (result results)) | |
162 | (do ((i 0 (+ 1 i))) | |
163 | ((= i n) | |
5be9f729 | 164 | (for-each join-thread threads)) |
a64d0589 MV |
165 | (set! threads |
166 | (cons (begin-thread | |
359aab24 MD |
167 | (let loop () |
168 | (lock-mutex m) | |
169 | (cond ((null? results) | |
170 | (unlock-mutex m)) | |
171 | ((not (eq? (car results) no-result)) | |
172 | (let ((arg (car results))) | |
173 | ;; stop others from choosing to process results | |
174 | (set-car! results no-result) | |
175 | (unlock-mutex m) | |
176 | (s-proc arg) | |
177 | (lock-mutex m) | |
178 | (set! results (cdr results)) | |
179 | (unlock-mutex m) | |
180 | (loop))) | |
181 | ((null? result) | |
182 | (unlock-mutex m)) | |
183 | (else | |
184 | (let ((args (map car arglists)) | |
185 | (my-result result)) | |
186 | (set! arglists (map cdr arglists)) | |
187 | (set! result (cdr result)) | |
188 | (unlock-mutex m) | |
189 | (set-car! my-result (apply p-proc args)) | |
190 | (loop)))))) | |
a64d0589 | 191 | threads))))) |
359aab24 | 192 | |
87623595 | 193 | (define (thread-handler tag . args) |
13dc0cae MD |
194 | (let ((n (length args)) |
195 | (p (current-error-port))) | |
c7a813af TTN |
196 | (display "In thread:" p) |
197 | (newline p) | |
198 | (if (>= n 3) | |
199 | (display-error #f | |
200 | p | |
201 | (car args) | |
202 | (cadr args) | |
203 | (caddr args) | |
204 | (if (= n 4) | |
205 | (cadddr args) | |
206 | '())) | |
207 | (begin | |
208 | (display "uncaught throw to " p) | |
209 | (display tag p) | |
210 | (display ": " p) | |
211 | (display args p) | |
f4f16ecc MV |
212 | (newline p))) |
213 | #f)) | |
13dc0cae | 214 | |
87623595 | 215 | ;;; Set system thread handler |
a64d0589 | 216 | (define %thread-handler thread-handler) |
c7a813af | 217 | |
c7a813af | 218 | ;;; threads.scm ends here |