apiv1/impl-clisp.lisp

   1 ;;;; -*- indent-tabs-mode: nil -*-
   2
   3 #|
   4 Copyright 2006, 2007 Greg Pfeil
   5
   6 Distributed under the MIT license (see LICENSE file)
   7 |#
   8
   9 (in-package #:bordeaux-threads)
  10
  11 (deftype thread ()
  12   'mt:thread)
  13
  14 ;;; Thread Creation
  15 (defun %make-thread (function name)
  16   (mt:make-thread function
  17                   :name name
  18                   :initial-bindings mt:*default-special-bindings*))
  19
  20 (defun current-thread ()
  21   (mt:current-thread))
  22
  23 (defun threadp (object)
  24   (mt:threadp object))
  25
  26 (defun thread-name (thread)
  27   (mt:thread-name thread))
  28
  29 ;;; Resource contention: locks and recursive locks
  30
  31 (deftype lock () 'mt:mutex)
  32
  33 (deftype recursive-lock ()
  34   '(and mt:mutex (satisfies mt:mutex-recursive-p)))
  35
  36 (defun lock-p (object)
  37   (typep object 'mt:mutex))
  38
  39 (defun recursive-lock-p (object)
  40   (and (typep object 'mt:mutex)
  41        (mt:mutex-recursive-p object)))
  42
  43 (defun make-lock (&optional name)
  44   (mt:make-mutex :name (or name "Anonymous lock")))
  45
  46 (defun acquire-lock (lock &optional (wait-p t))
  47   (mt:mutex-lock lock :timeout (if wait-p nil 0)))
  48
  49 (defun release-lock (lock)
  50   (mt:mutex-unlock lock))
  51
  52 (defmacro with-lock-held ((place) &body body)
  53   `(mt:with-mutex-lock (,place) ,@body))
  54
  55 (defun make-recursive-lock (&optional name)
  56   (mt:make-mutex :name (or name "Anonymous recursive lock")
  57                  :recursive-p t))
  58
  59 (defun acquire-recursive-lock (lock &optional (wait-p t))
  60   (acquire-lock lock wait-p))
  61
  62 (defun release-recursive-lock (lock)
  63   (release-lock lock))
  64
  65 (defmacro with-recursive-lock-held ((place) &body body)
  66   `(mt:with-mutex-lock (,place) ,@body))
  67
  68 ;;; Resource contention: condition variables
  69
  70 (defun make-condition-variable (&key name)
  71   (mt:make-exemption :name (or name "Anonymous condition variable")))
  72
  73 (defun condition-wait (condition-variable lock &key timeout)
  74   (mt:exemption-wait condition-variable lock :timeout timeout)
  75   t)
  76
  77 (defun condition-notify (condition-variable)
  78   (mt:exemption-signal condition-variable))
  79
  80 (defun thread-yield ()
  81   (mt:thread-yield))
  82
  83 ;;; Timeouts
  84
  85 (defmacro with-timeout ((timeout) &body body)
  86   (once-only (timeout)
  87     `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
  88        ,@body)))
  89
  90 ;;; Introspection/debugging
  91
  92 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
  93 (defun all-threads ()
  94   (delete-if-not #'mt:thread-active-p (mt:list-threads)))
  95
  96 (defun interrupt-thread (thread function &rest args)
  97   (mt:thread-interrupt thread :function function :arguments args))
  98
  99 (defun destroy-thread (thread)
 100   ;;; VTZ: actually we can kill ourselelf.
 101   ;;; suicide is part of our contemporary life :)
 102   (signal-error-if-current-thread thread)
 103   (mt:thread-interrupt thread :function t))
 104
 105 (defun thread-alive-p (thread)
 106   (mt:thread-active-p thread))
 107
 108 (defun join-thread (thread)
 109   (values-list (mt:thread-join thread)))
 110
 111 (mark-supported)