module/srfi/srfi-18.scm

   1 ;;; srfi-18.scm --- Multithreading support
   2
   3 ;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Author: Julian Graham <julian.graham@aya.yale.edu>
  20 ;;; Date: 2008-04-11
  21
  22 ;;; Commentary:
  23
  24 ;; This is an implementation of SRFI-18 (Multithreading support).
  25 ;;
  26 ;; All procedures defined in SRFI-18, which are not already defined in
  27 ;; the Guile core library, are exported.
  28 ;;
  29 ;; This module is fully documented in the Guile Reference Manual.
  30
  31 ;;; Code:
  32
  33 (define-module (srfi srfi-18)
  34   :use-module (srfi srfi-34)
  35   :export (
  36
  37 ;;; Threads
  38  ;; current-thread                      <= in the core
  39  ;; thread?                             <= in the core
  40  make-thread
  41  thread-name
  42  thread-specific
  43  thread-specific-set!
  44  thread-start!
  45  thread-yield!
  46  thread-sleep!
  47  thread-terminate!
  48  thread-join!
  49
  50 ;;; Mutexes
  51  ;; mutex?                              <= in the core
  52  make-mutex
  53  mutex-name
  54  mutex-specific
  55  mutex-specific-set!
  56  mutex-state
  57  mutex-lock!
  58  mutex-unlock!
  59
  60 ;;; Condition variables
  61  ;; condition-variable?                 <= in the core
  62  make-condition-variable
  63  condition-variable-name
  64  condition-variable-specific
  65  condition-variable-specific-set!
  66  condition-variable-signal!
  67  condition-variable-broadcast!
  68  condition-variable-wait!
  69
  70 ;;; Time
  71  current-time
  72  time?
  73  time->seconds
  74  seconds->time
  75
  76  current-exception-handler
  77  with-exception-handler
  78  raise
  79  join-timeout-exception?
  80  abandoned-mutex-exception?
  81  terminated-thread-exception?
  82  uncaught-exception?
  83  uncaught-exception-reason
  84  )
  85   :re-export (current-thread thread? mutex? condition-variable?)
  86   :replace (current-time
  87             make-thread
  88             make-mutex
  89             make-condition-variable
  90             raise))
  91
  92 (if (not (provided? 'threads))
  93     (error "SRFI-18 requires Guile with threads support"))
  94
  95 (cond-expand-provide (current-module) '(srfi-18))
  96
  97 (define (check-arg-type pred arg caller)
  98   (if (pred arg)
  99       arg
 100       (scm-error 'wrong-type-arg caller
 101                  "Wrong type argument: ~S" (list arg) '())))
 102
 103 (define abandoned-mutex-exception (list 'abandoned-mutex-exception))
 104 (define join-timeout-exception (list 'join-timeout-exception))
 105 (define terminated-thread-exception (list 'terminated-thread-exception))
 106 (define uncaught-exception (list 'uncaught-exception))
 107
 108 (define object-names (make-weak-key-hash-table))
 109 (define object-specifics (make-weak-key-hash-table))
 110 (define thread-start-conds (make-weak-key-hash-table))
 111 (define thread-exception-handlers (make-weak-key-hash-table))
 112
 113 ;; EXCEPTIONS
 114
 115 (define raise (@ (srfi srfi-34) raise))
 116 (define (initial-handler obj)
 117   (srfi-18-exception-preserver (cons uncaught-exception obj)))
 118
 119 (define thread->exception (make-object-property))
 120
 121 (define (srfi-18-exception-preserver obj)
 122   (if (or (terminated-thread-exception? obj)
 123           (uncaught-exception? obj))
 124       (set! (thread->exception (current-thread)) obj)))
 125
 126 (define (srfi-18-exception-handler key . args)
 127
 128   ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
 129   ;; if one is caught at this level, it has already been taken care of by
 130   ;; `initial-handler'.
 131
 132   (and (not (eq? key 'srfi-34))
 133        (srfi-18-exception-preserver (if (null? args)
 134                                         (cons uncaught-exception key)
 135                                         (cons* uncaught-exception key args)))))
 136
 137 (define (current-handler-stack)
 138   (let ((ct (current-thread)))
 139     (or (hashq-ref thread-exception-handlers ct)
 140         (hashq-set! thread-exception-handlers ct (list initial-handler)))))
 141
 142 (define (with-exception-handler handler thunk)
 143   (let ((ct (current-thread))
 144         (hl (current-handler-stack)))
 145     (check-arg-type procedure? handler "with-exception-handler")
 146     (check-arg-type thunk? thunk "with-exception-handler")
 147     (hashq-set! thread-exception-handlers ct (cons handler hl))
 148     ((@ (srfi srfi-34) with-exception-handler)
 149      (lambda (obj)
 150        (hashq-set! thread-exception-handlers ct hl)
 151        (handler obj))
 152      (lambda ()
 153        (call-with-values thunk
 154          (lambda res
 155            (hashq-set! thread-exception-handlers ct hl)
 156            (apply values res)))))))
 157
 158 (define (current-exception-handler)
 159   (car (current-handler-stack)))
 160
 161 (define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
 162 (define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
 163 (define (uncaught-exception? obj)
 164   (and (pair? obj) (eq? (car obj) uncaught-exception)))
 165 (define (uncaught-exception-reason exc)
 166   (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
 167 (define (terminated-thread-exception? obj)
 168   (eq? obj terminated-thread-exception))
 169
 170 ;; THREADS
 171
 172 ;; Create a new thread and prevent it from starting using a condition variable.
 173 ;; Once started, install a top-level exception handler that rethrows any
 174 ;; exceptions wrapped in an uncaught-exception wrapper.
 175
 176 (define make-thread
 177   (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
 178                              (lambda ()
 179                                (lock-mutex lmutex)
 180                                (signal-condition-variable lcond)
 181                                (lock-mutex smutex)
 182                                (unlock-mutex lmutex)
 183                                (wait-condition-variable scond smutex)
 184                                (unlock-mutex smutex)
 185                                (with-exception-handler initial-handler
 186                                                        thunk)))))
 187     (lambda (thunk . name)
 188       (let ((n (and (pair? name) (car name)))
 189
 190             (lm (make-mutex 'launch-mutex))
 191             (lc (make-condition-variable 'launch-condition-variable))
 192             (sm (make-mutex 'start-mutex))
 193             (sc (make-condition-variable 'start-condition-variable)))
 194
 195         (lock-mutex lm)
 196         (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
 197                                        srfi-18-exception-handler)))
 198           (hashq-set! thread-start-conds t (cons sm sc))
 199           (and n (hashq-set! object-names t n))
 200           (wait-condition-variable lc lm)
 201           (unlock-mutex lm)
 202           t)))))
 203
 204 (define (thread-name thread)
 205   (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
 206
 207 (define (thread-specific thread)
 208   (hashq-ref object-specifics
 209              (check-arg-type thread? thread "thread-specific")))
 210
 211 (define (thread-specific-set! thread obj)
 212   (hashq-set! object-specifics
 213               (check-arg-type thread? thread "thread-specific-set!")
 214               obj)
 215   *unspecified*)
 216
 217 (define (thread-start! thread)
 218   (let ((x (hashq-ref thread-start-conds
 219                       (check-arg-type thread? thread "thread-start!"))))
 220     (and x (let ((smutex (car x))
 221                  (scond (cdr x)))
 222              (hashq-remove! thread-start-conds thread)
 223              (lock-mutex smutex)
 224              (signal-condition-variable scond)
 225              (unlock-mutex smutex)))
 226     thread))
 227
 228 (define (thread-yield!) (yield) *unspecified*)
 229
 230 (define (thread-sleep! timeout)
 231   (let* ((ct (time->seconds (current-time)))
 232          (t (cond ((time? timeout) (- (time->seconds timeout) ct))
 233                   ((number? timeout) (- timeout ct))
 234                   (else (scm-error 'wrong-type-arg "thread-sleep!"
 235                                    "Wrong type argument: ~S"
 236                                    (list timeout)
 237                                    '()))))
 238          (secs (inexact->exact (truncate t)))
 239          (usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
 240     (and (> secs 0) (sleep secs))
 241     (and (> usecs 0) (usleep usecs))
 242     *unspecified*))
 243
 244 ;; A convenience function for installing exception handlers on SRFI-18
 245 ;; primitives that resume the calling continuation after the handler is
 246 ;; invoked -- this resolves a behavioral incompatibility with Guile's
 247 ;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
 248 ;; exceptions.  (SRFI-18, "Primitives and exceptions")
 249
 250 (define (wrap thunk)
 251   (lambda (continuation)
 252     (with-exception-handler (lambda (obj)
 253                               ((current-exception-handler) obj)
 254                               (continuation))
 255                             thunk)))
 256
 257 ;; A pass-thru to cancel-thread that first installs a handler that throws
 258 ;; terminated-thread exception, as per SRFI-18,
 259
 260 (define (thread-terminate! thread)
 261   (define (thread-terminate-inner!)
 262     (let ((current-handler (thread-cleanup thread)))
 263       (if (thunk? current-handler)
 264           (set-thread-cleanup! thread
 265                                (lambda ()
 266                                  (with-exception-handler initial-handler
 267                                                          current-handler)
 268                                  (srfi-18-exception-preserver
 269                                   terminated-thread-exception)))
 270           (set-thread-cleanup! thread
 271                                (lambda () (srfi-18-exception-preserver
 272                                            terminated-thread-exception))))
 273       (cancel-thread thread)
 274       *unspecified*))
 275   (thread-terminate-inner!))
 276
 277 (define (thread-join! thread . args)
 278   (define thread-join-inner!
 279     (wrap (lambda ()
 280             (let ((v (apply join-thread thread args))
 281                   (e (thread->exception thread)))
 282               (if (and (= (length args) 1) (not v))
 283                   (raise join-timeout-exception))
 284               (if e (raise e))
 285               v))))
 286   (call/cc thread-join-inner!))
 287
 288 ;; MUTEXES
 289 ;; These functions are all pass-thrus to the existing Guile implementations.
 290
 291 (define make-mutex
 292   (lambda name
 293     (let ((n (and (pair? name) (car name)))
 294           (m ((@ (guile) make-mutex)
 295               'unchecked-unlock
 296               'allow-external-unlock
 297               'recursive)))
 298       (and n (hashq-set! object-names m n)) m)))
 299
 300 (define (mutex-name mutex)
 301   (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
 302
 303 (define (mutex-specific mutex)
 304   (hashq-ref object-specifics
 305              (check-arg-type mutex? mutex "mutex-specific")))
 306
 307 (define (mutex-specific-set! mutex obj)
 308   (hashq-set! object-specifics
 309               (check-arg-type mutex? mutex "mutex-specific-set!")
 310               obj)
 311   *unspecified*)
 312
 313 (define (mutex-state mutex)
 314   (let ((owner (mutex-owner mutex)))
 315     (if owner
 316         (if (thread-exited? owner) 'abandoned owner)
 317         (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
 318
 319 (define (mutex-lock! mutex . args)
 320   (define mutex-lock-inner!
 321     (wrap (lambda ()
 322             (catch 'abandoned-mutex-error
 323                    (lambda () (apply lock-mutex mutex args))
 324                    (lambda (key . args) (raise abandoned-mutex-exception))))))
 325   (call/cc mutex-lock-inner!))
 326
 327 (define (mutex-unlock! mutex . args)
 328   (apply unlock-mutex mutex args))
 329
 330 ;; CONDITION VARIABLES
 331 ;; These functions are all pass-thrus to the existing Guile implementations.
 332
 333 (define make-condition-variable
 334   (lambda name
 335     (let ((n (and (pair? name) (car name)))
 336           (m ((@ (guile) make-condition-variable))))
 337       (and n (hashq-set! object-names m n)) m)))
 338
 339 (define (condition-variable-name condition-variable)
 340   (hashq-ref object-names (check-arg-type condition-variable?
 341                                           condition-variable
 342                                           "condition-variable-name")))
 343
 344 (define (condition-variable-specific condition-variable)
 345   (hashq-ref object-specifics (check-arg-type condition-variable?
 346                                               condition-variable
 347                                               "condition-variable-specific")))
 348
 349 (define (condition-variable-specific-set! condition-variable obj)
 350   (hashq-set! object-specifics
 351               (check-arg-type condition-variable?
 352                               condition-variable
 353                               "condition-variable-specific-set!")
 354               obj)
 355   *unspecified*)
 356
 357 (define (condition-variable-signal! cond)
 358   (signal-condition-variable cond)
 359   *unspecified*)
 360
 361 (define (condition-variable-broadcast! cond)
 362   (broadcast-condition-variable cond)
 363   *unspecified*)
 364
 365 ;; TIME
 366
 367 (define current-time gettimeofday)
 368 (define (time? obj)
 369   (and (pair? obj)
 370        (let ((co (car obj))) (and (integer? co) (>= co 0)))
 371        (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
 372
 373 (define (time->seconds time)
 374   (and (check-arg-type time? time "time->seconds")
 375        (+ (car time) (/ (cdr time) 1000000))))
 376
 377 (define (seconds->time x)
 378   (and (check-arg-type number? x "seconds->time")
 379        (let ((fx (truncate x)))
 380          (cons (inexact->exact fx)
 381                (inexact->exact (truncate (* (- x fx) 1000000)))))))
 382
 383 ;; srfi-18.scm ends here