module/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 3 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 (begin-thread
  36            parallel
  37            letpar
  38            make-thread
  39            with-mutex
  40            monitor
  41
  42            par-map
  43            par-for-each
  44            n-par-map
  45            n-par-for-each
  46            n-for-each-par-map
  47            %thread-handler))
  48
  49 \f
  50
  51 ;;; Macros first, so that the procedures expand correctly.
  52
  53 (define-syntax begin-thread
  54   (syntax-rules ()
  55     ((_ e0 e1 ...)
  56      (call-with-new-thread
  57       (lambda () e0 e1 ...)
  58       %thread-handler))))
  59
  60 (define-syntax parallel
  61   (lambda (x)
  62     (syntax-case x ()
  63       ((_ e0 ...)
  64        (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
  65          (syntax
  66           (let ((tmp0 (begin-thread e0))
  67                 ...)
  68             (values (join-thread tmp0) ...))))))))
  69
  70 (define-syntax letpar
  71   (syntax-rules ()
  72     ((_ ((v e) ...) b0 b1 ...)
  73      (call-with-values
  74          (lambda () (parallel e ...))
  75        (lambda (v ...)
  76          b0 b1 ...)))))
  77
  78 (define-syntax make-thread
  79   (syntax-rules ()
  80     ((_ proc arg ...)
  81      (call-with-new-thread
  82       (lambda () (proc arg ...))
  83       %thread-handler))))
  84
  85 (define-syntax with-mutex
  86   (syntax-rules ()
  87     ((_ m e0 e1 ...)
  88      (let ((x m))
  89        (dynamic-wind
  90          (lambda () (lock-mutex x))
  91          (lambda () (begin e0 e1 ...))
  92          (lambda () (unlock-mutex x)))))))
  93
  94 (define-syntax monitor
  95   (syntax-rules ()
  96     ((_ first rest ...)
  97      (with-mutex (make-mutex)
  98        first rest ...))))
  99
 100 (define (par-mapper mapper)
 101   (lambda (proc . arglists)
 102     (mapper join-thread
 103             (apply map
 104                    (lambda args
 105                      (begin-thread (apply proc args)))
 106                    arglists))))
 107
 108 (define par-map (par-mapper map))
 109 (define par-for-each (par-mapper for-each))
 110
 111 (define (n-par-map n proc . arglists)
 112   (let* ((m (make-mutex))
 113          (threads '())
 114          (results (make-list (length (car arglists))))
 115          (result results))
 116     (do ((i 0 (+ 1 i)))
 117         ((= i n)
 118          (for-each join-thread threads)
 119          results)
 120       (set! threads
 121             (cons (begin-thread
 122                    (let loop ()
 123                      (lock-mutex m)
 124                      (if (null? result)
 125                          (unlock-mutex m)
 126                          (let ((args (map car arglists))
 127                                (my-result result))
 128                            (set! arglists (map cdr arglists))
 129                            (set! result (cdr result))
 130                            (unlock-mutex m)
 131                            (set-car! my-result (apply proc args))
 132                            (loop)))))
 133                   threads)))))
 134
 135 (define (n-par-for-each n proc . arglists)
 136   (let ((m (make-mutex))
 137         (threads '()))
 138     (do ((i 0 (+ 1 i)))
 139         ((= i n)
 140          (for-each join-thread threads))
 141       (set! threads
 142             (cons (begin-thread
 143                    (let loop ()
 144                      (lock-mutex m)
 145                      (if (null? (car arglists))
 146                          (unlock-mutex m)
 147                          (let ((args (map car arglists)))
 148                            (set! arglists (map cdr arglists))
 149                            (unlock-mutex m)
 150                            (apply proc args)
 151                            (loop)))))
 152                   threads)))))
 153
 154 ;;; The following procedure is motivated by the common and important
 155 ;;; case where a lot of work should be done, (not too much) in parallel,
 156 ;;; but the results need to be handled serially (for example when
 157 ;;; writing them to a file).
 158 ;;;
 159 (define (n-for-each-par-map n s-proc p-proc . arglists)
 160   "Using N parallel processes, apply S-PROC in serial order on the results
 161 of applying P-PROC on ARGLISTS."
 162   (let* ((m (make-mutex))
 163          (threads '())
 164          (no-result '(no-value))
 165          (results (make-list (length (car arglists)) no-result))
 166          (result results))
 167     (do ((i 0 (+ 1 i)))
 168         ((= i n)
 169          (for-each join-thread threads))
 170       (set! threads
 171             (cons (begin-thread
 172                    (let loop ()
 173                      (lock-mutex m)
 174                      (cond ((null? results)
 175                             (unlock-mutex m))
 176                            ((not (eq? (car results) no-result))
 177                             (let ((arg (car results)))
 178                               ;; stop others from choosing to process results
 179                               (set-car! results no-result)
 180                               (unlock-mutex m)
 181                               (s-proc arg)
 182                               (lock-mutex m)
 183                               (set! results (cdr results))
 184                               (unlock-mutex m)
 185                               (loop)))
 186                            ((null? result)
 187                             (unlock-mutex m))
 188                            (else
 189                             (let ((args (map car arglists))
 190                                   (my-result result))
 191                               (set! arglists (map cdr arglists))
 192                               (set! result (cdr result))
 193                               (unlock-mutex m)
 194                               (set-car! my-result (apply p-proc args))
 195                               (loop))))))
 196                   threads)))))
 197
 198 (define (thread-handler tag . args)
 199   (fluid-set! the-last-stack #f)
 200   (let ((n (length args))
 201         (p (current-error-port)))
 202     (display "In thread:" p)
 203     (newline p)
 204     (if (>= n 3)
 205         (display-error #f
 206                        p
 207                        (car args)
 208                        (cadr args)
 209                        (caddr args)
 210                        (if (= n 4)
 211                            (cadddr args)
 212                            '()))
 213         (begin
 214           (display "uncaught throw to " p)
 215           (display tag p)
 216           (display ": " p)
 217           (display args p)
 218           (newline p)))
 219     #f))
 220
 221 ;;; Set system thread handler
 222 (define %thread-handler thread-handler)
 223
 224 ;;; threads.scm ends here