3rdparties/software/bordeaux-threads-v0.8.7/src/impl-cmucl.lisp (4919 bytes)
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 'mp::process) 13 14 ;;; Thread Creation 15 16 (defun start-multiprocessing () 17 (mp::startup-idle-and-top-level-loops)) 18 19 (defun %make-thread (function name) 20 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 21 (mp:make-process function :name name) 22 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 23 (mp:make-process (lambda () 24 (let ((return-values 25 (multiple-value-list (funcall function)))) 26 (setf (getf (mp:process-property-list mp:*current-process*) 27 'return-values) 28 return-values) 29 (values-list return-values))) 30 :name name)) 31 32 (defun current-thread () 33 mp:*current-process*) 34 35 (defmethod threadp (object) 36 (mp:processp object)) 37 38 (defun thread-name (thread) 39 (mp:process-name thread)) 40 41 ;;; Resource contention: locks and recursive locks 42 43 (deftype lock () 'mp::error-check-lock) 44 45 (deftype recursive-lock () 'mp::recursive-lock) 46 47 (defun lock-p (object) 48 (typep object 'mp::error-check-lock)) 49 50 (defun recursive-lock-p (object) 51 (typep object 'mp::recursive-lock)) 52 53 (defun make-lock (&optional name) 54 (mp:make-lock (or name "Anonymous lock") 55 :kind :error-check)) 56 57 (defun acquire-lock (lock &optional (wait-p t)) 58 (if wait-p 59 (mp::lock-wait lock "Lock wait") 60 (mp::lock-wait-with-timeout lock "Lock wait" 0))) 61 62 (defun release-lock (lock) 63 (setf (mp::lock-process lock) nil)) 64 65 (defmacro with-lock-held ((place) &body body) 66 `(mp:with-lock-held (,place "Lock wait") ,@body)) 67 68 (defun make-recursive-lock (&optional name) 69 (mp:make-lock (or name "Anonymous recursive lock") 70 :kind :recursive)) 71 72 (defun acquire-recursive-lock (lock &optional (wait-p t)) 73 (acquire-lock lock)) 74 75 (defun release-recursive-lock (lock) 76 (release-lock lock)) 77 78 (defmacro with-recursive-lock-held ((place &key timeout) &body body) 79 `(mp:with-lock-held (,place "Lock Wait" :timeout ,timeout) ,@body)) 80 81 ;;; Note that the locks _are_ recursive, but not "balanced", and only 82 ;;; checked if they are being held by the same process by with-lock-held. 83 ;;; The default with-lock-held in bordeaux-mp.lisp sort of works, in that 84 ;;; it will wait for recursive locks by the same process as well. 85 86 ;;; Resource contention: condition variables 87 88 ;;; There's some stuff in x86-vm.lisp that might be worth investigating 89 ;;; whether to build on. There's also process-wait and friends. 90 91 (defstruct condition-var 92 "CMUCL doesn't have conditions, so we need to create our own type." 93 name 94 lock 95 active) 96 97 (defun make-condition-variable (&key name) 98 (make-condition-var :lock (make-lock) 99 :name (or name "Anonymous condition variable"))) 100 101 (defun condition-wait (condition-variable lock &key timeout) 102 (signal-error-if-condition-wait-timeout timeout) 103 (check-type condition-variable condition-var) 104 (with-lock-held ((condition-var-lock condition-variable)) 105 (setf (condition-var-active condition-variable) nil)) 106 (release-lock lock) 107 (mp:process-wait "Condition Wait" 108 #'(lambda () (condition-var-active condition-variable))) 109 (acquire-lock lock) 110 t) 111 112 (define-condition-wait-compiler-macro) 113 114 (defun condition-notify (condition-variable) 115 (check-type condition-variable condition-var) 116 (with-lock-held ((condition-var-lock condition-variable)) 117 (setf (condition-var-active condition-variable) t)) 118 (thread-yield)) 119 120 (defun thread-yield () 121 (mp:process-yield)) 122 123 ;;; Timeouts 124 125 (defmacro with-timeout ((timeout) &body body) 126 (once-only (timeout) 127 `(mp:with-timeout (,timeout (error 'timeout :length ,timeout)) 128 ,@body))) 129 130 ;;; Introspection/debugging 131 132 (defun all-threads () 133 (mp:all-processes)) 134 135 (defun interrupt-thread (thread function &rest args) 136 (flet ((apply-function () 137 (if args 138 (lambda () (apply function args)) 139 function))) 140 (declare (dynamic-extent #'apply-function)) 141 (mp:process-interrupt thread (apply-function)))) 142 143 (defun destroy-thread (thread) 144 (signal-error-if-current-thread thread) 145 (mp:destroy-process thread)) 146 147 (defun thread-alive-p (thread) 148 (mp:process-active-p thread)) 149 150 (defun join-thread (thread) 151 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 152 (mp:process-join thread) 153 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 154 (progn 155 (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 156 (lambda () (not (mp:process-alive-p thread)))) 157 (let ((return-values 158 (getf (mp:process-property-list thread) 'return-values))) 159 (values-list return-values)))) 160 161 (mark-supported)