summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-18.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi/srfi-18.scm')
-rw-r--r--module/srfi/srfi-18.scm382
1 files changed, 382 insertions, 0 deletions
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
new file mode 100644
index 000000000..7177e0690
--- /dev/null
+++ b/module/srfi/srfi-18.scm
@@ -0,0 +1,382 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2008-04-11
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-18 (Multithreading support).
+;;
+;; All procedures defined in SRFI-18, which are not already defined in
+;; the Guile core library, are exported.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-18)
+ #:use-module ((ice-9 threads) #:prefix threads:)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module ((srfi srfi-34) #:prefix srfi-34:)
+ #:use-module ((srfi srfi-35) #:select (define-condition-type
+ &error
+ condition))
+ #: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
+ 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!
+
+ ;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
+
+ current-exception-handler
+ with-exception-handler
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason)
+ #:re-export ((srfi-34:raise . raise))
+ #:replace (current-time
+ current-thread
+ thread?
+ make-thread
+ make-mutex
+ mutex?
+ make-condition-variable
+ condition-variable?))
+
+(unless (provided? 'threads)
+ (error "SRFI-18 requires Guile with threads support"))
+
+(cond-expand-provide (current-module) '(srfi-18))
+
+(define (check-arg-type pred arg caller)
+ (if (pred arg)
+ arg
+ (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S" (list arg) '())))
+
+(define-condition-type &abandoned-mutex-exception &error
+ abandoned-mutex-exception?)
+(define-condition-type &join-timeout-exception &error
+ join-timeout-exception?)
+(define-condition-type &terminated-thread-exception &error
+ terminated-thread-exception?)
+(define-condition-type &uncaught-exception &error
+ uncaught-exception?
+ (reason uncaught-exception-reason))
+
+(define-record-type <mutex>
+ (%make-mutex prim name specific owner abandoned?)
+ mutex?
+ (prim mutex-prim)
+ (name mutex-name)
+ (specific mutex-specific mutex-specific-set!)
+ (owner mutex-owner set-mutex-owner!)
+ (abandoned? mutex-abandoned? set-mutex-abandoned?!))
+
+(define-record-type <condition-variable>
+ (%make-condition-variable prim name specific)
+ condition-variable?
+ (prim condition-variable-prim)
+ (name condition-variable-name)
+ (specific condition-variable-specific condition-variable-specific-set!))
+
+(define-record-type <thread>
+ (%make-thread prim name specific start-conds exception)
+ thread?
+ (prim thread-prim set-thread-prim!)
+ (name thread-name)
+ (specific thread-specific thread-specific-set!)
+ (start-conds thread-start-conds set-thread-start-conds!)
+ (exception thread-exception set-thread-exception!))
+
+(define current-thread (make-parameter (%make-thread #f #f #f #f #f)))
+(define thread-mutexes (make-parameter #f))
+
+(define (timeout->absolute-time timeout)
+ "Return an absolute time in seconds corresponding to TIMEOUT. TIMEOUT
+can be any value authorized by SRFI-18: a number (relative time), a time
+object (absolute point in time), or #f."
+ (cond ((number? timeout) ;seconds relative to now
+ (+ ((@ (guile) current-time)) timeout))
+ ((time? timeout) ;absolute point in time
+ (time->seconds timeout))
+ (else timeout))) ;pair or #f
+
+;; EXCEPTIONS
+
+;; All threads created by SRFI-18 have an initial handler installed that
+;; will squirrel away an uncaught exception to allow it to bubble out to
+;; joining threads. However for the main thread and other threads not
+;; created by SRFI-18, just let the exception bubble up by passing on
+;; doing anything with the exception.
+(define (exception-handler-for-foreign-threads obj)
+ (values))
+
+(define current-exception-handler
+ (make-parameter exception-handler-for-foreign-threads))
+
+(define (with-exception-handler handler thunk)
+ (check-arg-type procedure? handler "with-exception-handler")
+ (check-arg-type thunk? thunk "with-exception-handler")
+ (srfi-34:with-exception-handler
+ (let ((prev-handler (current-exception-handler)))
+ (lambda (obj)
+ (parameterize ((current-exception-handler prev-handler))
+ (handler obj))))
+ (lambda ()
+ (parameterize ((current-exception-handler handler))
+ (thunk)))))
+
+;; THREADS
+
+;; Create a new thread and prevent it from starting using a condition variable.
+;; Once started, install a top-level exception handler that rethrows any
+;; exceptions wrapped in an uncaught-exception wrapper.
+
+(define (with-thread-mutex-cleanup thunk)
+ (let ((mutexes (make-weak-key-hash-table)))
+ (dynamic-wind
+ values
+ (lambda ()
+ (parameterize ((thread-mutexes mutexes))
+ (thunk)))
+ (lambda ()
+ (let ((thread (current-thread)))
+ (hash-for-each (lambda (mutex _)
+ (when (eq? (mutex-owner mutex) thread)
+ (abandon-mutex! mutex)))
+ mutexes))))))
+
+(define* (make-thread thunk #:optional name)
+ (let* ((sm (make-mutex 'start-mutex))
+ (sc (make-condition-variable 'start-condition-variable))
+ (thread (%make-thread #f name #f (cons sm sc) #f)))
+ (mutex-lock! sm)
+ (let ((prim (threads:call-with-new-thread
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (parameterize ((current-thread thread))
+ (with-thread-mutex-cleanup
+ (lambda ()
+ (mutex-lock! sm)
+ (condition-variable-signal! sc)
+ (mutex-unlock! sm sc)
+ (thunk)))))
+ (lambda (key . args)
+ (set-thread-exception!
+ thread
+ (condition (&uncaught-exception
+ (reason
+ (match (cons key args)
+ (('srfi-34 obj) obj)
+ (obj obj))))))))))))
+ (set-thread-prim! thread prim)
+ (mutex-unlock! sm sc)
+ thread)))
+
+(define (thread-start! thread)
+ (match (thread-start-conds thread)
+ ((smutex . scond)
+ (set-thread-start-conds! thread #f)
+ (mutex-lock! smutex)
+ (condition-variable-signal! scond)
+ (mutex-unlock! smutex))
+ (#f #f))
+ thread)
+
+(define (thread-yield!) (threads:yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+ (let* ((t (cond ((time? timeout) (- (time->seconds timeout)
+ (time->seconds (current-time))))
+ ((number? timeout) timeout)
+ (else (scm-error 'wrong-type-arg "thread-sleep!"
+ "Wrong type argument: ~S"
+ (list timeout)
+ '()))))
+ (secs (inexact->exact (truncate t)))
+ (usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
+ (when (> secs 0) (sleep secs))
+ (when (> usecs 0) (usleep usecs))
+ *unspecified*))
+
+;; Whereas SRFI-34 leaves the continuation of a call to an exception
+;; handler unspecified, SRFI-18 has this to say:
+;;
+;; When one of the primitives defined in this SRFI raises an exception
+;; defined in this SRFI, the exception handler is called with the same
+;; continuation as the primitive (i.e. it is a tail call to the
+;; exception handler).
+;;
+;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run
+;; handlers with the continuation of the primitive call, for those
+;; primitives that throw exceptions.
+
+(define (with-exception-handlers-here thunk)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda ()
+ (with-exception-handler (lambda (exn) (abort-to-prompt tag exn))
+ thunk))
+ (lambda (k exn)
+ ((current-exception-handler) exn)))))
+
+;; A unique value.
+(define %cancel-sentinel (list 'cancelled))
+(define (thread-terminate! thread)
+ (threads:cancel-thread (thread-prim thread) %cancel-sentinel)
+ *unspecified*)
+
+;; A unique value.
+(define %timeout-sentinel (list 1))
+(define* (thread-join! thread #:optional (timeout %timeout-sentinel)
+ (timeoutval %timeout-sentinel))
+ (let ((t (thread-prim thread)))
+ (with-exception-handlers-here
+ (lambda ()
+ (let* ((v (if (eq? timeout %timeout-sentinel)
+ (threads:join-thread t)
+ (threads:join-thread t timeout %timeout-sentinel))))
+ (cond
+ ((eq? v %timeout-sentinel)
+ (if (eq? timeoutval %timeout-sentinel)
+ (srfi-34:raise (condition (&join-timeout-exception)))
+ timeoutval))
+ ((eq? v %cancel-sentinel)
+ (srfi-34:raise (condition (&terminated-thread-exception))))
+ ((thread-exception thread) => srfi-34:raise)
+ (else v)))))))
+
+;; MUTEXES
+
+(define* (make-mutex #:optional name)
+ (%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f))
+
+(define (mutex-state mutex)
+ (cond
+ ((mutex-abandoned? mutex) 'abandoned)
+ ((mutex-owner mutex))
+ ((> (threads:mutex-level (mutex-prim mutex)) 0) 'not-owned)
+ (else 'not-abandoned)))
+
+(define (abandon-mutex! mutex)
+ (set-mutex-abandoned?! mutex #t)
+ (threads:unlock-mutex (mutex-prim mutex)))
+
+(define* (mutex-lock! mutex #:optional timeout (thread (current-thread)))
+ (let ((mutexes (thread-mutexes)))
+ (when mutexes
+ (hashq-set! mutexes mutex #t)))
+ (with-exception-handlers-here
+ (lambda ()
+ (cond
+ ((threads:lock-mutex (mutex-prim mutex)
+ (timeout->absolute-time timeout))
+ (set-mutex-owner! mutex thread)
+ (when (mutex-abandoned? mutex)
+ (set-mutex-abandoned?! mutex #f)
+ (srfi-34:raise
+ (condition (&abandoned-mutex-exception))))
+ #t)
+ (else #f)))))
+
+(define %unlock-sentinel (list 'unlock))
+(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
+ (timeout %unlock-sentinel))
+ (let ((timeout (timeout->absolute-time timeout)))
+ (when (mutex-owner mutex)
+ (set-mutex-owner! mutex #f)
+ (cond
+ ((eq? cond-var %unlock-sentinel)
+ (threads:unlock-mutex (mutex-prim mutex)))
+ ((eq? timeout %unlock-sentinel)
+ (threads:wait-condition-variable (condition-variable-prim cond-var)
+ (mutex-prim mutex))
+ (threads:unlock-mutex (mutex-prim mutex)))
+ ((threads:wait-condition-variable (condition-variable-prim cond-var)
+ (mutex-prim mutex)
+ timeout)
+ (threads:unlock-mutex (mutex-prim mutex)))
+ (else #f)))))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define* (make-condition-variable #:optional name)
+ (%make-condition-variable (threads:make-condition-variable) name #f))
+
+(define (condition-variable-signal! cond)
+ (threads:signal-condition-variable (condition-variable-prim cond))
+ *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+ (threads:broadcast-condition-variable (condition-variable-prim cond))
+ *unspecified*)
+
+;; TIME
+
+(define current-time gettimeofday)
+(define (time? obj)
+ (and (pair? obj)
+ (let ((co (car obj))) (and (integer? co) (>= co 0)))
+ (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
+
+(define (time->seconds time)
+ (and (check-arg-type time? time "time->seconds")
+ (+ (car time) (/ (cdr time) 1000000))))
+
+(define (seconds->time x)
+ (and (check-arg-type number? x "seconds->time")
+ (let ((fx (truncate x)))
+ (cons (inexact->exact fx)
+ (inexact->exact (truncate (* (- x fx) 1000000)))))))
+
+;; srfi-18.scm ends here