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