[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/03: Move thread bindings to (ice-9 threads)
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/03: Move thread bindings to (ice-9 threads) |
|
Date: |
Sun, 23 Oct 2016 20:34:19 +0000 (UTC) |
wingo pushed a commit to branch master
in repository guile.
commit d74e0fed0d79f4ae30aa1acf309f47cfade5c589
Author: Andy Wingo <address@hidden>
Date: Sun Oct 23 20:28:48 2016 +0200
Move thread bindings to (ice-9 threads)
* libguile/init.c (scm_i_init_guile): Don't call scm_init_thread_procs.
* libguile/threads.c (scm_init_ice_9_threads): Rename from
scm_init_thread_procs, make static.
(scm_init_threads): Register scm_init_thread_procs extension.
* libguile/threads.h (scm_init_thread_procs): Remove decl.
* module/ice-9/boot-9.scm: Load (ice-9 threads), so that related side
effects occur early.
* module/ice-9/deprecated.scm (define-deprecated): Fix to allow
deprecated bindings to appear in operator position. Export deprecated
bindings.
(define-deprecated/threads, define-deprecated/threads*): Trampoline
thread bindings to (ice-9 threads).
* module/ice-9/futures.scm: Use ice-9 threads.
* module/ice-9/threads.scm: Load scm_init_ice_9_threads extension.
Reorder definitions and imports so that the module circularity
with (ice-9 futures) continues to work.
* module/language/cps/intmap.scm:
* module/language/cps/intset.scm:
* module/language/tree-il/primitives.scm: Use (ice-9 threads).
* module/language/cps/reify-primitives.scm: Reify current-thread
in (ice-9 threads) module.
* module/srfi/srfi-18.scm: Use ice-9 threads with a module prefix, and
adapt all users. Use proper keywords in module definition form.
* test-suite/tests/filesys.test (test-suite):
* test-suite/tests/fluids.test (test-suite):
* test-suite/tests/srfi-18.test: Use ice-9 threads.
* NEWS: Add entry.
* doc/ref/api-scheduling.texi (Threads): Update.
* doc/ref/posix.texi (Processes): Move current-processor-count and
total-processor-count docs to Threads.
---
NEWS | 9 ++
doc/ref/api-scheduling.texi | 44 +++++-
doc/ref/posix.texi | 25 +---
libguile/init.c | 1 -
libguile/threads.c | 16 ++-
libguile/threads.h | 1 -
module/ice-9/boot-9.scm | 8 ++
module/ice-9/deprecated.scm | 58 +++++++-
module/ice-9/futures.scm | 1 +
module/ice-9/threads.scm | 129 ++++++++++-------
module/language/cps/intmap.scm | 1 +
module/language/cps/intset.scm | 1 +
module/language/cps/reify-primitives.scm | 1 +
module/language/tree-il/primitives.scm | 1 +
module/srfi/srfi-18.scm | 222 +++++++++++++++---------------
test-suite/tests/filesys.test | 1 +
test-suite/tests/fluids.test | 5 +-
test-suite/tests/srfi-18.test | 14 +-
18 files changed, 332 insertions(+), 206 deletions(-)
diff --git a/NEWS b/NEWS
index 7402cad..0702eb2 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,15 @@ Changes in 2.1.5 (changes since the 2.1.4 alpha release):
* New interfaces
* Performance improvements
* Incompatible changes
+** Threading facilities moved to (ice-9 threads)
+
+It used to be that call-with-new-thread and other threading primitives
+were available in the default environment. This is no longer the case;
+they have been moved to (ice-9 threads) instead. Existing code will not
+break, however; we used the deprecation facility to signal a warning
+message while also providing these bindings in the root environment for
+the duration of the 2.2 series.
+
* New deprecations
** Arbiters deprecated
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index a13208a..551b3fb 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -37,6 +37,12 @@ the system's POSIX threads. For application-level
parallelism, using
higher-level constructs, such as futures, is recommended
(@pxref{Futures}).
+To use these facilities, load the @code{(ice-9 threads)} module.
+
address@hidden
+(use-modules (ice-9 threads))
address@hidden example
+
@deffn {Scheme Procedure} all-threads
@deffnx {C Function} scm_all_threads ()
Return a list of all threads.
@@ -142,10 +148,6 @@ Return the cleanup handler currently installed for the
thread
thread-cleanup returns @code{#f}.
@end deffn
-Higher level thread procedures are available by loading the
address@hidden(ice-9 threads)} module. These provide standardized
-thread creation.
-
@deffn macro make-thread proc arg @dots{}
Apply @var{proc} to @var{arg} @dots{} in a new thread formed by
@code{call-with-new-thread} using a default error handler that display
@@ -159,6 +161,34 @@ Evaluate forms @var{expr1} @var{expr2} @dots{} in a new
thread formed by
the error to the current error port.
@end deffn
+One often wants to limit the number of threads running to be
+proportional to the number of available processors. These interfaces
+are therefore exported by (ice-9 threads) as well.
+
address@hidden {Scheme Procedure} total-processor-count
address@hidden {C Function} scm_total_processor_count ()
+Return the total number of processors of the machine, which
+is guaranteed to be at least 1. A ``processor'' here is a
+thread execution unit, which can be either:
+
address@hidden
address@hidden an execution core in a (possibly multi-core) chip, in a
+ (possibly multi- chip) module, in a single computer, or
address@hidden a thread execution unit inside a core in the case of
+ @dfn{hyper-threaded} CPUs.
address@hidden itemize
+
+Which of the two definitions is used, is unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} current-processor-count
address@hidden {C Function} scm_current_processor_count ()
+Like @code{total-processor-count}, but return the number of
+processors available to the current process. See
address@hidden and @code{getaffinity} for more
+information.
address@hidden deffn
+
@node Asyncs
@subsection Asynchronous Interrupts
@@ -350,6 +380,12 @@ then an endless wait will occur (in the current
implementation).
Acquiring requisite mutexes in a fixed order (like always A before B)
in all threads is one way to avoid such problems.
+To use these facilities, load the @code{(ice-9 threads)} module.
+
address@hidden
+(use-modules (ice-9 threads))
address@hidden example
+
@sp 1
@deffn {Scheme Procedure} make-mutex flag @dots{}
@deffnx {C Function} scm_make_mutex ()
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 1c2c1f3..bcb16bd 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -1976,29 +1976,8 @@ Currently this procedure is only defined on GNU variants
GNU C Library Reference Manual}).
@end deffn
address@hidden {Scheme Procedure} total-processor-count
address@hidden {C Function} scm_total_processor_count ()
-Return the total number of processors of the machine, which
-is guaranteed to be at least 1. A ``processor'' here is a
-thread execution unit, which can be either:
-
address@hidden
address@hidden an execution core in a (possibly multi-core) chip, in a
- (possibly multi- chip) module, in a single computer, or
address@hidden a thread execution unit inside a core in the case of
- @dfn{hyper-threaded} CPUs.
address@hidden itemize
-
-Which of the two definitions is used, is unspecified.
address@hidden deffn
-
address@hidden {Scheme Procedure} current-processor-count
address@hidden {C Function} scm_current_processor_count ()
-Like @code{total-processor-count}, but return the number of
-processors available to the current process. See
address@hidden and @code{getaffinity} for more
-information.
address@hidden deffn
address@hidden, for information on how get the number of processors
+available on a system.
@node Signals
diff --git a/libguile/init.c b/libguile/init.c
index 31363c6..4b95f36 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -415,7 +415,6 @@ scm_i_init_guile (void *base)
scm_init_root (); /* requires continuations */
scm_init_threads (); /* requires smob_prehistory */
scm_init_gsubr ();
- scm_init_thread_procs (); /* requires gsubrs */
scm_init_procprop ();
scm_init_alist ();
scm_init_async (); /* requires smob_prehistory */
diff --git a/libguile/threads.c b/libguile/threads.c
index b609930..9f11ac7 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -2093,6 +2093,12 @@ scm_t_bits scm_tc16_thread;
scm_t_bits scm_tc16_mutex;
scm_t_bits scm_tc16_condvar;
+static void
+scm_init_ice_9_threads (void *unused)
+{
+#include "libguile/threads.x"
+}
+
void
scm_init_threads ()
{
@@ -2111,6 +2117,10 @@ scm_init_threads ()
threads_initialized_p = 1;
dynwind_critical_section_mutex = scm_make_recursive_mutex ();
+
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_ice_9_threads",
+ scm_init_ice_9_threads, NULL);
}
void
@@ -2120,12 +2130,6 @@ scm_init_threads_default_dynamic_state ()
scm_i_default_dynamic_state = state;
}
-void
-scm_init_thread_procs ()
-{
-#include "libguile/threads.x"
-}
-
/* IA64-specific things. */
diff --git a/libguile/threads.h b/libguile/threads.h
index 6b85baf..a8bb21a 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -141,7 +141,6 @@ SCM_API void *scm_with_guile (void *(*func)(void *), void
*data);
SCM_INTERNAL void scm_i_reset_fluid (size_t);
SCM_INTERNAL void scm_threads_prehistory (void *);
SCM_INTERNAL void scm_init_threads (void);
-SCM_INTERNAL void scm_init_thread_procs (void);
SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs
(scm_i_pthread_mutex_t *mutex);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 48ea61d..7f62097 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4067,6 +4067,14 @@ when none is available, reading FILE-NAME with READER."
+;;; {Threads}
+;;;
+
+;; Load (ice-9 threads), initializing some internal data structures.
+(resolve-interface '(ice-9 threads))
+
+
+
;;; SRFI-4 in the default environment. FIXME: we should figure out how
;;; to deprecate this.
;;;
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 375846f..de917df 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -16,14 +16,17 @@
;;;;
(define-module (ice-9 deprecated)
- #:export (_IONBF _IOLBF _IOFBF))
+ #:use-module ((ice-9 threads) #:prefix threads:))
(define-syntax-rule (define-deprecated var msg exp)
- (define-syntax var
- (lambda (x)
- (issue-deprecation-warning msg)
- (syntax-case x ()
- (id (identifier? #'id) #'exp)))))
+ (begin
+ (define-syntax var
+ (lambda (x)
+ (issue-deprecation-warning msg)
+ (syntax-case x ()
+ ((id arg (... ...)) #'(let ((x id)) (x arg (... ...))))
+ (id (identifier? #'id) #'exp))))
+ (export var)))
(define-deprecated _IONBF
"`_IONBF' is deprecated. Use the symbol 'none instead."
@@ -34,3 +37,46 @@
(define-deprecated _IOFBF
"`_IOFBF' is deprecated. Use the symbol 'block instead."
'block)
+
+(define-syntax define-deprecated/threads
+ (lambda (stx)
+ (define (threads-name id)
+ (datum->syntax id (symbol-append 'threads: (syntax->datum id))))
+ (syntax-case stx ()
+ ((_ name)
+ (with-syntax ((name* (threads-name #'name))
+ (warning (string-append
+ "Import (ice-9 threads) to have access to `"
+ (symbol->string (syntax->datum #'name)) "'.")))
+ #'(define-deprecated name warning name*))))))
+
+(define-syntax-rule (define-deprecated/threads* name ...)
+ (begin (define-deprecated/threads name) ...))
+
+(define-deprecated/threads*
+ call-with-new-thread
+ yield
+ cancel-thread
+ set-thread-cleanup!
+ thread-cleanup
+ join-thread
+ thread?
+ make-mutex
+ make-recursive-mutex
+ lock-mutex
+ try-mutex
+ unlock-mutex
+ mutex?
+ mutex-owner
+ mutex-level
+ mutex-locked?
+ make-condition-variable
+ wait-condition-variable
+ signal-condition-variable
+ broadcast-condition-variable
+ condition-variable?
+ current-thread
+ all-threads
+ thread-exited?
+ total-processor-count
+ current-processor-count)
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 90bbe53..cc57e5c 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -24,6 +24,7 @@
#:use-module (ice-9 q)
#:use-module (ice-9 match)
#:use-module (ice-9 control)
+ #:use-module (ice-9 threads)
#:export (future make-future future? touch))
;;; Author: Ludovic Courtès <address@hidden>
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 14da113..49d070b 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -26,22 +26,50 @@
;;; 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)
- #:use-module (ice-9 futures)
#:use-module (ice-9 match)
+ ;; These bindings are marked as #:replace because when deprecated code
+ ;; is enabled, (ice-9 deprecated) also exports these names.
+ ;; (Referencing one of the deprecated names prints a warning directing
+ ;; the user to these bindings.) Anyway once we can remove the
+ ;; deprecated bindings, we should use #:export instead of #:replace
+ ;; for these.
+ #:replace (call-with-new-thread
+ yield
+ cancel-thread
+ set-thread-cleanup!
+ thread-cleanup
+ join-thread
+ thread?
+ make-mutex
+ make-recursive-mutex
+ lock-mutex
+ try-mutex
+ unlock-mutex
+ mutex?
+ mutex-owner
+ mutex-level
+ mutex-locked?
+ make-condition-variable
+ wait-condition-variable
+ signal-condition-variable
+ broadcast-condition-variable
+ condition-variable?
+ current-thread
+ all-threads
+ thread-exited?
+ total-processor-count
+ current-processor-count)
#:export (begin-thread
- parallel
- letpar
make-thread
with-mutex
monitor
+ parallel
+ letpar
par-map
par-for-each
n-par-map
@@ -49,6 +77,13 @@
n-for-each-par-map
%thread-handler))
+;; Note that this extension also defines %make-transcoded-port, which is
+;; not exported but is used by (rnrs io ports).
+
+(eval-when (expand eval load)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_ice_9_threads"))
+
;;; Macros first, so that the procedures expand correctly.
@@ -58,21 +93,6 @@
(lambda () e0 e1 ...)
%thread-handler))
-(define-syntax parallel
- (lambda (x)
- (syntax-case x ()
- ((_ e0 ...)
- (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
- #'(let ((tmp0 (future e0))
- ...)
- (values (touch tmp0) ...)))))))
-
-(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
- (call-with-values
- (lambda () (parallel e ...))
- (lambda (v ...)
- b0 b1 ...)))
-
(define-syntax-rule (make-thread proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
@@ -104,6 +124,48 @@
#`(with-mutex (monitor-mutex-with-id '#,id)
body body* ...))))))
+(define (thread-handler tag . args)
+ (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)
+
+(use-modules (ice-9 futures))
+
+(define-syntax parallel
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e0 ...)
+ (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
+ #'(let ((tmp0 (future e0))
+ ...)
+ (values (touch tmp0) ...)))))))
+
+(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
+ (call-with-values
+ (lambda () (parallel e ...))
+ (lambda (v ...)
+ b0 b1 ...)))
+
(define (par-mapper mapper cons)
(lambda (proc . lists)
(let loop ((lists lists))
@@ -205,29 +267,4 @@ of applying P-PROC on ARGLISTS."
(loop))))))
threads)))))
-(define (thread-handler tag . args)
- (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)
-
;;; threads.scm ends here
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index c29fa9e..3a4f517 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -34,6 +34,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
+ #:use-module ((ice-9 threads) #:select (current-thread))
#:export (empty-intmap
intmap?
transient-intmap?
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index cdf1fbe..09af0ea 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -29,6 +29,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
+ #:use-module ((ice-9 threads) #:select (current-thread))
#:export (empty-intset
intset?
transient-intset?
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index df4dd24..60be330 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -79,6 +79,7 @@
make-atomic-box atomic-box-ref atomic-box-set!
atomic-box-swap! atomic-box-compare-and-swap!)
'(ice-9 atomic))
+ ((current-thread) '(ice-9 threads))
((class-of) '(oop goops))
((u8vector-ref
u8vector-set! s8vector-ref s8vector-set!
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 71db1a6..be613c7 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -21,6 +21,7 @@
(define-module (language tree-il primitives)
#:use-module (system base pmatch)
#:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (system base syntax)
#:use-module (language tree-il)
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 832b436..e2d9047 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -31,66 +31,63 @@
;;; Code:
(define-module (srfi srfi-18)
- :use-module (srfi srfi-34)
- :export (
-
-;;; Threads
- ;; current-thread <= in the core
- ;; thread? <= in the core
- make-thread
- thread-name
- thread-specific
- thread-specific-set!
- thread-start!
- thread-yield!
- thread-sleep!
- thread-terminate!
- thread-join!
-
-;;; Mutexes
- ;; mutex? <= in the core
- make-mutex
- mutex-name
- mutex-specific
- mutex-specific-set!
- mutex-state
- mutex-lock!
- mutex-unlock!
-
-;;; Condition variables
- ;; condition-variable? <= in the core
- make-condition-variable
- condition-variable-name
- condition-variable-specific
- condition-variable-specific-set!
- condition-variable-signal!
- condition-variable-broadcast!
- condition-variable-wait!
-
-;;; Time
- current-time
- time?
- time->seconds
- seconds->time
+ #:use-module ((ice-9 threads) #:prefix threads:)
+ #:use-module (srfi srfi-34)
+ #:export (;; Threads
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+ thread-sleep!
+ thread-terminate!
+ thread-join!
+
+ ;; Mutexes
+ make-mutex
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-lock!
+ mutex-unlock!
+
+ ;; Condition variables
+ make-condition-variable
+ condition-variable-name
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable-signal!
+ condition-variable-broadcast!
+ condition-variable-wait!
+
+ ;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
- current-exception-handler
- with-exception-handler
- raise
- join-timeout-exception?
- abandoned-mutex-exception?
- terminated-thread-exception?
- uncaught-exception?
- uncaught-exception-reason
- )
- :re-export (current-thread thread? mutex? condition-variable?)
- :replace (current-time
- make-thread
- make-mutex
- make-condition-variable
- raise))
-
-(if (not (provided? 'threads))
- (error "SRFI-18 requires Guile with threads support"))
+ current-exception-handler
+ with-exception-handler
+ raise
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason)
+ #:re-export ((threads:condition-variable? . condition-variable?)
+ (threads:current-thread . current-thread)
+ (threads:thread? . thread?)
+ (threads:mutex? . mutex?))
+ #:replace (current-time
+ make-thread
+ make-mutex
+ make-condition-variable
+ raise))
+
+(unless (provided? 'threads)
+ (error "SRFI-18 requires Guile with threads support"))
(cond-expand-provide (current-module) '(srfi-18))
@@ -121,7 +118,7 @@
(define (srfi-18-exception-preserver obj)
(if (or (terminated-thread-exception? obj)
(uncaught-exception? obj))
- (set! (thread->exception (current-thread)) obj)))
+ (set! (thread->exception (threads:current-thread)) obj)))
(define (srfi-18-exception-handler key . args)
@@ -135,12 +132,12 @@
(cons* uncaught-exception key args)))))
(define (current-handler-stack)
- (let ((ct (current-thread)))
+ (let ((ct (threads:current-thread)))
(or (hashq-ref thread-exception-handlers ct)
(hashq-set! thread-exception-handlers ct (list initial-handler)))))
(define (with-exception-handler handler thunk)
- (let ((ct (current-thread))
+ (let ((ct (threads:current-thread))
(hl (current-handler-stack)))
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
@@ -176,12 +173,12 @@
(define make-thread
(let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
(lambda ()
- (lock-mutex lmutex)
- (signal-condition-variable lcond)
- (lock-mutex smutex)
- (unlock-mutex lmutex)
- (wait-condition-variable scond smutex)
- (unlock-mutex smutex)
+ (threads:lock-mutex lmutex)
+ (threads:signal-condition-variable lcond)
+ (threads:lock-mutex smutex)
+ (threads:unlock-mutex lmutex)
+ (threads:wait-condition-variable scond smutex)
+ (threads:unlock-mutex smutex)
(with-exception-handler initial-handler
thunk)))))
(lambda (thunk . name)
@@ -192,40 +189,42 @@
(sm (make-mutex 'start-mutex))
(sc (make-condition-variable 'start-condition-variable)))
- (lock-mutex lm)
- (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
- srfi-18-exception-handler)))
+ (threads:lock-mutex lm)
+ (let ((t (threads:call-with-new-thread
+ (make-cond-wrapper thunk lc lm sc sm)
+ srfi-18-exception-handler)))
(hashq-set! thread-start-conds t (cons sm sc))
(and n (hashq-set! object-names t n))
- (wait-condition-variable lc lm)
- (unlock-mutex lm)
+ (threads:wait-condition-variable lc lm)
+ (threads:unlock-mutex lm)
t)))))
(define (thread-name thread)
- (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+ (hashq-ref object-names
+ (check-arg-type threads:thread? thread "thread-name")))
(define (thread-specific thread)
(hashq-ref object-specifics
- (check-arg-type thread? thread "thread-specific")))
+ (check-arg-type threads:thread? thread "thread-specific")))
(define (thread-specific-set! thread obj)
(hashq-set! object-specifics
- (check-arg-type thread? thread "thread-specific-set!")
+ (check-arg-type threads:thread? thread "thread-specific-set!")
obj)
*unspecified*)
(define (thread-start! thread)
(let ((x (hashq-ref thread-start-conds
- (check-arg-type thread? thread "thread-start!"))))
+ (check-arg-type threads:thread? thread "thread-start!"))))
(and x (let ((smutex (car x))
(scond (cdr x)))
(hashq-remove! thread-start-conds thread)
- (lock-mutex smutex)
- (signal-condition-variable scond)
- (unlock-mutex smutex)))
+ (threads:lock-mutex smutex)
+ (threads:signal-condition-variable scond)
+ (threads:unlock-mutex smutex)))
thread))
-(define (thread-yield!) (yield) *unspecified*)
+(define (thread-yield!) (threads:yield) *unspecified*)
(define (thread-sleep! timeout)
(let* ((ct (time->seconds (current-time)))
@@ -259,25 +258,27 @@
(define (thread-terminate! thread)
(define (thread-terminate-inner!)
- (let ((current-handler (thread-cleanup thread)))
+ (let ((current-handler (threads:thread-cleanup thread)))
(if (thunk? current-handler)
- (set-thread-cleanup! thread
- (lambda ()
- (with-exception-handler initial-handler
- current-handler)
- (srfi-18-exception-preserver
- terminated-thread-exception)))
- (set-thread-cleanup! thread
- (lambda () (srfi-18-exception-preserver
- terminated-thread-exception))))
- (cancel-thread thread)
+ (threads:set-thread-cleanup!
+ thread
+ (lambda ()
+ (with-exception-handler initial-handler
+ current-handler)
+ (srfi-18-exception-preserver
+ terminated-thread-exception)))
+ (threads:set-thread-cleanup!
+ thread
+ (lambda () (srfi-18-exception-preserver
+ terminated-thread-exception))))
+ (threads:cancel-thread thread)
*unspecified*))
(thread-terminate-inner!))
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
- (let ((v (apply join-thread thread args))
+ (let ((v (apply threads:join-thread thread args))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
@@ -291,41 +292,40 @@
(define make-mutex
(lambda name
(let ((n (and (pair? name) (car name)))
- (m ((@ (guile) make-mutex)
- 'unchecked-unlock
- 'allow-external-unlock
- 'recursive)))
+ (m (threads:make-mutex 'unchecked-unlock
+ 'allow-external-unlock
+ 'recursive)))
(and n (hashq-set! object-names m n)) m)))
(define (mutex-name mutex)
- (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+ (hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name")))
(define (mutex-specific mutex)
(hashq-ref object-specifics
- (check-arg-type mutex? mutex "mutex-specific")))
+ (check-arg-type threads:mutex? mutex "mutex-specific")))
(define (mutex-specific-set! mutex obj)
(hashq-set! object-specifics
- (check-arg-type mutex? mutex "mutex-specific-set!")
+ (check-arg-type threads:mutex? mutex "mutex-specific-set!")
obj)
*unspecified*)
(define (mutex-state mutex)
- (let ((owner (mutex-owner mutex)))
+ (let ((owner (threads:mutex-owner mutex)))
(if owner
- (if (thread-exited? owner) 'abandoned owner)
- (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
+ (if (threads:thread-exited? owner) 'abandoned owner)
+ (if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned))))
(define (mutex-lock! mutex . args)
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
- (lambda () (apply lock-mutex mutex args))
+ (lambda () (apply threads:lock-mutex mutex args))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (mutex-unlock! mutex . args)
- (apply unlock-mutex mutex args))
+ (apply threads:unlock-mutex mutex args))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
@@ -333,33 +333,33 @@
(define make-condition-variable
(lambda name
(let ((n (and (pair? name) (car name)))
- (m ((@ (guile) make-condition-variable))))
+ (m (threads:make-condition-variable)))
(and n (hashq-set! object-names m n)) m)))
(define (condition-variable-name condition-variable)
- (hashq-ref object-names (check-arg-type condition-variable?
+ (hashq-ref object-names (check-arg-type threads:condition-variable?
condition-variable
"condition-variable-name")))
(define (condition-variable-specific condition-variable)
- (hashq-ref object-specifics (check-arg-type condition-variable?
+ (hashq-ref object-specifics (check-arg-type threads:condition-variable?
condition-variable
"condition-variable-specific")))
(define (condition-variable-specific-set! condition-variable obj)
(hashq-set! object-specifics
- (check-arg-type condition-variable?
+ (check-arg-type threads:condition-variable?
condition-variable
"condition-variable-specific-set!")
obj)
*unspecified*)
(define (condition-variable-signal! cond)
- (signal-condition-variable cond)
+ (threads:signal-condition-variable cond)
*unspecified*)
(define (condition-variable-broadcast! cond)
- (broadcast-condition-variable cond)
+ (threads:broadcast-condition-variable cond)
*unspecified*)
;; TIME
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 253c32a..fceb182 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -19,6 +19,7 @@
(define-module (test-suite test-filesys)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
+ #:use-module (ice-9 threads)
#:use-module (ice-9 match)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors))
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 9ad9e81..ce7e625 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -18,8 +18,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-fluids)
- :use-module (test-suite lib)
- :use-module (system base compile))
+ #:use-module (ice-9 threads)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile))
(define exception:syntax-error
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index ab05513..5fba80e 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -18,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-srfi-18)
+ #:use-module ((ice-9 threads) #:prefix threads:)
#:use-module (test-suite lib))
;; two expressions so that the srfi-18 import is in effect for expansion
@@ -43,9 +44,9 @@
(with-test-prefix "make-thread"
(pass-if "make-thread creates new thread"
- (let* ((n (length (all-threads)))
+ (let* ((n (length (threads:all-threads)))
(t (make-thread (lambda () 'foo) 'make-thread-1))
- (r (> (length (all-threads)) n)))
+ (r (> (length (threads:all-threads)) n)))
(thread-terminate! t) r)))
(with-test-prefix "thread-name"
@@ -110,7 +111,7 @@
(pass-if "termination destroys non-started thread"
(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
- (num-threads (length (all-threads)))
+ (num-threads (length (threads:all-threads)))
(success #f))
(thread-terminate! t)
(with-exception-handler
@@ -375,7 +376,8 @@
(mutex-unlock! m1)))
(dec-sem! (lambda ()
(mutex-lock! m1)
- (while (eqv? sem 0) (wait-condition-variable c1 m1))
+ (while (eqv? sem 0)
+ (threads:wait-condition-variable c1 m1))
(set! sem (- sem 1))
(mutex-unlock! m1)))
(t1 (make-thread (lambda ()
@@ -449,13 +451,13 @@
h2 (lambda ()
(mutex-lock! m)
(condition-variable-signal! c)
- (wait-condition-variable c m)
+ (threads:wait-condition-variable c m)
(and (eq? (current-exception-handler) h2)
(mutex-unlock! m)))))
'current-exception-handler-4)))
(mutex-lock! m)
(thread-start! t)
- (wait-condition-variable c m)
+ (threads:wait-condition-variable c m)
(and (eq? (current-exception-handler) h1)
(condition-variable-signal! c)
(mutex-unlock! m)