diff options
author | Andy Wingo <wingo@pobox.com> | 2016-10-23 20:28:48 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-10-23 22:29:44 +0200 |
commit | d74e0fed0d79f4ae30aa1acf309f47cfade5c589 (patch) | |
tree | 0187b57092522854ddcdc927c8e1a7e597271af3 /module | |
parent | 56b490a4dd9b8d775d476154c0d4b96483b49436 (diff) | |
download | guile-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.scm | 8 | ||||
-rw-r--r-- | module/ice-9/deprecated.scm | 58 | ||||
-rw-r--r-- | module/ice-9/futures.scm | 1 | ||||
-rw-r--r-- | module/ice-9/threads.scm | 129 | ||||
-rw-r--r-- | module/language/cps/intmap.scm | 1 | ||||
-rw-r--r-- | module/language/cps/intset.scm | 1 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 1 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 1 | ||||
-rw-r--r-- | module/srfi/srfi-18.scm | 222 |
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 |