X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=54092dedee2cebadc2ba5d53d8818e06c1c5b13b;hb=496071a75429677a2c064e4995c379d3ba6ec458;hp=5571ef8a916e89586e63eb2d40983cd7fd9bc490;hpb=ec2e02db335d1545b3c18233bf440ca4160f780d;p=sbcl.git

diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 5571ef8..54092de 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -15,10 +15,30 @@
   #!+sb-doc
   "Mutex type."
   (name nil :type (or null simple-string))
-  (value nil)
+  (%owner nil :type (or null thread))
+  #!+(and (not sb-lutex) sb-thread)
+  (state 0 :type fixnum)
   #!+(and sb-lutex sb-thread)
   (lutex (make-lutex)))
 
+;;; FIXME: We probably want to rename the accessor MUTEX-OWNER.
+(defun mutex-value (mutex)
+  "Current owner of the mutex, NIL if the mutex is free."
+  (mutex-%owner mutex))
+
+(defsetf mutex-value set-mutex-value)
+
+(declaim (inline set-mutex-value))
+(defun set-mutex-value (mutex value)
+  (declare (ignore mutex value))
+  (error "~S is no longer supported." '(setf mutex-value)))
+
+(define-compiler-macro set-mutex-value (&whole form mutex value)
+  (declare (ignore mutex value))
+  (warn "~S is no longer supported, and will signal an error at runtime."
+        '(setf mutex-value))
+  form)
+
 (def!struct spinlock
   #!+sb-doc
   "Spinlock type."
@@ -38,12 +58,22 @@ and the mutex is in use, sleep until it is available"
       ,value
       ,wait-p)))
 
-(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body)
+(sb!xc:defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts) &body body)
   `(dx-flet ((with-system-mutex-thunk () ,@body))
-     (call-with-system-mutex
-      #'with-system-mutex-thunk
-      ,mutex
-      ,without-gcing)))
+     (,(cond (without-gcing
+               'call-with-system-mutex/without-gcing)
+             (allow-with-interrupts
+              'call-with-system-mutex/allow-with-interrupts)
+             (t
+              'call-with-system-mutex))
+       #'with-system-mutex-thunk
+       ,mutex)))
+
+(sb!xc:defmacro with-system-spinlock ((spinlock &key) &body body)
+  `(dx-flet ((with-system-spinlock-thunk () ,@body))
+     (call-with-system-spinlock
+       #'with-system-spinlock-thunk
+       ,spinlock)))
 
 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   #!+sb-doc
@@ -62,13 +92,16 @@ provided the default value is used for the mutex."
       #'with-recursive-spinlock-thunk
       ,spinlock)))
 
-(sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing)
+(sb!xc:defmacro with-recursive-system-spinlock ((spinlock
+                                                 &key without-gcing)
                                                 &body body)
   `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
-     (call-with-recursive-system-spinlock
-      #'with-recursive-system-spinlock-thunk
-      ,spinlock
-      ,without-gcing)))
+     (,(cond (without-gcing
+               'call-with-recursive-system-spinlock/without-gcing)
+             (t
+              'call-with-recursive-system-spinlock))
+       #'with-recursive-system-spinlock-thunk
+       ,spinlock)))
 
 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
   `(dx-flet ((with-spinlock-thunk () ,@body))
@@ -82,24 +115,22 @@ provided the default value is used for the mutex."
 ;;; using them.
 #!-sb-thread
 (progn
-  (defun call-with-system-mutex (function mutex &optional without-gcing-p)
-    (declare (ignore mutex)
-             (function function))
-    (if without-gcing-p
-        (without-gcing
-          (funcall function))
-        (without-interrupts
-          (funcall function))))
-
-  (defun call-with-recursive-system-spinlock (function lock
-                                              &optional without-gcing-p)
-    (declare (ignore lock)
-             (function function))
-    (if without-gcing-p
-        (without-gcing
-          (funcall function))
-        (without-interrupts
-          (funcall function))))
+  (macrolet ((def (name &optional variant)
+               `(defun ,(if variant (symbolicate name "/" variant) name) (function lock)
+                  (declare (ignore lock) (function function))
+                  ,(ecase variant
+                    (:without-gcing
+                      `(without-gcing (funcall function)))
+                    (:allow-with-interrupts
+                      `(without-interrupts (allow-with-interrupts (funcall function))))
+                    ((nil)
+                      `(without-interrupts (funcall function)))))))
+    (def call-with-system-mutex)
+    (def call-with-system-mutex :without-gcing)
+    (def call-with-system-mutex :allow-with-interrupts)
+    (def call-with-system-spinlock)
+    (def call-with-recursive-system-spinlock)
+    (def call-with-recursive-system-spinlock :without-gcing))
 
   (defun call-with-mutex (function mutex value waitp)
     (declare (ignore mutex value waitp)
@@ -120,43 +151,68 @@ provided the default value is used for the mutex."
 
 #!+sb-thread
 ;;; KLUDGE: These need to use DX-LET, because the cleanup form that
-;;; closes over GOT-IT causes a value-cell to be allocated for it -- and
-;;; we prefer that to go on the stack since it can.
+;;; closes over GOT-IT causes a value-cell to be allocated for it --
+;;; and we prefer that to go on the stack since it can.
 (progn
-  (defun call-with-system-mutex (function mutex &optional without-gcing-p)
-    (declare (function function))
-    (flet ((%call-with-system-mutex ()
-             (dx-let (got-it)
-               (unwind-protect
-                    (when (setf got-it (get-mutex mutex))
-                      (funcall function))
-                 (when got-it
-                   (release-mutex mutex))))))
-      (if without-gcing-p
-          (without-gcing
-            (%call-with-system-mutex))
-          (without-interrupts
-            (%call-with-system-mutex)))))
-
-  (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p)
+  (macrolet ((def (name &optional variant)
+               `(defun ,(if variant (symbolicate name "/" variant) name) (function mutex)
+                  (declare (function function))
+                  (flet ((%call-with-system-mutex ()
+                           (dx-let (got-it)
+                             #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
+                             (unwind-protect
+                                  (when (setf got-it (get-mutex mutex))
+                                    (funcall function))
+                               (when got-it
+                                 (release-mutex mutex))))))
+                    (declare (inline %call-with-system-mutex))
+                    ,(ecase variant
+                      (:without-gcing
+                        `(without-gcing (%call-with-system-mutex)))
+                      (:allow-with-interrupts
+                        `(without-interrupts (allow-with-interrupts (%call-with-system-mutex))))
+                      ((nil)
+                        `(without-interrupts (%call-with-system-mutex))))))))
+    (def call-with-system-mutex)
+    (def call-with-system-mutex :without-gcing)
+    (def call-with-system-mutex :allow-with-interrupts))
+
+  (defun call-with-system-spinlock (function spinlock)
     (declare (function function))
-    (flet ((%call-with-system-spinlock ()
-             (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock)))
-                      (got-it nil))
-               (unwind-protect
-                    (when (or inner-lock-p (setf got-it (get-spinlock lock)))
-                      (funcall function))
-                 (when got-it
-                   (release-spinlock lock))))))
-      (if without-gcing-p
-          (without-gcing
-            (%call-with-system-spinlock))
-          (without-interrupts
-            (%call-with-system-spinlock)))))
+    (without-interrupts
+      (dx-let (got-it)
+        #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
+        (unwind-protect
+             (when (setf got-it (get-spinlock spinlock))
+               (funcall function))
+          (when got-it
+            (release-spinlock spinlock))))))
+
+  (macrolet ((def (name &optional variant)
+               `(defun ,(if variant (symbolicate name "/" variant) name) (function spinlock)
+                  (declare (function function))
+                  (flet ((%call-with-system-spinlock ()
+                           (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value spinlock)))
+                                    (got-it nil))
+                             #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
+                             (unwind-protect
+                                  (when (or inner-lock-p (setf got-it (get-spinlock spinlock)))
+                                    (funcall function))
+                               (when got-it
+                                 (release-spinlock spinlock))))))
+                    (declare (inline %call-with-system-spinlock))
+                    ,(ecase variant
+                      (:without-gcing
+                        `(without-gcing (%call-with-system-spinlock)))
+                      ((nil)
+                        `(without-interrupts (%call-with-system-spinlock))))))))
+    (def call-with-recursive-system-spinlock)
+    (def call-with-recursive-system-spinlock :without-gcing))
 
   (defun call-with-spinlock (function spinlock)
     (declare (function function))
     (dx-let ((got-it nil))
+      #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
       (without-interrupts
         (unwind-protect
              (when (setf got-it (allow-with-interrupts
@@ -168,6 +224,7 @@ provided the default value is used for the mutex."
   (defun call-with-mutex (function mutex value waitp)
     (declare (function function))
     (dx-let ((got-it nil))
+      #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
       (without-interrupts
         (unwind-protect
              (when (setq got-it (allow-with-interrupts
@@ -178,8 +235,9 @@ provided the default value is used for the mutex."
 
   (defun call-with-recursive-lock (function mutex)
     (declare (function function))
-    (dx-let ((inner-lock-p (eq (mutex-value mutex) *current-thread*))
+    (dx-let ((inner-lock-p (eq (mutex-%owner mutex) *current-thread*))
              (got-it nil))
+      #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
       (without-interrupts
         (unwind-protect
              (when (or inner-lock-p (setf got-it (allow-with-interrupts
@@ -194,6 +252,7 @@ provided the default value is used for the mutex."
     (declare (function function))
     (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*))
           (got-it nil))
+      #-sb-xc-host (declare (optimize sb!c::stack-allocate-value-cells))
       (without-interrupts
         (unwind-protect
              (when (or inner-lock-p (setf got-it (allow-with-interrupts