ice-9/threads.scm

   1 ;;;;    Copyright (C) 1996, 1998, 2001, 2002, 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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   :re-export (future-ref)
  40   :export-syntax (begin-thread
  41                   parallel
  42                   letpar
  43                   make-thread
  44                   with-mutex
  45                   monitor)
  46   :re-export-syntax (future))
  47
  48 \f
  49
  50 (define ((par-mapper mapper)  proc . arglists)
  51   (mapper future-ref
  52           (apply map
  53                  (lambda args
  54                    (future (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          (futures '())
  63          (results (make-list (length (car arglists))))
  64          (result results))
  65     (do ((i 0 (+ 1 i)))
  66         ((= i n)
  67          (for-each future-ref futures)
  68          results)
  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))
  79                            (unlock-mutex m)
  80                            (set-car! my-result (apply proc args))
  81                            (loop)))))
  82                   futures)))))
  83
  84 (define (n-par-for-each n proc . arglists)
  85   (let ((m (make-mutex))
  86         (futures '()))
  87     (do ((i 0 (+ 1 i)))
  88         ((= i n)
  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))
  98                            (unlock-mutex m)
  99                            (apply proc args)
 100                            (loop)))))
 101                   futures)))))
 102
 103 (define (thread-handler tag . args)
 104   (fluid-set! the-last-stack #f)
 105   (let ((n (length args))
 106         (p (current-error-port)))
 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)
 123           (newline p)))
 124     #f))
 125
 126 ;;; Set system thread handler
 127 (set! %thread-handler thread-handler)
 128
 129 ; --- MACROS -------------------------------------------------------
 130
 131 (define-macro (begin-thread . forms)
 132   (if (null? forms)
 133       '(begin)
 134       `(call-with-new-thread
 135         (lambda ()
 136           ,@forms)
 137         %thread-handler)))
 138
 139 (define-macro (parallel . forms)
 140   (cond ((null? forms) '(begin))
 141         ((null? (cdr forms)) (car forms))
 142         (else
 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))))))
 149
 150 (define-macro (letpar bindings . body)
 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))))))
 159
 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)
 167   `(dynamic-wind
 168        (lambda () (lock-mutex ,m))
 169        (lambda () (begin ,@body))
 170        (lambda () (unlock-mutex ,m))))
 171
 172 (define-macro (monitor first . rest)
 173   `(with-mutex ,(make-mutex)
 174      (begin
 175        ,first ,@rest)))
 176
 177 ;;; threads.scm ends here