Before I try to understand this, is the idea that this will work on +sb-lutex as well?

Thanks,

Cyrus

On Jun 25, 2006, at 5:29 PM, Marco Monteiro wrote:

I just noticed that I have sent this to Juho Snellman and not to the mailing list.

-------- Original Message --------
Subject: Re: [Sbcl-devel] [Patch] Faster mutex.
Date: Sun, 25 Jun 2006 11:38:53 +0100
From: Marco Monteiro <masm@acm.org>
To: Juho Snellman <jsnell@iki.fi>
References: <449B47CB.8010409@acm.org> <873bdurtgx.fsf@vasara.proghammer.com>

The patch attached replaces the first one.

Juho Snellman wrote:
  * It's not immediately obvious that the code is correct. Could you add
    some comments that explain what is going on, and why it's correct?

I have a simulation of control flow on paper; it would be to much work
to explain how it works in words. With the new comments it is much
easier to see it.

  * The mutex structure now has fields named VAL and VALUE, which isn't
    very clear. VAL should probably be renamed to something more descriptive.
    Maybe STATE?
  * There are lots of magic numbers in the code. They should probably
    be named.  

Addressed in this patch. The numbers are documented.

Marco

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c77d056..e58628e 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -209,13 +209,37 @@ (setf (sb!kernel:fdocumentation 'make-mu

 

 #!+(and sb-thread (not sb-lutex))
 (progn
-  (declaim (inline mutex-value-address))
-  (defun mutex-value-address (mutex)
+  (declaim (inline mutex-lock-address
+                   try-lock-mutex lock-mutex unlock-mutex))
+  (defun mutex-lock-address (mutex)
     (declare (optimize (speed 3)))
     (sb!ext:truly-the
      sb!vm:word
      (+ (sb!kernel:get-lisp-obj-address mutex)
-        (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
+        (- (* 4 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+  ;; (MUTEX-LOCK MUTEX) can be 0, 1, or 2. If it is 0, MUTEX is unlocked.
+  ;; If it is 1, MUTEX is locked and uncontended. If it is 2, MUTEX is
+  ;; locked and contended.
+  (defun try-lock-mutex (mutex)
+    (declare (type mutex mutex) (optimize (speed 3)))
+    (zerop (the fixnum (sb!vm::%instance-set-conditional mutex 3 0 1))))
+  (defun lock-mutex (mutex)
+    (declare (type mutex mutex) (optimize (speed 3)))
+    (let ((c (sb!vm::%instance-set-conditional mutex 3 0 1)))
+      (declare (type fixnum c))
+      (unless (zerop c)
+        (when (= c 1)
+          (setf c (sb!vm::%instance-set-return-old mutex 3 2)))
+        (loop until (zerop c) do
+              (with-pinned-objects (mutex)
+                (futex-wait (mutex-lock-address mutex) (sb!vm:fixnumize 2)))
+              (setf c (sb!vm::%instance-set-return-old mutex 3 2))))))
+  (defun unlock-mutex (mutex)
+    (declare (type mutex mutex) (optimize (speed 3)))
+    ;; FUTEX-WAKE only when there is contention.
+    (when (= 2 (the fixnum (sb!vm::%instance-add-return-old mutex 3 -1)))
+      (setf (mutex-lock mutex) 0)
+      (futex-wake (mutex-lock-address mutex) 1))))

 

 (defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
   #!+sb-doc
@@ -248,16 +272,13 @@ until it is available"
         (%lutex-lock lutex))
       (setf (mutex-value mutex) new-value))
     #!-sb-lutex
-    (let (old)
-      (loop
-         (unless
-             (setf old (sb!vm::%instance-set-conditional mutex 2 nil
-                                                         new-value))
-           (return t))
-         (unless wait-p (return nil))
-         (with-pinned-objects (mutex old)
-           (futex-wait (mutex-value-address mutex)
-                       (sb!kernel:get-lisp-obj-address old)))))))
+    (progn
+      (if wait-p
+          (lock-mutex mutex)
+          (unless (try-lock-mutex mutex)
+            (return-from get-mutex nil)))
+      (setf (mutex-value mutex) new-value)
+      t)))

 

 (defun release-mutex (mutex)
   #!+sb-doc
@@ -272,7 +293,7 @@ this mutex."
     (with-lutex-address (lutex (mutex-lutex mutex))
       (%lutex-unlock lutex))
     #!-sb-lutex
-    (futex-wake (mutex-value-address mutex) 1)))
+    (unlock-mutex mutex)))

 

 ;;;; waitqueues/condition variables

 

diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 37e89ac..ef04070 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -16,7 +16,9 @@ (def!struct mutex
   "Mutex type."
   (name nil :type (or null simple-string))
   (value nil)
-  #!+(and sb-lutex sb-thread)
+  #!+(and sb-thread (not sb-lutex))
+  (lock 0)                              ; for use with futex functions
+  #!+(and sb-thread sb-lutex)
   (lutex (make-lutex)))

 

 (def!struct spinlock
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 60171da..123f9b1 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -479,6 +479,49 @@ (define-vop (instance-set-conditional)
           new-value)
     (move result rax)))

 

+(defknown %instance-set-return-old (instance index t) t
+          (unsafe))
+
+(define-vop (instance-set-return-old)
+  (:args (object :scs (descriptor-reg) :to :eval)
+         (slot :scs (any-reg) :to :result)
+         (value :scs (descriptor-reg any-reg) :target rax))
+  (:arg-types instance positive-fixnum *)
+  (:policy :fast-safe)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+                   :from (:argument 2) :to :result :target result)  rax)
+  (:translate %instance-set-return-old)
+  (:generator 5
+    (move rax value)
+    (inst lock)
+    (inst xchg (make-ea :qword :base object :index slot :scale 1
+                        :disp (- (* instance-slots-offset n-word-bytes)
+                                 instance-pointer-lowtag))
+          rax)
+    (move result rax)))
+
+(defknown %instance-add-return-old (instance index fixnum) t
+          (unsafe))
+
+(define-vop (instance-add-return-old)
+    (:args (object :scs (descriptor-reg) :to :eval)
+           (slot :scs (any-reg) :to :result)
+           (increment :scs (any-reg) :target rax))
+  (:arg-types instance positive-fixnum fixnum)
+  (:policy :fast-safe)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+                   :from (:argument 2) :to :result :target result) rax)
+  (:translate %instance-add-return-old)
+  (:generator 5
+    (move rax increment)
+    (inst lock)
+    (inst xadd (make-ea :qword :base object :index slot :scale 1
+                        :disp (+ (* instance-slots-offset n-word-bytes)
+                                 (- instance-pointer-lowtag)))
+          rax)
+    (move result rax)))

 

 

 ;;;; code object frobbing
diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 6aaf63a..5b078fd 100644
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -481,6 +481,49 @@ (define-vop (instance-set-conditional)
           new-value)
     (move result eax)))

 

+(defknown %instance-set-return-old (instance index t) t
+          (unsafe))
+
+(define-vop (instance-set-return-old)
+  (:args (object :scs (descriptor-reg) :to :eval)
+         (slot :scs (any-reg) :to :result)
+         (value :scs (descriptor-reg any-reg) :target eax))
+  (:arg-types instance positive-fixnum *)
+  (:policy :fast-safe)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset eax-offset
+                   :from (:argument 2) :to :result :target result)  eax)
+  (:translate %instance-set-return-old)
+  (:generator 5
+    (move eax value)
+    (inst lock)
+    (inst xchg (make-ea :dword :base object :index slot :scale 1
+                        :disp (- (* instance-slots-offset n-word-bytes)
+                                 instance-pointer-lowtag))
+          eax)
+    (move result eax)))
+
+(defknown %instance-add-return-old (instance index fixnum) t
+          (unsafe))
+
+(define-vop (instance-add-return-old)
+    (:args (object :scs (descriptor-reg) :to :eval)
+           (slot :scs (any-reg) :to :result)
+           (increment :scs (any-reg) :target eax))
+  (:arg-types instance positive-fixnum fixnum)
+  (:policy :fast-safe)
+  (:results (result :scs (descriptor-reg any-reg)))
+  (:temporary (:sc descriptor-reg :offset rax-offset
+                   :from (:argument 2) :to :result :target result) eax)
+  (:translate %instance-add-return-old)
+  (:generator 5
+    (move eax increment)
+    (inst lock)
+    (inst xadd (make-ea :dword :base object :index slot :scale 1
+                        :disp (+ (* instance-slots-offset n-word-bytes)
+                                 (- instance-pointer-lowtag)))
+          eax)
+    (move result eax)))

 

 

 ;;;; code object frobbing

Using Tomcat but need to do more? Need to support web services, security?
Get stuff done quickly with pre-integrated technology to make your job easier
Download IBM WebSphere Application Server v.1.0.1 based on Apache Geronimo
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=120709&bid=263057&dat=121642
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel