src/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 (defun make-lock (&optional name)
  32   (mt:make-mutex :name (or name "Anonymous lock")))
  33
  34 (defun acquire-lock (lock &optional (wait-p t))
  35   (mt:mutex-lock lock :timeout (if wait-p nil 0)))
  36
  37 (defun release-lock (lock)
  38   (mt:mutex-unlock lock))
  39
  40 (defmacro with-lock-held ((place) &body body)
  41   `(mt:with-mutex-lock (,place) ,@body))
  42
  43 (defun make-recursive-lock (&optional name)
  44   (mt:make-mutex :name (or name "Anonymous recursive lock")
  45                  :recursive-p t))
  46
  47 (defmacro with-recursive-lock-held ((place) &body body)
  48   `(mt:with-mutex-lock (,place) ,@body))
  49
  50 ;;; Resource contention: condition variables
  51
  52 (defun make-condition-variable (&key name)
  53   (mt:make-exemption :name (or name "Anonymous condition variable")))
  54
  55 (defun condition-wait (condition-variable lock &key timeout)
  56   (mt:exemption-wait condition-variable lock :timeout timeout)
  57   t)
  58
  59 (defun condition-notify (condition-variable)
  60   (mt:exemption-signal condition-variable))
  61
  62 (defun thread-yield ()
  63   (mt:thread-yield))
  64
  65 ;;; Timeouts
  66
  67 (defmacro with-timeout ((timeout) &body body)
  68   (once-only (timeout)
  69     `(mt:with-timeout (,timeout (error 'timeout :length ,timeout))
  70        ,@body)))
  71
  72 ;;; Introspection/debugging
  73
  74 ;;; VTZ: mt:list-threads returns all threads that are not garbage collected.
  75 (defun all-threads ()
  76   (delete-if-not #'mt:thread-active-p (mt:list-threads)))
  77
  78 (defun interrupt-thread (thread function &rest args)
  79   (mt:thread-interrupt thread :function function :arguments args))
  80
  81 (defun destroy-thread (thread)
  82   ;;; VTZ: actually we can kill ourselelf.
  83   ;;; suicide is part of our contemporary life :)
  84   (signal-error-if-current-thread thread)
  85   (mt:thread-interrupt thread :function t))
  86
  87 (defun thread-alive-p (thread)
  88   (mt:thread-active-p thread))
  89
  90 (defun join-thread (thread)
  91   (mt:thread-join thread))
  92
  93 (mark-supported)