srfi/srfi-18.scm

   1 ;;; srfi-18.scm --- Multithreading support
   2
   3 ;; Copyright (C) 2008 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 2.1 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 (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 mutex-owners (make-weak-key-hash-table))
 109 (define object-names (make-weak-key-hash-table))
 110 (define object-specifics (make-weak-key-hash-table))
 111 (define thread-start-conds (make-weak-key-hash-table))
 112 (define thread-exception-handlers (make-weak-key-hash-table))
 113
 114 ;; EXCEPTIONS
 115
 116 (define raise (@ (srfi srfi-34) raise))
 117 (define (initial-handler obj)
 118   (srfi-18-exception-preserver (cons uncaught-exception obj)))
 119
 120 (define thread->exception (make-object-property))
 121
 122 (define (srfi-18-exception-preserver obj)
 123   (if (or (terminated-thread-exception? obj)
 124           (uncaught-exception? obj))
 125       (set! (thread->exception (current-thread)) obj)))
 126
 127 (define (srfi-18-exception-handler key . args)
 128
 129   ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
 130   ;; if one is caught at this level, it has already been taken care of by
 131   ;; `initial-handler'.
 132
 133   (and (not (eq? key 'srfi-34))
 134        (srfi-18-exception-preserver (if (null? args)
 135                                         (cons uncaught-exception key)
 136                                         (cons* uncaught-exception key args)))))
 137
 138 (define (current-handler-stack)
 139   (let ((ct (current-thread)))
 140     (or (hashq-ref thread-exception-handlers ct)
 141         (hashq-set! thread-exception-handlers ct (list initial-handler)))))
 142
 143 (define (with-exception-handler handler thunk)
 144   (let ((ct (current-thread))
 145         (hl (current-handler-stack)))
 146     (check-arg-type procedure? handler "with-exception-handler")
 147     (check-arg-type thunk? thunk "with-exception-handler")
 148     (hashq-set! thread-exception-handlers ct (cons handler hl))
 149     (apply (@ (srfi srfi-34) with-exception-handler)
 150            (list (lambda (obj)
 151                    (hashq-set! thread-exception-handlers ct hl)
 152                    (handler obj))
 153                  (lambda ()
 154                    (let ((r (thunk)))
 155                      (hashq-set! thread-exception-handlers ct hl) r))))))
 156
 157 (define (current-exception-handler)
 158   (car (current-handler-stack)))
 159
 160 (define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
 161 (define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
 162 (define (uncaught-exception? obj)
 163   (and (pair? obj) (eq? (car obj) uncaught-exception)))
 164 (define (uncaught-exception-reason exc)
 165   (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
 166 (define (terminated-thread-exception? obj)
 167   (eq? obj terminated-thread-exception))
 168
 169 ;; THREADS
 170
 171 ;; Create a new thread and prevent it from starting using a condition variable.
 172 ;; Once started, install a top-level exception handler that rethrows any
 173 ;; exceptions wrapped in an uncaught-exception wrapper.
 174
 175 (define make-thread
 176   (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
 177                              (lambda ()
 178                                (lock-mutex lmutex)
 179                                (signal-condition-variable lcond)
 180                                (lock-mutex smutex)
 181                                (unlock-mutex lmutex)
 182                                (wait-condition-variable scond smutex)
 183                                (unlock-mutex smutex)
 184                                (with-exception-handler initial-handler
 185                                                        thunk)))))
 186     (lambda (thunk . name)
 187       (let ((n (and (pair? name) (car name)))
 188
 189             (lm (make-mutex 'launch-mutex))
 190             (lc (make-condition-variable 'launch-condition-variable))
 191             (sm (make-mutex 'start-mutex))
 192             (sc (make-condition-variable 'start-condition-variable)))
 193
 194         (lock-mutex lm)
 195         (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
 196                                        srfi-18-exception-handler)))
 197           (hashq-set! thread-start-conds t (cons sm sc))
 198           (and n (hashq-set! object-names t n))
 199           (wait-condition-variable lc lm)
 200           (unlock-mutex lm)
 201           t)))))
 202
 203 (define (thread-name thread)
 204   (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
 205
 206 (define (thread-specific thread)
 207   (hashq-ref object-specifics
 208              (check-arg-type thread? thread "thread-specific")))
 209
 210 (define (thread-specific-set! thread obj)
 211   (hashq-set! object-specifics
 212               (check-arg-type thread? thread "thread-specific-set!")
 213               obj)
 214   *unspecified*)
 215
 216 (define (thread-start! thread)
 217   (let ((x (hashq-ref thread-start-conds
 218                       (check-arg-type thread? thread "thread-start!"))))
 219     (and x (let ((smutex (car x))
 220                  (scond (cdr x)))
 221              (hashq-remove! thread-start-conds thread)
 222              (lock-mutex smutex)
 223              (signal-condition-variable scond)
 224              (unlock-mutex smutex)))
 225     thread))
 226
 227 (define (thread-yield!) (yield) *unspecified*)
 228
 229 (define (thread-sleep! timeout)
 230   (let* ((ct (time->seconds (current-time)))
 231          (t (cond ((time? timeout) (- (time->seconds timeout) ct))
 232                   ((number? timeout) (- timeout ct))
 233                   (else (scm-error 'wrong-type-arg caller
 234                                    "Wrong type argument: ~S"
 235                                    (list timeout)
 236                                    '()))))
 237          (secs (inexact->exact (truncate t)))
 238          (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
 239     (and (> secs 0) (sleep secs))
 240     (and (> usecs 0) (usleep usecs))
 241     *unspecified*))
 242
 243 ;; A convenience function for installing exception handlers on SRFI-18
 244 ;; primitives that resume the calling continuation after the handler is
 245 ;; invoked -- this resolves a behavioral incompatibility with Guile's
 246 ;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
 247 ;; exceptions.  (SRFI-18, "Primitives and exceptions")
 248
 249 (define (wrap thunk)
 250   (lambda (continuation)
 251     (with-exception-handler (lambda (obj)
 252                               (apply (current-exception-handler) (list obj))
 253                               (apply continuation (list)))
 254                             thunk)))
 255
 256 ;; A pass-thru to cancel-thread that first installs a handler that throws
 257 ;; terminated-thread exception, as per SRFI-18,
 258
 259 (define (thread-terminate! thread)
 260   (define (thread-terminate-inner!)
 261     (let ((current-handler (thread-cleanup thread)))
 262       (if (thunk? current-handler)
 263           (set-thread-cleanup! thread
 264                                (lambda ()
 265                                  (with-exception-handler initial-handler
 266                                                          current-handler)
 267                                  (srfi-18-exception-preserver
 268                                   terminated-thread-exception)))
 269           (set-thread-cleanup! thread
 270                                (lambda () (srfi-18-exception-preserver
 271                                            terminated-thread-exception))))
 272       (cancel-thread thread)
 273       *unspecified*))
 274   (thread-terminate-inner!))
 275
 276 (define (thread-join! thread . args)
 277   (define thread-join-inner!
 278     (wrap (lambda ()
 279             (let ((v (apply join-thread (cons thread args)))
 280                   (e (thread->exception thread)))
 281               (if (and (= (length args) 1) (not v))
 282                   (raise join-timeout-exception))
 283               (if e (raise e))
 284               v))))
 285   (call/cc thread-join-inner!))
 286
 287 ;; MUTEXES
 288 ;; These functions are all pass-thrus to the existing Guile implementations.
 289
 290 (define make-mutex
 291   (lambda name
 292     (let ((n (and (pair? name) (car name)))
 293           (m ((@ (guile) make-mutex)
 294               'unchecked-unlock
 295               'allow-external-unlock
 296               'recursive)))
 297       (and n (hashq-set! object-names m n)) m)))
 298
 299 (define (mutex-name mutex)
 300   (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
 301
 302 (define (mutex-specific mutex)
 303   (hashq-ref object-specifics
 304              (check-arg-type mutex? mutex "mutex-specific")))
 305
 306 (define (mutex-specific-set! mutex obj)
 307   (hashq-set! object-specifics
 308               (check-arg-type mutex? mutex "mutex-specific-set!")
 309               obj)
 310   *unspecified*)
 311
 312 (define (mutex-state mutex)
 313   (let ((owner (mutex-owner mutex)))
 314     (if owner
 315         (if (thread-exited? owner) 'abandoned owner)
 316         (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
 317
 318 (define (mutex-lock! mutex . args)
 319   (define mutex-lock-inner!
 320     (wrap (lambda ()
 321             (catch 'abandoned-mutex-error
 322                    (lambda () (apply lock-mutex (cons mutex args)))
 323                    (lambda (key . args) (raise abandoned-mutex-exception))))))
 324   (call/cc mutex-lock-inner!))
 325
 326 (define (mutex-unlock! mutex . args)
 327   (apply unlock-mutex (cons mutex args)))
 328
 329 ;; CONDITION VARIABLES
 330 ;; These functions are all pass-thrus to the existing Guile implementations.
 331
 332 (define make-condition-variable
 333   (lambda name
 334     (let ((n (and (pair? name) (car name)))
 335           (m ((@ (guile) make-condition-variable))))
 336       (and n (hashq-set! object-names m n)) m)))
 337
 338 (define (condition-variable-name condition-variable)
 339   (hashq-ref object-names (check-arg-type condition-variable?
 340                                           condition-variable
 341                                           "condition-variable-name")))
 342
 343 (define (condition-variable-specific condition-variable)
 344   (hashq-ref object-specifics (check-arg-type condition-variable?
 345                                               condition-variable
 346                                               "condition-variable-specific")))
 347
 348 (define (condition-variable-specific-set! condition-variable obj)
 349   (hashq-set! object-specifics
 350               (check-arg-type condition-variable?
 351                               condition-variable
 352                               "condition-variable-specific-set!")
 353               obj)
 354   *unspecified*)
 355
 356 (define (condition-variable-signal! cond)
 357   (signal-condition-variable cond)
 358   *unspecified*)
 359
 360 (define (condition-variable-broadcast! cond)
 361   (broadcast-condition-variable cond)
 362   *unspecified*)
 363
 364 ;; TIME
 365
 366 (define current-time gettimeofday)
 367 (define (time? obj)
 368   (and (pair? obj)
 369        (let ((co (car obj))) (and (integer? co) (>= co 0)))
 370        (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
 371
 372 (define (time->seconds time)
 373   (and (check-arg-type time? time "time->seconds")
 374        (+ (car time) (/ (cdr time) 1000000))))
 375
 376 (define (seconds->time x)
 377   (and (check-arg-type number? x "seconds->time")
 378        (let ((fx (truncate x)))
 379          (cons (inexact->exact fx)
 380                (inexact->exact (truncate (* (- x fx) 1000000)))))))
 381
 382 ;; srfi-18.scm ends here