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 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)
  51   (lambda (proc . arglists)
  52     (mapper join-thread
  53             (apply map
  54                    (lambda args
  55                      (begin-thread (apply proc args)))
  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)
  62   (let* ((m (make-mutex))
  63          (threads '())
  64          (results (make-list (length (car arglists))))
  65          (result results))
  66     (do ((i 0 (+ 1 i)))
  67         ((= i n)
  68          (for-each join-thread threads)
  69          results)
  70       (set! threads
  71             (cons (begin-thread
  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))
  80                            (unlock-mutex m)
  81                            (set-car! my-result (apply proc args))
  82                            (loop)))))
  83                   threads)))))
  84
  85 (define (n-par-for-each n proc . arglists)
  86   (let ((m (make-mutex))
  87         (threads '()))
  88     (do ((i 0 (+ 1 i)))
  89         ((= i n)
  90          (for-each join-thread threads))
  91       (set! threads
  92             (cons (begin-thread
  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))
  99                            (unlock-mutex m)
 100                            (apply proc args)
 101                            (loop)))))
 102                   threads)))))
 103
 104 ;;; The following procedure is motivated by the common and important
 105 ;;; case where a lot of work should be done, (not too much) in parallel,
 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          (threads '())
 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 join-thread threads))
 120       (set! threads
 121             (cons (begin-thread
 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                   threads)))))
 147
 148 (define (thread-handler tag . args)
 149   (fluid-set! the-last-stack #f)
 150   (let ((n (length args))
 151         (p (current-error-port)))
 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)
 168           (newline p)))
 169     #f))
 170
 171 ;;; Set system thread handler
 172 (define %thread-handler thread-handler)
 173
 174 ; --- MACROS -------------------------------------------------------
 175
 176 (define-macro (begin-thread . forms)
 177   (if (null? forms)
 178       '(begin)
 179       `(call-with-new-thread
 180         (lambda ()
 181           ,@forms)
 182         %thread-handler)))
 183
 184 (define-macro (parallel . forms)
 185   (cond ((null? forms) '(values))
 186         ((null? (cdr forms)) (car forms))
 187         (else
 188          (let ((vars (map (lambda (f)
 189                             (make-symbol "f"))
 190                           forms)))
 191            `((lambda ,vars
 192                (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
 193              ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
 194
 195 (define-macro (letpar bindings . body)
 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) `(join-thread ,v)) vars)))
 203              ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
 204
 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)
 212   `(dynamic-wind
 213        (lambda () (lock-mutex ,m))
 214        (lambda () (begin ,@body))
 215        (lambda () (unlock-mutex ,m))))
 216
 217 (define-macro (monitor first . rest)
 218   `(with-mutex ,(make-mutex)
 219      (begin
 220        ,first ,@rest)))
 221
 222 ;;; threads.scm ends here