X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=guile18%2Fice-9%2Fthreads.scm;fp=guile18%2Fice-9%2Fthreads.scm;h=cdabb24175cae50f28b775baf904de6c1580c8c6;hb=139c38d9204dd07f6b235f83bae644faedbc63fd;hp=0000000000000000000000000000000000000000;hpb=652ed35a2013489d0a14fede6307cd2595abb2c4;p=lilypond.git diff --git a/guile18/ice-9/threads.scm b/guile18/ice-9/threads.scm new file mode 100644 index 0000000000..cdabb24175 --- /dev/null +++ b/guile18/ice-9/threads.scm @@ -0,0 +1,221 @@ +;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; +;;;; ---------------------------------------------------------------- +;;;; threads.scm -- User-level interface to Guile's thread system +;;;; 4 March 1996, Anthony Green +;;;; Modified 5 October 1996, MDJ +;;;; Modified 6 April 2001, ttn +;;;; ---------------------------------------------------------------- +;;;; + +;;; Commentary: + +;; This module is documented in the Guile Reference Manual. +;; Briefly, one procedure is exported: `%thread-handler'; +;; as well as four macros: `make-thread', `begin-thread', +;; `with-mutex' and `monitor'. + +;;; Code: + +(define-module (ice-9 threads) + :export (par-map + par-for-each + n-par-map + n-par-for-each + n-for-each-par-map + %thread-handler) + :export-syntax (begin-thread + parallel + letpar + make-thread + with-mutex + monitor)) + + + +(define ((par-mapper mapper) proc . arglists) + (mapper join-thread + (apply map + (lambda args + (begin-thread (apply proc args))) + arglists))) + +(define par-map (par-mapper map)) +(define par-for-each (par-mapper for-each)) + +(define (n-par-map n proc . arglists) + (let* ((m (make-mutex)) + (threads '()) + (results (make-list (length (car arglists)))) + (result results)) + (do ((i 0 (+ 1 i))) + ((= i n) + (for-each join-thread threads) + results) + (set! threads + (cons (begin-thread + (let loop () + (lock-mutex m) + (if (null? result) + (unlock-mutex m) + (let ((args (map car arglists)) + (my-result result)) + (set! arglists (map cdr arglists)) + (set! result (cdr result)) + (unlock-mutex m) + (set-car! my-result (apply proc args)) + (loop))))) + threads))))) + +(define (n-par-for-each n proc . arglists) + (let ((m (make-mutex)) + (threads '())) + (do ((i 0 (+ 1 i))) + ((= i n) + (for-each join-thread threads)) + (set! threads + (cons (begin-thread + (let loop () + (lock-mutex m) + (if (null? (car arglists)) + (unlock-mutex m) + (let ((args (map car arglists))) + (set! arglists (map cdr arglists)) + (unlock-mutex m) + (apply proc args) + (loop))))) + threads))))) + +;;; The following procedure is motivated by the common and important +;;; case where a lot of work should be done, (not too much) in parallel, +;;; but the results need to be handled serially (for example when +;;; writing them to a file). +;;; +(define (n-for-each-par-map n s-proc p-proc . arglists) + "Using N parallel processes, apply S-PROC in serial order on the results +of applying P-PROC on ARGLISTS." + (let* ((m (make-mutex)) + (threads '()) + (no-result '(no-value)) + (results (make-list (length (car arglists)) no-result)) + (result results)) + (do ((i 0 (+ 1 i))) + ((= i n) + (for-each join-thread threads)) + (set! threads + (cons (begin-thread + (let loop () + (lock-mutex m) + (cond ((null? results) + (unlock-mutex m)) + ((not (eq? (car results) no-result)) + (let ((arg (car results))) + ;; stop others from choosing to process results + (set-car! results no-result) + (unlock-mutex m) + (s-proc arg) + (lock-mutex m) + (set! results (cdr results)) + (unlock-mutex m) + (loop))) + ((null? result) + (unlock-mutex m)) + (else + (let ((args (map car arglists)) + (my-result result)) + (set! arglists (map cdr arglists)) + (set! result (cdr result)) + (unlock-mutex m) + (set-car! my-result (apply p-proc args)) + (loop)))))) + threads))))) + +(define (thread-handler tag . args) + (fluid-set! the-last-stack #f) + (let ((n (length args)) + (p (current-error-port))) + (display "In thread:" p) + (newline p) + (if (>= n 3) + (display-error #f + p + (car args) + (cadr args) + (caddr args) + (if (= n 4) + (cadddr args) + '())) + (begin + (display "uncaught throw to " p) + (display tag p) + (display ": " p) + (display args p) + (newline p))) + #f)) + +;;; Set system thread handler +(define %thread-handler thread-handler) + +; --- MACROS ------------------------------------------------------- + +(define-macro (begin-thread . forms) + (if (null? forms) + '(begin) + `(call-with-new-thread + (lambda () + ,@forms) + %thread-handler))) + +(define-macro (parallel . forms) + (cond ((null? forms) '(values)) + ((null? (cdr forms)) (car forms)) + (else + (let ((vars (map (lambda (f) + (make-symbol "f")) + forms))) + `((lambda ,vars + (values ,@(map (lambda (v) `(join-thread ,v)) vars))) + ,@(map (lambda (form) `(begin-thread ,form)) forms)))))) + +(define-macro (letpar bindings . body) + (cond ((or (null? bindings) (null? (cdr bindings))) + `(let ,bindings ,@body)) + (else + (let ((vars (map car bindings))) + `((lambda ,vars + ((lambda ,vars ,@body) + ,@(map (lambda (v) `(join-thread ,v)) vars))) + ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings)))))) + +(define-macro (make-thread proc . args) + `(call-with-new-thread + (lambda () + (,proc ,@args)) + %thread-handler)) + +(define-macro (with-mutex m . body) + `(dynamic-wind + (lambda () (lock-mutex ,m)) + (lambda () (begin ,@body)) + (lambda () (unlock-mutex ,m)))) + +(define-macro (monitor first . rest) + `(with-mutex ,(make-mutex) + (begin + ,first ,@rest))) + +;;; threads.scm ends here