summaryrefslogtreecommitdiff
path: root/module/srfi
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/srfi
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/srfi')
-rw-r--r--module/srfi/srfi-18.scm222
1 files changed, 111 insertions, 111 deletions
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