src/allegro.lisp

   1 #|
   2 Copyright 2006, 2007 Greg Pfeil
   3
   4 Distributed under the MIT license (see LICENSE file)
   5 |#
   6
   7 (in-package #:bordeaux-threads)
   8
   9 ;;; documentation on the Allegro Multiprocessing interface can be found at
  10 ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
  11
  12 ;;; Thread Creation
  13
  14 (defun make-thread (function &key name)
  15   (mp:process-run-function name function))
  16
  17 (defun current-thread ()
  18   mp:*current-process*)
  19
  20 (defun threadp (object)
  21   (typep object 'mp:process))
  22
  23 (defun thread-name (thread)
  24   (mp:process-name thread))
  25
  26 ;;; Resource contention: locks and recursive locks
  27
  28 (defun make-lock (&optional name)
  29   (mp:make-process-lock :name name))
  30
  31 (defun acquire-lock (lock &optional (wait-p t))
  32   (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0)))
  33
  34 (defun release-lock (lock)
  35   (mp:process-unlock lock))
  36
  37 (defmacro with-lock-held ((place) &body body)
  38   `(mp:with-process-lock (,place :norecursive t)
  39      ,@body))
  40
  41 (defmacro with-recursive-lock-held ((place &key timeout) &body body)
  42   `(mp:with-process-lock (,place :timeout ,timeout)
  43      ,@body))
  44
  45 ;;; Resource contention: condition variables
  46
  47 (defun make-condition-variable ()
  48   (mp:make-gate nil))
  49
  50 (defun condition-wait (condition-variable lock)
  51   (release-lock lock)
  52   (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable)
  53   (acquire-lock lock)
  54   (mp:close-gate condition-variable))
  55
  56 (defun condition-notify (condition-variable)
  57   (mp:open-gate condition-variable))
  58
  59 (defun thread-yield ()
  60   (mp:process-allow-schedule))
  61
  62 ;;; Introspection/debugging
  63
  64 (defun all-threads ()
  65   mp:*all-processes*)
  66
  67 (defun interrupt-thread (thread function)
  68   (mp:process-interrupt thread function))
  69
  70 (defun destroy-thread (thread)
  71   (signal-error-if-current-thread thread)
  72   (mp:process-kill thread))
  73
  74 (defun thread-alive-p (thread)
  75   (mp:process-alive-p thread))
  76
  77 (mark-supported)