1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 17:00:23 +02:00

Replaced 'futures' with threads.

This commit is contained in:
Marius Vollmer 2006-01-29 19:44:45 +00:00
parent 99e370f645
commit a64d058951
4 changed files with 35 additions and 29 deletions

View file

@ -1,3 +1,7 @@
2006-01-29 Marius Vollmer <mvo@zagadka.de>
* threads.scm: Replaced 'futures' with threads.
2006-01-13 Neil Jerram <neil@ossau.uklinux.net> 2006-01-13 Neil Jerram <neil@ossau.uklinux.net>
* boot-9.scm (repl-reader): Use value of current-reader fluid to * boot-9.scm (repl-reader): Use value of current-reader fluid to

View file

@ -37,22 +37,20 @@
n-par-map n-par-map
n-par-for-each n-par-for-each
n-for-each-par-map) n-for-each-par-map)
:re-export (future-ref)
:export-syntax (begin-thread :export-syntax (begin-thread
parallel parallel
letpar letpar
make-thread make-thread
with-mutex with-mutex
monitor) monitor))
:re-export-syntax (future))
(define ((par-mapper mapper) proc . arglists) (define ((par-mapper mapper) proc . arglists)
(mapper future-ref (mapper thread-join
(apply map (apply map
(lambda args (lambda args
(future (apply proc args))) (begin-thread (apply proc args)))
arglists))) arglists)))
(define par-map (par-mapper map)) (define par-map (par-mapper map))
@ -60,15 +58,15 @@
(define (n-par-map n proc . arglists) (define (n-par-map n proc . arglists)
(let* ((m (make-mutex)) (let* ((m (make-mutex))
(futures '()) (threads '())
(results (make-list (length (car arglists)))) (results (make-list (length (car arglists))))
(result results)) (result results))
(do ((i 0 (+ 1 i))) (do ((i 0 (+ 1 i)))
((= i n) ((= i n)
(for-each future-ref futures) (for-each thread-join threads)
results) results)
(set! futures (set! threads
(cons (future (cons (begin-thread
(let loop () (let loop ()
(lock-mutex m) (lock-mutex m)
(if (null? result) (if (null? result)
@ -80,16 +78,16 @@
(unlock-mutex m) (unlock-mutex m)
(set-car! my-result (apply proc args)) (set-car! my-result (apply proc args))
(loop))))) (loop)))))
futures))))) threads)))))
(define (n-par-for-each n proc . arglists) (define (n-par-for-each n proc . arglists)
(let ((m (make-mutex)) (let ((m (make-mutex))
(futures '())) (threads '()))
(do ((i 0 (+ 1 i))) (do ((i 0 (+ 1 i)))
((= i n) ((= i n)
(for-each future-ref futures)) (for-each thread-join futures))
(set! futures (set! threads
(cons (future (cons (begin-thread
(let loop () (let loop ()
(lock-mutex m) (lock-mutex m)
(if (null? (car arglists)) (if (null? (car arglists))
@ -99,7 +97,7 @@
(unlock-mutex m) (unlock-mutex m)
(apply proc args) (apply proc args)
(loop))))) (loop)))))
futures))))) threads)))))
;;; The following procedure is motivated by the common and important ;;; The following procedure is motivated by the common and important
;;; case where a lot of work should be done, (not too much) in parallel, ;;; case where a lot of work should be done, (not too much) in parallel,
@ -110,15 +108,15 @@
"Using N parallel processes, apply S-PROC in serial order on the results "Using N parallel processes, apply S-PROC in serial order on the results
of applying P-PROC on ARGLISTS." of applying P-PROC on ARGLISTS."
(let* ((m (make-mutex)) (let* ((m (make-mutex))
(futures '()) (threads '())
(no-result '(no-value)) (no-result '(no-value))
(results (make-list (length (car arglists)) no-result)) (results (make-list (length (car arglists)) no-result))
(result results)) (result results))
(do ((i 0 (+ 1 i))) (do ((i 0 (+ 1 i)))
((= i n) ((= i n)
(for-each future-ref futures)) (for-each thread-join futures))
(set! futures (set! threads
(cons (future (cons (begin-thread
(let loop () (let loop ()
(lock-mutex m) (lock-mutex m)
(cond ((null? results) (cond ((null? results)
@ -143,7 +141,7 @@ of applying P-PROC on ARGLISTS."
(unlock-mutex m) (unlock-mutex m)
(set-car! my-result (apply p-proc args)) (set-car! my-result (apply p-proc args))
(loop)))))) (loop))))))
futures))))) threads)))))
(define (thread-handler tag . args) (define (thread-handler tag . args)
(fluid-set! the-last-stack #f) (fluid-set! the-last-stack #f)
@ -169,7 +167,7 @@ of applying P-PROC on ARGLISTS."
#f)) #f))
;;; Set system thread handler ;;; Set system thread handler
(set! %thread-handler thread-handler) (define %thread-handler thread-handler)
; --- MACROS ------------------------------------------------------- ; --- MACROS -------------------------------------------------------
@ -189,8 +187,8 @@ of applying P-PROC on ARGLISTS."
(make-symbol "f")) (make-symbol "f"))
forms))) forms)))
`((lambda ,vars `((lambda ,vars
(values ,@(map (lambda (v) `(future-ref ,v)) vars))) (values ,@(map (lambda (v) `(thread-join ,v)) vars)))
,@(map (lambda (form) `(future ,form)) forms)))))) ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
(define-macro (letpar bindings . body) (define-macro (letpar bindings . body)
(cond ((or (null? bindings) (null? (cdr bindings))) (cond ((or (null? bindings) (null? (cdr bindings)))
@ -199,8 +197,8 @@ of applying P-PROC on ARGLISTS."
(let ((vars (map car bindings))) (let ((vars (map car bindings)))
`((lambda ,vars `((lambda ,vars
((lambda ,vars ,@body) ((lambda ,vars ,@body)
,@(map (lambda (v) `(future-ref ,v)) vars))) ,@(map (lambda (v) `(thread-join ,v)) vars)))
,@(map (lambda (b) `(future ,(cadr b))) bindings)))))) ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
(define-macro (make-thread proc . args) (define-macro (make-thread proc . args)
`(call-with-new-thread `(call-with-new-thread

View file

@ -1,3 +1,7 @@
2006-01-29 Marius Vollmer <mvo@zagadka.de>
* tests/time.test: Replaced 'futures' with threads.
2005-11-30 Kevin Ryde <user42@zip.com.au> 2005-11-30 Kevin Ryde <user42@zip.com.au>
* tests/srfi-13.test (string-append/shared): New tests. * tests/srfi-13.test (string-append/shared): New tests.

View file

@ -40,9 +40,9 @@
(alarm 5) (alarm 5)
(false-if-exception (gmtime t)) (false-if-exception (gmtime t))
(future-ref (future (catch 'out-of-range (thread-join (begin-thread (catch 'out-of-range
(lambda () (gmtime t)) (lambda () (gmtime t))
(lambda args #f)))) (lambda args #f))))
(alarm 0) (alarm 0)
#t)) #t))
@ -118,6 +118,6 @@
(alarm 5) (alarm 5)
(false-if-exception (false-if-exception
(strptime "%a" "nosuchday")) (strptime "%a" "nosuchday"))
(future-ref (future (strptime "%d" "1"))) (thread-join (begin-thread (strptime "%d" "1")))
(alarm 0) (alarm 0)
#t)) #t))