GopherProxy

	timpl-allegro.lisp - clic - Clic is an command line interactive client for goph…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	timpl-allegro.lisp (3752B)
	---
	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 …
	12 ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.h…
	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-variabl…
	62 (mp:process-wait "wait for message" #'mp:gate-open-p condition-v…
	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" thr…
	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)