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