1 ;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
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.
8 ;;;; This library is distributed in the hope that it will be useful,
9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 ;;;; Lesser General Public License for more details.
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
15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
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>
21 ;;;; Modified 6 April 2001, ttn
22 ;;;; ----------------------------------------------------------------
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'.
34 (define-module (ice-9 threads)
41 :export-syntax (begin-thread
50 (define ((par-mapper mapper) proc . arglists)
54 (begin-thread (apply proc args)))
57 (define par-map (par-mapper map))
58 (define par-for-each (par-mapper for-each))
60 (define (n-par-map n proc . arglists)
61 (let* ((m (make-mutex))
63 (results (make-list (length (car arglists))))
67 (for-each join-thread threads)
75 (let ((args (map car arglists))
77 (set! arglists (map cdr arglists))
78 (set! result (cdr result))
80 (set-car! my-result (apply proc args))
84 (define (n-par-for-each n proc . arglists)
85 (let ((m (make-mutex))
89 (for-each join-thread threads))
94 (if (null? (car arglists))
96 (let ((args (map car arglists)))
97 (set! arglists (map cdr arglists))
103 ;;; The following procedure is motivated by the common and important
104 ;;; case where a lot of work should be done, (not too much) in parallel,
105 ;;; but the results need to be handled serially (for example when
106 ;;; writing them to a file).
108 (define (n-for-each-par-map n s-proc p-proc . arglists)
109 "Using N parallel processes, apply S-PROC in serial order on the results
110 of applying P-PROC on ARGLISTS."
111 (let* ((m (make-mutex))
113 (no-result '(no-value))
114 (results (make-list (length (car arglists)) no-result))
118 (for-each join-thread threads))
123 (cond ((null? results)
125 ((not (eq? (car results) no-result))
126 (let ((arg (car results)))
127 ;; stop others from choosing to process results
128 (set-car! results no-result)
132 (set! results (cdr results))
138 (let ((args (map car arglists))
140 (set! arglists (map cdr arglists))
141 (set! result (cdr result))
143 (set-car! my-result (apply p-proc args))
147 (define (thread-handler tag . args)
148 (fluid-set! the-last-stack #f)
149 (let ((n (length args))
150 (p (current-error-port)))
151 (display "In thread:" p)
163 (display "uncaught throw to " p)
170 ;;; Set system thread handler
171 (define %thread-handler thread-handler)
173 ; --- MACROS -------------------------------------------------------
175 (define-macro (begin-thread . forms)
178 `(call-with-new-thread
183 (define-macro (parallel . forms)
184 (cond ((null? forms) '(values))
185 ((null? (cdr forms)) (car forms))
187 (let ((vars (map (lambda (f)
191 (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
192 ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
194 (define-macro (letpar bindings . body)
195 (cond ((or (null? bindings) (null? (cdr bindings)))
196 `(let ,bindings ,@body))
198 (let ((vars (map car bindings)))
200 ((lambda ,vars ,@body)
201 ,@(map (lambda (v) `(join-thread ,v)) vars)))
202 ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
204 (define-macro (make-thread proc . args)
205 `(call-with-new-thread
210 (define-macro (with-mutex m . body)
212 (lambda () (lock-mutex ,m))
213 (lambda () (begin ,@body))
214 (lambda () (unlock-mutex ,m))))
216 (define-macro (monitor first . rest)
217 `(with-mutex ,(make-mutex)
221 ;;; threads.scm ends here