home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / threads.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  6.2 KB  |  222 lines
  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.  
  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.  
  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
  222.