3rdparties/software/bordeaux-threads-v0.8.7/src/impl-lispworks.lisp (4032 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 ;;; documentation on the LispWorks Multiprocessing interface can be found at 12 ;;; http://www.lispworks.com/documentation/lw445/LWUG/html/lwuser-156.htm 13 14 (deftype thread () 15 'mp:process) 16 17 ;;; Thread Creation 18 19 (defun start-multiprocessing () 20 (mp:initialize-multiprocessing)) 21 22 (defun %make-thread (function name) 23 (mp:process-run-function 24 name nil 25 (lambda () 26 (let ((return-values 27 (multiple-value-list (funcall function)))) 28 (setf (mp:process-property 'return-values) 29 return-values) 30 (values-list return-values))))) 31 32 (defun current-thread () 33 #-#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) 34 mp:*current-process* 35 ;; introduced in LispWorks 5.1 36 #+#.(cl:if (cl:find-symbol (cl:string '#:get-current-process) :mp) '(and) '(or)) 37 (mp:get-current-process)) 38 39 (defun threadp (object) 40 (mp:process-p object)) 41 42 (defun thread-name (thread) 43 (mp:process-name thread)) 44 45 ;;; Resource contention: locks and recursive locks 46 47 48 (deftype lock () 'mp:lock) 49 50 #-(or lispworks4 lispworks5) 51 (deftype recursive-lock () 52 '(and mp:lock (satisfies mp:lock-recursive-p))) 53 54 (defun lock-p (object) 55 (typep object 'mp:lock)) 56 57 (defun recursive-lock-p (object) 58 #+(or lispworks4 lispworks5) 59 nil 60 #-(or lispworks4 lispworks5) ; version 6+ 61 (and (typep object 'mp:lock) 62 (mp:lock-recursive-p object))) 63 64 (defun make-lock (&optional name) 65 (mp:make-lock :name (or name "Anonymous lock") 66 #-(or lispworks4 lispworks5) :recursivep 67 #-(or lispworks4 lispworks5) nil)) 68 69 (defun acquire-lock (lock &optional (wait-p t)) 70 (mp:process-lock lock nil 71 (cond ((null wait-p) 0) 72 ((numberp wait-p) wait-p) 73 (t nil)))) 74 75 (defun release-lock (lock) 76 (mp:process-unlock lock)) 77 78 (defmacro with-lock-held ((place) &body body) 79 `(mp:with-lock (,place) ,@body)) 80 81 (defun make-recursive-lock (&optional name) 82 (mp:make-lock :name (or name "Anonymous recursive lock") 83 #-(or lispworks4 lispworks5) :recursivep 84 #-(or lispworks4 lispworks5) t)) 85 86 (defun acquire-recursive-lock (lock &optional (wait-p t)) 87 (acquire-lock lock wait-p)) 88 89 (defun release-recursive-lock (lock) 90 (release-lock lock)) 91 92 (defmacro with-recursive-lock-held ((place) &body body) 93 `(mp:with-lock (,place) ,@body)) 94 95 ;;; Resource contention: condition variables 96 97 #+(or lispworks6 lispworks7) 98 (defun make-condition-variable (&key name) 99 (mp:make-condition-variable :name (or name "Anonymous condition variable"))) 100 101 #+(or lispworks6 lispworks7) 102 (defun condition-wait (condition-variable lock &key timeout) 103 (mp:condition-variable-wait condition-variable lock :timeout timeout) 104 t) 105 106 #+(or lispworks6 lispworks7) 107 (defun condition-notify (condition-variable) 108 (mp:condition-variable-signal condition-variable)) 109 110 (defun thread-yield () 111 (mp:process-allow-scheduling)) 112 113 ;;; Introspection/debugging 114 115 (defun all-threads () 116 (mp:list-all-processes)) 117 118 (defun interrupt-thread (thread function &rest args) 119 (apply #'mp:process-interrupt thread function args)) 120 121 (defun destroy-thread (thread) 122 (signal-error-if-current-thread thread) 123 (mp:process-kill thread)) 124 125 (defun thread-alive-p (thread) 126 (mp:process-alive-p thread)) 127 128 (declaim (inline %join-thread)) 129 (defun %join-thread (thread) 130 #-#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 131 (mp:process-wait (format nil "Waiting for thread ~A to complete" thread) 132 (complement #'mp:process-alive-p) 133 thread) 134 #+#.(cl:if (cl:find-symbol (cl:string '#:process-join) :mp) '(and) '(or)) 135 (mp:process-join thread)) 136 137 (defun join-thread (thread) 138 (%join-thread thread) 139 (let ((return-values 140 (mp:process-property 'return-values thread))) 141 (values-list return-values))) 142 143 (mark-supported)