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:
parent
99e370f645
commit
a64d058951
4 changed files with 35 additions and 29 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.
|
||||||
|
|
|
@ -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))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue