module/ice-9/threads.scm

   1 ;;;;    Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011,
   2 ;;;;      2012 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 3 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17 ;;;;
  18 ;;;; ----------------------------------------------------------------
  19 ;;;; threads.scm -- User-level interface to Guile's thread system
  20 ;;;; 4 March 1996, Anthony Green <green@cygnus.com>
  21 ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
  22 ;;;; Modified 6 April 2001, ttn
  23 ;;;; ----------------------------------------------------------------
  24 ;;;;
  25 \f
  26 ;;; Commentary:
  27
  28 ;; This module is documented in the Guile Reference Manual.
  29 ;; Briefly, one procedure is exported: `%thread-handler';
  30 ;; as well as four macros: `make-thread', `begin-thread',
  31 ;; `with-mutex' and `monitor'.
  32
  33 ;;; Code:
  34
  35 (define-module (ice-9 threads)
  36   #:use-module (ice-9 futures)
  37   #:use-module (ice-9 match)
  38   #:export (begin-thread
  39             parallel
  40             letpar
  41             make-thread
  42             with-mutex
  43             monitor
  44
  45             par-map
  46             par-for-each
  47             n-par-map
  48             n-par-for-each
  49             n-for-each-par-map
  50             %thread-handler))
  51
  52 \f
  53
  54 ;;; Macros first, so that the procedures expand correctly.
  55
  56 (define-syntax-rule (begin-thread e0 e1 ...)
  57   (call-with-new-thread
  58    (lambda () e0 e1 ...)
  59    %thread-handler))
  60
  61 (define-syntax parallel
  62   (lambda (x)
  63     (syntax-case x ()
  64       ((_ e0 ...)
  65        (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
  66          #'(let ((tmp0 (future e0))
  67                  ...)
  68              (values (touch tmp0) ...)))))))
  69
  70 (define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
  71   (call-with-values
  72       (lambda () (parallel e ...))
  73     (lambda (v ...)
  74       b0 b1 ...)))
  75
  76 (define-syntax-rule (make-thread proc arg ...)
  77   (call-with-new-thread
  78    (lambda () (proc arg ...))
  79    %thread-handler))
  80
  81 (define-syntax-rule (with-mutex m e0 e1 ...)
  82   (let ((x m))
  83     (dynamic-wind
  84       (lambda () (lock-mutex x))
  85       (lambda () (begin e0 e1 ...))
  86       (lambda () (unlock-mutex x)))))
  87
  88 (define-syntax-rule (monitor first rest ...)
  89   (with-mutex (make-mutex)
  90     first rest ...))
  91
  92 (define (par-mapper mapper cons)
  93   (lambda (proc . lists)
  94     (let loop ((lists lists))
  95       (match lists
  96         (((heads tails ...) ...)
  97          (let ((tail (future (loop tails)))
  98                (head (apply proc heads)))
  99            (cons head (touch tail))))
 100         (_
 101          '())))))
 102
 103 (define par-map (par-mapper map cons))
 104 (define par-for-each (par-mapper for-each (const *unspecified*)))
 105
 106 (define (n-par-map n proc . arglists)
 107   (let* ((m (make-mutex))
 108          (threads '())
 109          (results (make-list (length (car arglists))))
 110          (result results))
 111     (do ((i 0 (+ 1 i)))
 112         ((= i n)
 113          (for-each join-thread threads)
 114          results)
 115       (set! threads
 116             (cons (begin-thread
 117                    (let loop ()
 118                      (lock-mutex m)
 119                      (if (null? result)
 120                          (unlock-mutex m)
 121                          (let ((args (map car arglists))
 122                                (my-result result))
 123                            (set! arglists (map cdr arglists))
 124                            (set! result (cdr result))
 125                            (unlock-mutex m)
 126                            (set-car! my-result (apply proc args))
 127                            (loop)))))
 128                   threads)))))
 129
 130 (define (n-par-for-each n proc . arglists)
 131   (let ((m (make-mutex))
 132         (threads '()))
 133     (do ((i 0 (+ 1 i)))
 134         ((= i n)
 135          (for-each join-thread threads))
 136       (set! threads
 137             (cons (begin-thread
 138                    (let loop ()
 139                      (lock-mutex m)
 140                      (if (null? (car arglists))
 141                          (unlock-mutex m)
 142                          (let ((args (map car arglists)))
 143                            (set! arglists (map cdr arglists))
 144                            (unlock-mutex m)
 145                            (apply proc args)
 146                            (loop)))))
 147                   threads)))))
 148
 149 ;;; The following procedure is motivated by the common and important
 150 ;;; case where a lot of work should be done, (not too much) in parallel,
 151 ;;; but the results need to be handled serially (for example when
 152 ;;; writing them to a file).
 153 ;;;
 154 (define (n-for-each-par-map n s-proc p-proc . arglists)
 155   "Using N parallel processes, apply S-PROC in serial order on the results
 156 of applying P-PROC on ARGLISTS."
 157   (let* ((m (make-mutex))
 158          (threads '())
 159          (no-result '(no-value))
 160          (results (make-list (length (car arglists)) no-result))
 161          (result results))
 162     (do ((i 0 (+ 1 i)))
 163         ((= i n)
 164          (for-each join-thread threads))
 165       (set! threads
 166             (cons (begin-thread
 167                    (let loop ()
 168                      (lock-mutex m)
 169                      (cond ((null? results)
 170                             (unlock-mutex m))
 171                            ((not (eq? (car results) no-result))
 172                             (let ((arg (car results)))
 173                               ;; stop others from choosing to process results
 174                               (set-car! results no-result)
 175                               (unlock-mutex m)
 176                               (s-proc arg)
 177                               (lock-mutex m)
 178                               (set! results (cdr results))
 179                               (unlock-mutex m)
 180                               (loop)))
 181                            ((null? result)
 182                             (unlock-mutex m))
 183                            (else
 184                             (let ((args (map car arglists))
 185                                   (my-result result))
 186                               (set! arglists (map cdr arglists))
 187                               (set! result (cdr result))
 188                               (unlock-mutex m)
 189                               (set-car! my-result (apply p-proc args))
 190                               (loop))))))
 191                   threads)))))
 192
 193 (define (thread-handler tag . args)
 194   (let ((n (length args))
 195         (p (current-error-port)))
 196     (display "In thread:" p)
 197     (newline p)
 198     (if (>= n 3)
 199         (display-error #f
 200                        p
 201                        (car args)
 202                        (cadr args)
 203                        (caddr args)
 204                        (if (= n 4)
 205                            (cadddr args)
 206                            '()))
 207         (begin
 208           (display "uncaught throw to " p)
 209           (display tag p)
 210           (display ": " p)
 211           (display args p)
 212           (newline p)))
 213     #f))
 214
 215 ;;; Set system thread handler
 216 (define %thread-handler thread-handler)
 217
 218 ;;; threads.scm ends here