From ea3a2433c72ee97c5691c29d882a63e4d86f0a32 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 29 Apr 2007 17:17:25 +0000 Subject: [PATCH] 1.0.5.6: compare-and-swap / instance-set-conditional refactoring * Rename *-COMPARE-AND-EXCHANGE *-COMPARE-AND-SWAP. * DEFINE-FULL-COMPARE-AND-SWAP, use it to implement %INSTANCE-COMPARE-AND-SWAP (previously %INTANCE-SET-CONDITIONAL) on x86oids. * Implement %SIMPLE-VECTOR-COMPARE-AND-SWAP. Not used right now, but required by a forthcoming patch. * Implement non-x86oid (non-threaded) versions of the above. * Check that the slot isn't raw in DEFINE-STRUCURE-SLOT-COMPARE-AND-SWAP. * Whitespace. --- package-data-list.lisp-expr | 15 ++++++++---- src/code/array.lisp | 9 ++++++++ src/code/late-extensions.lisp | 10 +++++--- src/code/target-defstruct.lisp | 9 ++++++++ src/code/target-hash-table.lisp | 14 ++++++------ src/code/target-thread.lisp | 14 ++++++------ src/compiler/fndb.lisp | 8 +++++++ src/compiler/x86-64/array.lisp | 5 ++++ src/compiler/x86-64/cell.lisp | 31 +++---------------------- src/compiler/x86-64/macros.lisp | 24 ++++++++++++++++++++ src/compiler/x86/array.lisp | 4 ++++ src/compiler/x86/cell.lisp | 48 ++++++++++++--------------------------- src/compiler/x86/macros.lisp | 36 +++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 14 files changed, 144 insertions(+), 85 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 82500c8..80dfc3f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -278,7 +278,6 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "HALT" "IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA" "INSERT-STEP-CONDITIONS" - "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" "IR2-PHYSENV-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" @@ -1169,7 +1168,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64" "%SET-SIGNED-SAP-REF-WORD" "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF" - "%SET-SYMBOL-HASH" "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT" + "%SET-SYMBOL-HASH" + "%SIMPLE-VECTOR-COMPARE-AND-SWAP" + "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT" "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING" "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE" "%UNARY-FTRUNCATE" @@ -1234,7 +1235,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #!+long-float "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" "DEFINE-STRUCTURE-SLOT-ADDRESSOR" - "DEFINE-STRUCTURE-SLOT-COMPARE-AND-EXCHANGE" + "DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP" "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P" "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR" @@ -1456,8 +1457,12 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "SPECIFIER-TYPE" "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR" "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC" - "SYMBOLS-DESIGNATOR" "%INSTANCE-LENGTH" "%INSTANCE-REF" - "%INSTANCE-SET" "SYSTEM-AREA-CLEAR" + "SYMBOLS-DESIGNATOR" + "%INSTANCE-COMPARE-AND-SWAP" + "%INSTANCE-LENGTH" + "%INSTANCE-REF" + "%INSTANCE-SET" + "SYSTEM-AREA-CLEAR" "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV" diff --git a/src/code/array.lisp b/src/code/array.lisp index 45c15a5..d569ad4 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -56,6 +56,15 @@ (values vector index)) (values array index))) +(defun %simple-vector-compare-and-swap (vector index old new) + #!+(or x86 x86-64) + (%simple-vector-compare-and-swap vector index old new) + #!-(or x86 x86-64) + (let ((n-old (svref vector index))) + (when (eq old n-old) + (setf (svref vector index) new)) + n-old)) + ;;; It'd waste space to expand copies of error handling in every ;;; inline %WITH-ARRAY-DATA, so we have them call this function ;;; instead. This is just a wrapper which is known never to return. diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp index f2756dc..52b45c6 100644 --- a/src/code/late-extensions.lisp +++ b/src/code/late-extensions.lisp @@ -49,7 +49,7 @@ ;;; Used internally, but it would be nice to provide something ;;; like this for users as well. #!+sb-thread -(defmacro define-structure-slot-compare-and-exchange +(defmacro define-structure-slot-compare-and-swap (name &key structure slot) (let* ((dd (find-defstruct-description structure t)) (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name))) @@ -57,12 +57,16 @@ (index (when slotd (dsd-index slotd)))) (unless index (error "Slot ~S not found in ~S." slot structure)) + (unless (eq t (dsd-raw-type slotd)) + (error "Cannot define compare-and-swap on a raw slot.")) + (when (dsd-read-only slotd) + (error "Cannot define compare-and-swap on a read-only slot.")) `(progn (declaim (inline ,name)) (defun ,name (instance old new) (declare (type ,structure instance) - (type ,type new)) - (sb!vm::%instance-set-conditional instance ,index old new))))) + (type ,type old new)) + (%instance-compare-and-swap instance ,index old new))))) ;;; Ditto #!+sb-thread diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index d41ff7a..ef0761f 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -31,6 +31,15 @@ (defun %instance-set (instance index new-value) (setf (%instance-ref instance index) new-value)) +(defun %instance-compare-and-swap (instance index old new) + #!+(or x86 x86-64) + (%instance-compare-and-swap instance index old new) + #!-(or x86 x86-64) + (let ((n-old (%instance-ref instance index))) + (when (eq old n-old) + (%instance-set instance index new)) + n-old)) + #!-hppa (progn (defun %raw-instance-ref/word (instance index) diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp index 2011304..79a9cbd 100644 --- a/src/code/target-hash-table.lisp +++ b/src/code/target-hash-table.lisp @@ -23,13 +23,13 @@ #!-sb-thread (declare (ignore spinlock)) `(without-gcing - (unwind-protect - (progn - #!+sb-thread - (sb!thread::get-spinlock ,spinlock) - ,@body) - #!+sb-thread - (sb!thread::release-spinlock ,spinlock)))) + (unwind-protect + (progn + #!+sb-thread + (sb!thread::get-spinlock ,spinlock) + ,@body) + #!+sb-thread + (sb!thread::release-spinlock ,spinlock)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant max-hash sb!xc:most-positive-fixnum)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 2ad4674..59d0562 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -183,8 +183,8 @@ in future versions." ;;;; spinlocks #!+sb-thread -(define-structure-slot-compare-and-exchange - compare-and-exchange-spinlock-value +(define-structure-slot-compare-and-swap + compare-and-swap-spinlock-value :structure spinlock :slot value) @@ -198,14 +198,14 @@ in future versions." ;; store any value #!+sb-thread (loop until - (eql 0 (compare-and-exchange-spinlock-value spinlock 0 1))) + (eql 0 (compare-and-swap-spinlock-value spinlock 0 1))) t) (defun release-spinlock (spinlock) (declare (optimize (speed 3) (safety 0)) #!-sb-thread (ignore spinlock)) ;; %instance-set-conditional cannot compare arbitrary objects - ;; meaningfully, so (compare-and-exchange-spinlock-value our-value 0) + ;; meaningfully, so (compare-and-swap-spinlock-value our-value 0) ;; does not work for bignum thread ids. #!+sb-thread (setf (spinlock-value spinlock) 0) @@ -226,8 +226,8 @@ in future versions." (define-structure-slot-addressor mutex-value-address :structure mutex :slot value) - (define-structure-slot-compare-and-exchange - compare-and-exchange-mutex-value + (define-structure-slot-compare-and-swap + compare-and-swap-mutex-value :structure mutex :slot value)) @@ -266,7 +266,7 @@ until it is available." (loop (unless (setf old - (compare-and-exchange-mutex-value mutex nil new-value)) + (compare-and-swap-mutex-value mutex nil new-value)) (return t)) (unless wait-p (return nil)) (with-pinned-objects (mutex old) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index eca9eaf..6972590 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1552,3 +1552,11 @@ (values) ()) (defknown style-warn (string &rest t) null ()) + +;;;; atomic ops +#!+(or x86 x86-64) +(progn + (defknown %simple-vector-compare-and-swap (simple-vector index t t) t + (unsafe)) + (defknown %instance-compare-and-swap (instance index t t) t + (unsafe))) diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp index 7b5ee7a..ad8f2a5 100644 --- a/src/compiler/x86-64/array.lisp +++ b/src/compiler/x86-64/array.lisp @@ -154,6 +154,11 @@ signed-num signed-reg) (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num unsigned-reg)) + +(define-full-compare-and-swap simple-vector-compare-and-swap + simple-vector vector-data-offset other-pointer-lowtag + (descriptor-reg any-reg) * + %simple-vector-compare-and-swap) ;;;; integer vectors whose elements are smaller than a byte, i.e., ;;;; bit, 2-bit, and 4-bit vectors diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index ba0a27e..5adb018 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/src/compiler/x86-64/cell.lisp @@ -441,32 +441,9 @@ (define-full-setter instance-index-set * instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set) - -(defknown %instance-set-conditional (instance index t t) t - (unsafe)) - -(define-vop (instance-set-conditional) - (:translate %instance-set-conditional) - (:args (object :scs (descriptor-reg) :to :eval) - (slot :scs (any-reg) :to :result) - (old-value :scs (descriptor-reg any-reg) :target rax) - (new-value :scs (descriptor-reg any-reg))) - (:arg-types instance positive-fixnum * *) - (:temporary (:sc descriptor-reg :offset rax-offset - :from (:argument 2) :to :result :target result) rax) - (:results (result :scs (descriptor-reg any-reg))) - ;(:guard (backend-featurep :i486)) - (:policy :fast-safe) - (:generator 5 - (move rax old-value) - (inst lock) - (inst cmpxchg (make-ea :qword :base object :index slot :scale 1 - :disp (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag)) - new-value) - (move result rax))) - - +(define-full-compare-and-swap instance-compare-and-swap instance + instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) + * %instance-compare-and-swap) ;;;; code object frobbing @@ -475,8 +452,6 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) - - ;;;; raw instance slot accessors diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index c549113..6ec4218 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -354,6 +354,30 @@ ;;;; indexed references +(defmacro define-full-compare-and-swap + (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :eval) + (index :scs (any-reg) :to :result) + (old-value :scs ,scs :target rax) + (new-value :scs ,scs)) + (:arg-types ,type tagged-num ,el-type ,el-type) + (:temporary (:sc descriptor-reg :offset rax-offset + :from (:argument 2) :to :result :target value) rax) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (move rax old-value) + #!+sb-thread + (inst lock) + (inst cmpxchg (make-ea :qword :base object :index index + :disp (- (* ,offset n-word-bytes) ,lowtag)) + new-value) + (move value rax))))) + (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) `(progn (define-vop (,name) diff --git a/src/compiler/x86/array.lisp b/src/compiler/x86/array.lisp index f617419..16e9aa0 100644 --- a/src/compiler/x86/array.lisp +++ b/src/compiler/x86/array.lisp @@ -150,6 +150,10 @@ #!+sb-unicode (def-full-data-vector-frobs simple-character-string character character-reg)) +(define-full-compare-and-swap simple-vector-compare-and-swap + simple-vector vector-data-offset other-pointer-lowtag + (descriptor-reg any-reg) * + %simple-vector-compare-and-swap) ;;;; integer vectors whose elements are smaller than a byte, i.e., ;;;; bit, 2-bit, and 4-bit vectors diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index e30f508..811b480 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -415,38 +415,20 @@ (loadw res struct 0 instance-pointer-lowtag) (inst shr res n-widetag-bits))) -(define-full-reffer instance-index-ref * instance-slots-offset - instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref) - -(define-full-setter instance-index-set * instance-slots-offset - instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set) - - -(defknown %instance-set-conditional (instance index t t) t - (unsafe)) - -(define-vop (instance-set-conditional) - (:translate %instance-set-conditional) - (:args (object :scs (descriptor-reg) :to :eval) - (slot :scs (any-reg) :to :result) - (old-value :scs (descriptor-reg any-reg) :target eax) - (new-value :scs (descriptor-reg any-reg))) - (:arg-types instance positive-fixnum * *) - (:temporary (:sc descriptor-reg :offset eax-offset - :from (:argument 2) :to :result :target result) eax) - (:results (result :scs (descriptor-reg any-reg))) - ;(:guard (backend-featurep :i486)) - (:policy :fast-safe) - (:generator 5 - (move eax old-value) - (inst lock) - (inst cmpxchg (make-ea :dword :base object :index slot :scale 1 - :disp (- (* instance-slots-offset n-word-bytes) - instance-pointer-lowtag)) - new-value) - (move result eax))) - - +(define-full-reffer instance-index-ref * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-ref) + +(define-full-setter instance-index-set * + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-set) + +(define-full-compare-and-swap instance-compare-and-swap instance + instance-slots-offset instance-pointer-lowtag + (any-reg descriptor-reg) * + %instance-compare-and-swap) ;;;; code object frobbing @@ -455,8 +437,6 @@ (define-full-setter code-header-set * 0 other-pointer-lowtag (any-reg descriptor-reg) * code-header-set) - - ;;;; raw instance slot accessors diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 9d6ce4a..10540ca 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -389,6 +389,42 @@ ;;;; indexed references +(defmacro define-full-compare-and-swap + (name type offset lowtag scs el-type &optional translate) + `(progn + (define-vop (,name) + ,@(when translate `((:translate ,translate))) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to :eval) + (index :scs (any-reg immediate unsigned-reg) :to :result) + (old-value :scs ,scs :target eax) + (new-value :scs ,scs)) + (:arg-types ,type tagged-num ,el-type ,el-type) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 2) :to :result :target value) eax) + (:results (value :scs ,scs)) + (:result-types ,el-type) + (:generator 5 + (move eax old-value) + #!+sb-thread + (inst lock) + (let ((ea (sc-case index + (immediate + (make-ea :dword :base object + :disp (- (* (+ ,offset (tn-value index)) + n-word-bytes) + ,lowtag))) + (unsigned-reg + (make-ea :dword :base object :index index :scale 4 + :disp (- (* ,offset n-word-bytes) + ,lowtag))) + (t + (make-ea :dword :base object :index index + :disp (- (* ,offset n-word-bytes) + ,lowtag)))))) + (inst cmpxchg ea new-value)) + (move value eax))))) + (defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate) `(progn (define-vop (,name) diff --git a/version.lisp-expr b/version.lisp-expr index 76560d8..8f0ead8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.5.5" +"1.0.5.6" -- 1.7.10.4