summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-10-23 20:28:48 +0200
committerAndy Wingo <wingo@pobox.com>2016-10-23 22:29:44 +0200
commitd74e0fed0d79f4ae30aa1acf309f47cfade5c589 (patch)
tree0187b57092522854ddcdc927c8e1a7e597271af3 /module
parent56b490a4dd9b8d775d476154c0d4b96483b49436 (diff)
downloadguile-d74e0fed0d79f4ae30aa1acf309f47cfade5c589.tar.gz
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.
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm8
-rw-r--r--module/ice-9/deprecated.scm58
-rw-r--r--module/ice-9/futures.scm1
-rw-r--r--module/ice-9/threads.scm129
-rw-r--r--module/language/cps/intmap.scm1
-rw-r--r--module/language/cps/intset.scm1
-rw-r--r--module/language/cps/reify-primitives.scm1
-rw-r--r--module/language/tree-il/primitives.scm1
-rw-r--r--module/srfi/srfi-18.scm222
9 files changed, 259 insertions, 163 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 48ea61d77..7f620979d 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 375846ff3..de917df52 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 90bbe53ff..cc57e5c61 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 <ludo@gnu.org>
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 14da11339..49d070b99 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 c29fa9ef4..3a4f51776 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 cdf1fbe82..09af0eaa3 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 df4dd248c..60be330b2 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 71db1a635..be613c714 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 832b43606..e2d904770 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