ice-9/threads.scm

   1 ;;;;    Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
   2 ;;;;
   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,
   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.
  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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  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 ;;;; ----------------------------------------------------------------
  23 ;;;;
  24 \f
  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:
  33
  34 (define-module (ice-9 threads)
  35   :export (par-map
  36            par-for-each
  37            n-par-map
  38            n-par-for-each
  39            n-for-each-par-map
  40            %thread-handler)
  41   :export-syntax (begin-thread
  42                   parallel
  43                   letpar
  44                   make-thread
  45                   with-mutex
  46                   monitor))
  47
  48 \f
  49
  50 (define ((par-mapper mapper)  proc . arglists)
  51   (mapper join-thread
  52           (apply map
  53                  (lambda args
  54                    (begin-thread (apply proc args)))
  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)
  61   (let* ((m (make-mutex))
  62          (threads '())
  63          (results (make-list (length (car arglists))))
  64          (result results))
  65     (do ((i 0 (+ 1 i)))
  66         ((= i n)
  67          (for-each join-thread threads)
  68          results)
  69       (set! threads
  70             (cons (begin-thread
  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))
  79                            (unlock-mutex m)
  80                            (set-car! my-result (apply proc args))
  81                            (loop)))))
  82                   threads)))))
  83
  84 (define (n-par-for-each n proc . arglists)
  85   (let ((m (make-mutex))
  86         (threads '()))
  87     (do ((i 0 (+ 1 i)))
  88         ((= i n)
  89          (for-each join-thread threads))
  90       (set! threads
  91             (cons (begin-thread
  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))
  98                            (unlock-mutex m)
  99                            (apply proc args)
 100                            (loop)))))
 101                   threads)))))
 102
 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).
 107 ;;;
 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))
 112          (threads '())
 113          (no-result '(no-value))
 114          (results (make-list (length (car arglists)) no-result))
 115          (result results))
 116     (do ((i 0 (+ 1 i)))
 117         ((= i n)
 118          (for-each join-thread threads))
 119       (set! threads
 120             (cons (begin-thread
 121                    (let loop ()
 122                      (lock-mutex m)
 123                      (cond ((null? results)
 124                             (unlock-mutex m))
 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)
 129                               (unlock-mutex m)
 130                               (s-proc arg)
 131                               (lock-mutex m)
 132                               (set! results (cdr results))
 133                               (unlock-mutex m)
 134                               (loop)))
 135                            ((null? result)
 136                             (unlock-mutex m))
 137                            (else
 138                             (let ((args (map car arglists))
 139                                   (my-result result))
 140                               (set! arglists (map cdr arglists))
 141                               (set! result (cdr result))
 142                               (unlock-mutex m)
 143                               (set-car! my-result (apply p-proc args))
 144                               (loop))))))
 145                   threads)))))
 146
 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)
 152     (newline p)
 153     (if (>= n 3)
 154         (display-error #f
 155                        p
 156                        (car args)
 157                        (cadr args)
 158                        (caddr args)
 159                        (if (= n 4)
 160                            (cadddr args)
 161                            '()))
 162         (begin
 163           (display "uncaught throw to " p)
 164           (display tag p)
 165           (display ": " p)
 166           (display args p)
 167           (newline p)))
 168     #f))
 169
 170 ;;; Set system thread handler
 171 (define %thread-handler thread-handler)
 172
 173 ; --- MACROS -------------------------------------------------------
 174
 175 (define-macro (begin-thread . forms)
 176   (if (null? forms)
 177       '(begin)
 178       `(call-with-new-thread
 179         (lambda ()
 180           ,@forms)
 181         %thread-handler)))
 182
 183 (define-macro (parallel . forms)
 184   (cond ((null? forms) '(values))
 185         ((null? (cdr forms)) (car forms))
 186         (else
 187          (let ((vars (map (lambda (f)
 188                             (make-symbol "f"))
 189                           forms)))
 190            `((lambda ,vars
 191                (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
 192              ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
 193
 194 (define-macro (letpar bindings . body)
 195   (cond ((or (null? bindings) (null? (cdr bindings)))
 196          `(let ,bindings ,@body))
 197         (else
 198          (let ((vars (map car bindings)))
 199            `((lambda ,vars
 200                ((lambda ,vars ,@body)
 201                 ,@(map (lambda (v) `(join-thread ,v)) vars)))
 202              ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
 203
 204 (define-macro (make-thread proc . args)
 205   `(call-with-new-thread
 206     (lambda ()
 207       (,proc ,@args))
 208     %thread-handler))
 209
 210 (define-macro (with-mutex m . body)
 211   `(dynamic-wind
 212        (lambda () (lock-mutex ,m))
 213        (lambda () (begin ,@body))
 214        (lambda () (unlock-mutex ,m))))
 215
 216 (define-macro (monitor first . rest)
 217   `(with-mutex ,(make-mutex)
 218      (begin
 219        ,first ,@rest)))
 220
 221 ;;; threads.scm ends here