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 | |
15 | ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 MD |
37 | n-par-map |
38 | n-par-for-each) | |
f595ccfe | 39 | :re-export (future-ref) |
87623595 | 40 | :export-syntax (begin-thread |
abce330c | 41 | parallel |
fc85d095 | 42 | letpar |
87623595 | 43 | make-thread |
1a179b03 | 44 | with-mutex |
f595ccfe MD |
45 | monitor) |
46 | :re-export-syntax (future)) | |
1188fb05 MD |
47 | |
48 | \f | |
49 | ||
87623595 | 50 | (define ((par-mapper mapper) proc . arglists) |
f4719f31 | 51 | (mapper future-ref |
87623595 MD |
52 | (apply map |
53 | (lambda args | |
f4719f31 | 54 | (future (apply proc args))) |
87623595 MD |
55 | arglists))) |
56 | ||
57 | (define par-map (par-mapper map)) | |
58 | (define par-for-each (par-mapper for-each)) | |
59 | ||
60 | (define (n-par-map n proc . arglists) | |
abce330c | 61 | (let* ((m (make-mutex)) |
f4719f31 | 62 | (futures '()) |
87623595 MD |
63 | (results (make-list (length (car arglists)))) |
64 | (result results)) | |
65 | (do ((i 0 (+ 1 i))) | |
66 | ((= i n) | |
f4719f31 | 67 | (for-each future-ref futures) |
87623595 | 68 | results) |
f4719f31 MD |
69 | (set! futures |
70 | (cons (future | |
71 | (let loop () | |
72 | (lock-mutex m) | |
73 | (if (null? result) | |
74 | (unlock-mutex m) | |
75 | (let ((args (map car arglists)) | |
76 | (my-result result)) | |
77 | (set! arglists (map cdr arglists)) | |
78 | (set! result (cdr result)) | |
87623595 | 79 | (unlock-mutex m) |
f4719f31 MD |
80 | (set-car! my-result (apply proc args)) |
81 | (loop))))) | |
82 | futures))))) | |
87623595 MD |
83 | |
84 | (define (n-par-for-each n proc . arglists) | |
85 | (let ((m (make-mutex)) | |
f4719f31 | 86 | (futures '())) |
87623595 MD |
87 | (do ((i 0 (+ 1 i))) |
88 | ((= i n) | |
f4719f31 MD |
89 | (for-each future-ref futures)) |
90 | (set! futures | |
91 | (cons (future | |
92 | (let loop () | |
93 | (lock-mutex m) | |
94 | (if (null? (car arglists)) | |
95 | (unlock-mutex m) | |
96 | (let ((args (map car arglists))) | |
97 | (set! arglists (map cdr arglists)) | |
87623595 | 98 | (unlock-mutex m) |
f4719f31 MD |
99 | (apply proc args) |
100 | (loop))))) | |
101 | futures))))) | |
87623595 MD |
102 | |
103 | (define (thread-handler tag . args) | |
13dc0cae | 104 | (fluid-set! the-last-stack #f) |
13dc0cae MD |
105 | (let ((n (length args)) |
106 | (p (current-error-port))) | |
c7a813af TTN |
107 | (display "In thread:" p) |
108 | (newline p) | |
109 | (if (>= n 3) | |
110 | (display-error #f | |
111 | p | |
112 | (car args) | |
113 | (cadr args) | |
114 | (caddr args) | |
115 | (if (= n 4) | |
116 | (cadddr args) | |
117 | '())) | |
118 | (begin | |
119 | (display "uncaught throw to " p) | |
120 | (display tag p) | |
121 | (display ": " p) | |
122 | (display args p) | |
f4f16ecc MV |
123 | (newline p))) |
124 | #f)) | |
13dc0cae | 125 | |
87623595 MD |
126 | ;;; Set system thread handler |
127 | (set! %thread-handler thread-handler) | |
c7a813af | 128 | |
87623595 | 129 | ; --- MACROS ------------------------------------------------------- |
1188fb05 | 130 | |
87623595 MD |
131 | (define-macro (begin-thread . forms) |
132 | (if (null? forms) | |
133 | '(begin) | |
134 | `(call-with-new-thread | |
135 | (lambda () | |
136 | ,@forms) | |
137 | %thread-handler))) | |
1188fb05 | 138 | |
87623595 | 139 | (define-macro (parallel . forms) |
abce330c MD |
140 | (cond ((null? forms) '(begin)) |
141 | ((null? (cdr forms)) (car forms)) | |
142 | (else | |
c2950e36 MD |
143 | (let ((vars (map (lambda (f) |
144 | (make-symbol "f")) | |
145 | forms))) | |
146 | `((lambda ,vars | |
147 | (values ,@(map (lambda (v) `(future-ref ,v)) vars))) | |
148 | ,@(map (lambda (form) `(future ,form)) forms)))))) | |
87623595 MD |
149 | |
150 | (define-macro (letpar bindings . body) | |
c2950e36 MD |
151 | (cond ((or (null? bindings) (null? (cdr bindings))) |
152 | `(let ,bindings ,@body)) | |
153 | (else | |
154 | (let ((vars (map car bindings))) | |
155 | `((lambda ,vars | |
156 | ((lambda ,vars ,@body) | |
157 | ,@(map (lambda (v) `(future-ref ,v)) vars))) | |
158 | ,@(map (lambda (b) `(future ,(cadr b))) bindings)))))) | |
fc85d095 | 159 | |
87623595 MD |
160 | (define-macro (make-thread proc . args) |
161 | `(call-with-new-thread | |
162 | (lambda () | |
163 | (,proc ,@args)) | |
164 | %thread-handler)) | |
165 | ||
166 | (define-macro (with-mutex m . body) | |
1188fb05 | 167 | `(dynamic-wind |
c7a813af TTN |
168 | (lambda () (lock-mutex ,m)) |
169 | (lambda () (begin ,@body)) | |
170 | (lambda () (unlock-mutex ,m)))) | |
1188fb05 | 171 | |
87623595 | 172 | (define-macro (monitor first . rest) |
1188fb05 | 173 | `(with-mutex ,(make-mutex) |
c7a813af TTN |
174 | (begin |
175 | ,first ,@rest))) | |
176 | ||
c7a813af | 177 | ;;; threads.scm ends here |