mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 08:40:19 +02:00
Code Activity

Move thread bindings to (ice-9 threads)

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-10-23 20:28:48 +02:00
parent 56b490a4dd
commit d74e0fed0d
18 changed files with 328 additions and 202 deletions
Download patch file Download diff file Expand all files Collapse all files

8
module/ice-9/boot-9.scm
View file

@ -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.
;;;

58
module/ice-9/deprecated.scm
View file

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

1
module/ice-9/futures.scm
View file

@ -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>

129
module/ice-9/threads.scm
View file

@ -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

1
module/language/cps/intmap.scm
View file

@ -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?

1
module/language/cps/intset.scm
View file

@ -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?

1
module/language/cps/reify-primitives.scm
View file

@ -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!

1
module/language/tree-il/primitives.scm
View file

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

214
module/srfi/srfi-18.scm
View file

@ -31,66 +31,63 @@
;;; Code:
(define-module (srfi srfi-18)
:use-module (srfi srfi-34)
:export (
#: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!
;;; 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
make-mutex
mutex-name
mutex-specific
mutex-specific-set!
mutex-state
mutex-lock!
mutex-unlock!
;;; Mutexes
;; mutex? <= in the core
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!
;;; 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
;; 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))
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))
(if (not (provided? 'threads))
(error "SRFI-18 requires Guile with threads support"))
(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