guile-commits
[Top][All Lists]
Advanced

[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)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]