diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 7ef3eac62b805d142b96a3d91d647e4181af8ca5..f4816216f2258d6a17dafd460082707fbdd66a85 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.17 2002/09/07 13:16:48 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.18 2002/09/07 13:28:45 pmai Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; @@ -106,13 +106,13 @@ `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) - (without-interrupts + (with-pcl-lock (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) (defmacro modify-cache (cache-vector &body body) - `(without-interrupts + `(with-pcl-lock (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) @@ -178,7 +178,7 @@ ;;; (defun get-cache-vector (size) (let ((entry (gethash size *free-cache-vectors*))) - (without-interrupts + (with-pcl-lock (cond ((null entry) (setf (gethash size *free-cache-vectors*) (cons 0 nil)) (get-cache-vector size)) @@ -192,7 +192,7 @@ (defun free-cache-vector (cache-vector) (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) - (without-interrupts + (with-pcl-lock (if (null entry) (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") (let ((thread (cdr entry))) @@ -520,7 +520,7 @@ (defvar *free-caches* nil) (defun get-cache (nkeys valuep limit-fn nlines) - (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (let ((cache (or (with-pcl-lock (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (compute-cache-parameters nkeys valuep nlines) @@ -544,7 +544,7 @@ &optional (new-field (first-wrapper-cache-number-index))) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) - (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (cache (or (with-pcl-lock (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (if (= new-nlines (cache-nlines old-cache)) diff --git a/pcl/low.lisp b/pcl/low.lisp index ca8556c43acd0fad8969cfe3380679a363b25ca8..87ecd7b75f9a7221b0dae5650e933543494a155c 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.16 2002/09/07 13:16:48 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.17 2002/09/07 13:28:46 pmai Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -58,29 +58,37 @@ declaration.") ,new-value))) ;;; -;;; without-interrupts -;;; -;;; OK, Common Lisp doesn't have this and for good reason. But For all of -;;; the Common Lisp's that PCL runs on today, there is a meaningful way to -;;; implement this. WHAT I MEAN IS: -;;; -;;; I want the body to be evaluated in such a way that no other code that is -;;; running PCL can be run during that evaluation. I agree that the body -;;; won't take *long* to evaluate. That is to say that I will only use -;;; without interrupts around relatively small computations. +;;; With-Pcl-Lock ;;; -;;; INTERRUPTS-ON should turn interrupts back on if they were on. -;;; INTERRUPTS-OFF should turn interrupts back off. -;;; These are only valid inside the body of WITHOUT-INTERRUPTS. +;;; Evaluate the body in such a way that no other code that is +;;; running PCL can be run during that evaluation. ;;; -;;; OK? -;;; -;;; For CMU CL we just use our without-interrupts. We don't have the -;;; INTERRUPTS-ON/OFF local macros spec'ed, but they aren't used. +;;; Note that the MP version, which uses a PCL-specific lock +;;; is rather experimental, in that it is not currently clear +;;; if the code inside with-pcl-lock only has to prevent other +;;; threads from entering such sections, or if it really has to +;;; prevent _ALL_ other PCL code (e.g. GF invocations, etc.) +;;; from running. If the latter then we really need to identify +;;; all places that need to acquire the PCL lock, if we are going to +;;; support multiple concurrent threads/processes on SMP machines. +;;; +;;; For the moment we do the experimental thing, and fix any bugs +;;; that occur as a result of this. -- PRM 2002-09-06 ;;; -(defmacro without-interrupts (&body body) + +#-MP +(defmacro with-pcl-lock (&body body) `(sys:without-interrupts ,@body)) +#+MP +(defvar *global-pcl-lock* (mp:make-lock "Global PCL Lock")) + +#+MP +(defmacro with-pcl-lock (&body body) + `(mp:with-lock-held (*global-pcl-lock*) + ,@body)) + + ;;; ;;; FUNCTION-ARGLIST diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 591fbdca771fa85f175ac19dba730a426a0742a0..76ce6e71ec357ef845a0146eb371c7e9ac36c04b 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.12 1999/05/30 23:14:06 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.13 2002/09/07 13:28:46 pmai Exp $") ;;; (in-package :pcl) @@ -68,7 +68,7 @@ (error "What kind of instance is this?")))) (defun swap-wrappers-and-slots (i1 i2) - (without-interrupts + (with-pcl-lock (cond ((std-instance-p i1) (let ((w1 (std-instance-wrapper i1)) (s1 (std-instance-slots i1))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 35d017f97efd1cd255b9660dc705827036179916..bd7572025b1eefd231cf03c329bd992a8b93c1ef 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.33 2002/08/27 18:46:49 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.34 2002/09/07 13:28:46 pmai Exp $") ;;; (in-package :pcl) @@ -1073,7 +1073,7 @@ (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (without-interrupts + (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper :flush nwrapper)))))) @@ -1097,7 +1097,7 @@ (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) - (without-interrupts + (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper :obsolete nwrapper)