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..925ecb304
--- /dev/null
+++ b/module/srfi/srfi-18.scm
@@ -0,0 +1,382 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008 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 2.1 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 (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
+
+ current-exception-handler
+ with-exception-handler
+ raise
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason
+ )
+ :re-export (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"))
+
+(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 abandoned-mutex-exception (list 'abandoned-mutex-exception))
+(define join-timeout-exception (list 'join-timeout-exception))
+(define terminated-thread-exception (list 'terminated-thread-exception))
+(define uncaught-exception (list 'uncaught-exception))
+
+(define mutex-owners (make-weak-key-hash-table))
+(define object-names (make-weak-key-hash-table))
+(define object-specifics (make-weak-key-hash-table))
+(define thread-start-conds (make-weak-key-hash-table))
+(define thread-exception-handlers (make-weak-key-hash-table))
+
+;; EXCEPTIONS
+
+(define raise (@ (srfi srfi-34) raise))
+(define (initial-handler obj)
+ (srfi-18-exception-preserver (cons uncaught-exception obj)))
+
+(define thread->exception (make-object-property))
+
+(define (srfi-18-exception-preserver obj)
+ (if (or (terminated-thread-exception? obj)
+ (uncaught-exception? obj))
+ (set! (thread->exception (current-thread)) obj)))
+
+(define (srfi-18-exception-handler key . args)
+
+ ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
+ ;; if one is caught at this level, it has already been taken care of by
+ ;; `initial-handler'.
+
+ (and (not (eq? key 'srfi-34))
+ (srfi-18-exception-preserver (if (null? args)
+ (cons uncaught-exception key)
+ (cons* uncaught-exception key args)))))
+
+(define (current-handler-stack)
+ (let ((ct (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))
+ (hl (current-handler-stack)))
+ (check-arg-type procedure? handler "with-exception-handler")
+ (check-arg-type thunk? thunk "with-exception-handler")
+ (hashq-set! thread-exception-handlers ct (cons handler hl))
+ (apply (@ (srfi srfi-34) with-exception-handler)
+ (list (lambda (obj)
+ (hashq-set! thread-exception-handlers ct hl)
+ (handler obj))
+ (lambda ()
+ (let ((r (thunk)))
+ (hashq-set! thread-exception-handlers ct hl) r))))))
+
+(define (current-exception-handler)
+ (car (current-handler-stack)))
+
+(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
+(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
+(define (uncaught-exception? obj)
+ (and (pair? obj) (eq? (car obj) uncaught-exception)))
+(define (uncaught-exception-reason exc)
+ (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
+(define (terminated-thread-exception? obj)
+ (eq? obj terminated-thread-exception))
+
+;; 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 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)
+ (with-exception-handler initial-handler
+ thunk)))))
+ (lambda (thunk . name)
+ (let ((n (and (pair? name) (car name)))
+
+ (lm (make-mutex 'launch-mutex))
+ (lc (make-condition-variable 'launch-condition-variable))
+ (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)))
+ (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)
+ t)))))
+
+(define (thread-name thread)
+ (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+
+(define (thread-specific thread)
+ (hashq-ref object-specifics
+ (check-arg-type thread? thread "thread-specific")))
+
+(define (thread-specific-set! thread obj)
+ (hashq-set! object-specifics
+ (check-arg-type 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!"))))
+ (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)))
+ thread))
+
+(define (thread-yield!) (yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+ (let* ((ct (time->seconds (current-time)))
+ (t (cond ((time? timeout) (- (time->seconds timeout) ct))
+ ((number? timeout) (- timeout ct))
+ (else (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S"
+ (list timeout)
+ '()))))
+ (secs (inexact->exact (truncate t)))
+ (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
+ (and (> secs 0) (sleep secs))
+ (and (> usecs 0) (usleep usecs))
+ *unspecified*))
+
+;; A convenience function for installing exception handlers on SRFI-18
+;; primitives that resume the calling continuation after the handler is
+;; invoked -- this resolves a behavioral incompatibility with Guile's
+;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
+;; exceptions. (SRFI-18, "Primitives and exceptions")
+
+(define (wrap thunk)
+ (lambda (continuation)
+ (with-exception-handler (lambda (obj)
+ (apply (current-exception-handler) (list obj))
+ (apply continuation (list)))
+ thunk)))
+
+;; A pass-thru to cancel-thread that first installs a handler that throws
+;; terminated-thread exception, as per SRFI-18,
+
+(define (thread-terminate! thread)
+ (define (thread-terminate-inner!)
+ (let ((current-handler (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)
+ *unspecified*))
+ (thread-terminate-inner!))
+
+(define (thread-join! thread . args)
+ (define thread-join-inner!
+ (wrap (lambda ()
+ (let ((v (apply join-thread (cons thread args)))
+ (e (thread->exception thread)))
+ (if (and (= (length args) 1) (not v))
+ (raise join-timeout-exception))
+ (if e (raise e))
+ v))))
+ (call/cc thread-join-inner!))
+
+;; MUTEXES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-mutex
+ (lambda name
+ (let ((n (and (pair? name) (car name)))
+ (m ((@ (guile) 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")))
+
+(define (mutex-specific mutex)
+ (hashq-ref object-specifics
+ (check-arg-type mutex? mutex "mutex-specific")))
+
+(define (mutex-specific-set! mutex obj)
+ (hashq-set! object-specifics
+ (check-arg-type mutex? mutex "mutex-specific-set!")
+ obj)
+ *unspecified*)
+
+(define (mutex-state mutex)
+ (let ((owner (mutex-owner mutex)))
+ (if owner
+ (if (thread-exited? owner) 'abandoned owner)
+ (if (> (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 (cons mutex args)))
+ (lambda (key . args) (raise abandoned-mutex-exception))))))
+ (call/cc mutex-lock-inner!))
+
+(define (mutex-unlock! mutex . args)
+ (apply unlock-mutex (cons mutex args)))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-condition-variable
+ (lambda name
+ (let ((n (and (pair? name) (car name)))
+ (m ((@ (guile) 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?
+ condition-variable
+ "condition-variable-name")))
+
+(define (condition-variable-specific condition-variable)
+ (hashq-ref object-specifics (check-arg-type condition-variable?
+ condition-variable
+ "condition-variable-specific")))
+
+(define (condition-variable-specific-set! condition-variable obj)
+ (hashq-set! object-specifics
+ (check-arg-type condition-variable?
+ condition-variable
+ "condition-variable-specific-set!")
+ obj)
+ *unspecified*)
+
+(define (condition-variable-signal! cond)
+ (signal-condition-variable cond)
+ *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+ (broadcast-condition-variable 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 \ No newline at end of file