Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

1.0.7.19: SB-EXT:COMPARE-AND-SWAP

 * New macro SB-EXT:COMPARE-AND-SWAP provides a supported interface to
   compare-and-swap functionality.

 * New info-type :FUNCTION :STRUCTURE-ACCESSOR allows us to map from
   defstruct slot-accessor names to defstruct descriptions.

 * Add :CAS-TRANS slot keyword to DEFINE-PRIMITIVE object, and the
   compiler machinery needed to support compare and swap on primitive
   object slots.

 * New VOPs COMPARE-AND-SWAP-SLOT and %COMPARE-AND-SWAP-SYMBOL-VALUE.

 * Delete now unnecessary DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP.

 * Use a consistent %COMPARE-AND-SWAP-FOO naming scheme for CAS
   functions.

 * Tests.

 Tested on x86/Linux & x86/Darwin, x86-64/Darwi, and PPC/Darwin.
  • Loading branch information...
commit bfb19d306581ac86feb4371846c4b9953d692dd8 1 parent f34fee2
Nikodemus Siivola nikodemus authored
2  NEWS
... ... @@ -1,5 +1,7 @@
1 1 ;;;; -*- coding: utf-8; -*-
2 2 changes in sbcl-1.0.8 relative to sbcl-1.0.7:
  3 + * enhancement: experimental macro SB-EXT:COMPARE-AND-SWAP provides
  4 + atomic compare-and-swap operations on threaded platforms.
3 5 * enhancement: experimental function SB-EXT:RESTRICT-COMPILER-POLICY
4 6 allows assining a global minimum value to optimization qualities
5 7 (overriding proclamations and declarations).
3  base-target-features.lisp-expr
@@ -323,6 +323,9 @@
323 323 ;; :alien-callbacks
324 324 ;; Alien callbacks have been implemented for this platform.
325 325 ;;
  326 + ;; :compare-and-swap-vops
  327 + ;; The backend implements compare-and-swap VOPs.
  328 + ;;
326 329 ;; operating system features:
327 330 ;; :linux = We're intended to run under some version of Linux.
328 331 ;; :bsd = We're intended to run under some version of BSD Unix. (This
6 make-config.sh
@@ -274,7 +274,8 @@ cd $original_dir
274 274 # if we're building for x86. -- CSR, 2002-02-21 Then we do something
275 275 # similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
276 276 if [ "$sbcl_arch" = "x86" ]; then
277   - printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :unwind-to-frame-and-call-vop' >> $ltf
  277 + printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
  278 + printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
278 279 printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
279 280 if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "darwin" ] || [ "$sbcl_os" = "win32" ]; then
280 281 printf ' :linkage-table' >> $ltf
@@ -285,7 +286,8 @@ if [ "$sbcl_arch" = "x86" ]; then
285 286 printf ' :os-provides-dlopen' >> $ltf
286 287 fi
287 288 elif [ "$sbcl_arch" = "x86-64" ]; then
288   - printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table :unwind-to-frame-and-call-vop' >> $ltf
  289 + printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
  290 + printf ' :compare-and-swap-vop :unwind-to-frame-and-call-vop' >> $ltf
289 291 printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
290 292 elif [ "$sbcl_arch" = "mips" ]; then
291 293 printf ' :linkage-table' >> $ltf
17 package-data-list.lisp-expr
@@ -240,6 +240,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
240 240 "CLOSURE-INIT" "CLOSURE-REF"
241 241 "CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
242 242 "*CODE-COVERAGE-INFO*"
  243 + "COMPARE-AND-SWAP-SLOT"
243 244 "COMPILE-IN-LEXENV"
244 245 "COMPILE-LAMBDA-FOR-DEFUN"
245 246 "%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR"
@@ -338,6 +339,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
338 339 "VAR-ALLOC"
339 340 "SAFE-FDEFN-FUN"
340 341 "NOTE-FIXUP"
  342 + "DEF-CASSER"
341 343 "DEF-REFFER"
342 344 "EMIT-NOP"
343 345 "DEF-SETTER"
@@ -578,6 +580,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
578 580 "*POSIX-ARGV*" "*CORE-PATHNAME*"
579 581 "POSIX-GETENV" "POSIX-ENVIRON"
580 582
  583 + "COMPARE-AND-SWAP"
  584 +
581 585 ;; People have various good reasons to mess with the GC.
582 586 "*AFTER-GC-HOOKS*"
583 587 "BYTES-CONSED-BETWEEN-GCS"
@@ -1137,7 +1141,14 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
1137 1141 "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ASIN" "%ASINH"
1138 1142 "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC"
1139 1143 "%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS"
1140   - "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
  1144 + "%CLOSURE-FUN" "%CLOSURE-INDEX-REF"
  1145 + "%COMPARE-AND-SWAP-CAR"
  1146 + "%COMPARE-AND-SWAP-CDR"
  1147 + "%COMPARE-AND-SWAP-INSTANCE-REF"
  1148 + "%COMPARE-AND-SWAP-SVREF"
  1149 + "%COMPARE-AND-SWAP-SYMBOL-PLIST"
  1150 + "%COMPARE-AND-SWAP-SYMBOL-VALUE"
  1151 + "%COS" "%COS-QUICK"
1141 1152 "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
1142 1153 "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EXP" "%EXPM1" "%FIND-POSITION"
1143 1154 "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF"
@@ -1180,7 +1191,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
1180 1191 "%SET-SIGNED-SAP-REF-WORD"
1181 1192 "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF"
1182 1193 "%SET-SYMBOL-HASH"
1183   - "%SIMPLE-VECTOR-COMPARE-AND-SWAP"
1184 1194 "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT"
1185 1195 "%SINH" "%SQRT" "%SXHASH-SIMPLE-STRING"
1186 1196 "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH"
@@ -1246,7 +1256,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
1246 1256 #!+long-float "DECODE-LONG-FLOAT"
1247 1257 "DECODE-SINGLE-FLOAT"
1248 1258 "DEFINE-STRUCTURE-SLOT-ADDRESSOR"
1249   - "DEFINE-STRUCTURE-SLOT-COMPARE-AND-SWAP"
1250 1259 "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P"
1251 1260 "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO"
1252 1261 "DISPLACED-TO-ARRAY-TOO-SMALL-ERROR"
@@ -1463,7 +1472,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
1463 1472 "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P"
1464 1473 #!+sb-unicode "SIMPLE-CHARACTER-STRING-P"
1465 1474 "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY"
1466   - "SIMPLE-VECTOR-COMPARE-AND-SWAP"
1467 1475 "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
1468 1476 "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND"
1469 1477 "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
@@ -1471,7 +1479,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
1471 1479 "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR"
1472 1480 "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC"
1473 1481 "SYMBOLS-DESIGNATOR"
1474   - "%INSTANCE-COMPARE-AND-SWAP"
1475 1482 "%INSTANCE-LENGTH"
1476 1483 "%INSTANCE-REF"
1477 1484 "%INSTANCE-SET"
13 src/code/array.lisp
@@ -56,19 +56,6 @@
56 56 (values vector index))
57 57 (values array index)))
58 58
59   -(declaim (inline simple-vector-compare-and-swap))
60   -(defun simple-vector-compare-and-swap (vector index old new)
61   - #!+(or x86 x86-64)
62   - (%simple-vector-compare-and-swap vector
63   - (%check-bound vector (length vector) index)
64   - old
65   - new)
66   - #!-(or x86 x86-64)
67   - (let ((n-old (svref vector index)))
68   - (when (eq old n-old)
69   - (setf (svref vector index) new))
70   - n-old))
71   -
72 59 ;;; It'd waste space to expand copies of error handling in every
73 60 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
74 61 ;;; instead. This is just a wrapper which is known never to return.
1  src/code/defstruct.lisp
@@ -1034,6 +1034,7 @@
1034 1034 (let* ((accessor-name (dsd-accessor-name dsd))
1035 1035 (dsd-type (dsd-type dsd)))
1036 1036 (when accessor-name
  1037 + (setf (info :function :structure-accessor accessor-name) dd)
1037 1038 (let ((inherited (accessor-inherited-data accessor-name dd)))
1038 1039 (cond
1039 1040 ((not inherited)
93 src/code/late-extensions.lisp
@@ -48,26 +48,7 @@
48 48
49 49 ;;; Used internally, but it would be nice to provide something
50 50 ;;; like this for users as well.
51   -(defmacro define-structure-slot-compare-and-swap
52   - (name &key structure slot)
53   - (let* ((dd (find-defstruct-description structure t))
54   - (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
55   - (type (when slotd (dsd-type slotd)))
56   - (index (when slotd (dsd-index slotd))))
57   - (unless index
58   - (error "Slot ~S not found in ~S." slot structure))
59   - (unless (eq t (dsd-raw-type slotd))
60   - (error "Cannot define compare-and-swap on a raw slot."))
61   - (when (dsd-read-only slotd)
62   - (error "Cannot define compare-and-swap on a read-only slot."))
63   - `(progn
64   - (declaim (inline ,name))
65   - (defun ,name (instance old new)
66   - (declare (type ,structure instance)
67   - (type ,type old new))
68   - (%instance-compare-and-swap instance ,index old new)))))
69 51
70   -;;; Ditto
71 52 #!+sb-thread
72 53 (defmacro define-structure-slot-addressor (name &key structure slot)
73 54 (let* ((dd (find-defstruct-description structure t))
@@ -85,3 +66,77 @@
85 66 (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
86 67 sb!vm:instance-pointer-lowtag)))))))
87 68
  69 +(defmacro compare-and-swap (place old new)
  70 + "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
  71 +Two values are considered to match if they are EQ. Returns the previous value
  72 +of PLACE: if the returned value if EQ to OLD, the swap was carried out.
  73 +
  74 +PLACE must be an accessor form whose CAR is one of the following:
  75 +
  76 + CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
  77 +
  78 +or the name of a DEFSTRUCT created accessor for a slot whose declared type is
  79 +either FIXNUM or T. Results are unspecified if the slot has a declared type
  80 +other then FIXNUM or T.
  81 +
  82 +EXPERIMENTAL: Interface subject to change."
  83 + (flet ((invalid-place ()
  84 + (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
  85 + (unless (consp place)
  86 + (invalid-place))
  87 + ;; FIXME: Not the nicest way to do this...
  88 + (destructuring-bind (op &rest args) place
  89 + (case op
  90 + ((car first)
  91 + `(%compare-and-swap-car (the cons ,@args) ,old ,new))
  92 + ((cdr rest)
  93 + `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
  94 + (symbol-plist
  95 + `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
  96 + (symbol-value
  97 + `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
  98 + (svref
  99 + (let ((vector (car args))
  100 + (index (cadr args)))
  101 + (unless (and vector index (not (cddr args)))
  102 + (invalid-place))
  103 + (with-unique-names (v)
  104 + `(let ((,v ,vector))
  105 + (declare (simple-vector ,v))
  106 + (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
  107 + (t
  108 + (let ((dd (info :function :structure-accessor op)))
  109 + (if dd
  110 + (let* ((structure (dd-name dd))
  111 + (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
  112 + (index (dsd-index slotd))
  113 + (type (dsd-type slotd)))
  114 + (unless (eq t (dsd-raw-type slotd))
  115 + (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
  116 + place))
  117 + (when (dsd-read-only slotd)
  118 + (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
  119 + place))
  120 + `(truly-the (values ,type &optional)
  121 + (%compare-and-swap-instance-ref (the ,structure ,@args)
  122 + ,index
  123 + (the ,type ,old) (the ,type ,new))))
  124 + (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
  125 +
  126 +(macrolet ((def (name lambda-list ref &optional set)
  127 + `(defun ,name (,@lambda-list old new)
  128 + #!+compare-and-swap-vops
  129 + (,name ,@lambda-list old new)
  130 + #!-compare-and-swap-vops
  131 + (let ((current (,ref ,@lambda-list)))
  132 + (when (eq current old)
  133 + ,(if set
  134 + `(,set ,@lambda-list new)
  135 + `(setf (,ref ,@lambda-list) new)))
  136 + current))))
  137 + (def %compare-and-swap-car (cons) car)
  138 + (def %compare-and-swap-cdr (cons) cdr)
  139 + (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
  140 + (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
  141 + (def %compare-and-swap-symbol-value (symbol) symbol-value)
  142 + (def %compare-and-swap-svref (vector index) svref))
9 src/code/target-defstruct.lisp
@@ -31,15 +31,6 @@
31 31 (defun %instance-set (instance index new-value)
32 32 (setf (%instance-ref instance index) new-value))
33 33
34   -(defun %instance-compare-and-swap (instance index old new)
35   - #!+(or x86 x86-64)
36   - (%instance-compare-and-swap instance index old new)
37   - #!-(or x86 x86-64)
38   - (let ((n-old (%instance-ref instance index)))
39   - (when (eq old n-old)
40   - (%instance-set instance index new))
41   - n-old))
42   -
43 34 #!-hppa
44 35 (progn
45 36 (defun %raw-instance-ref/word (instance index)
21 src/code/target-thread.lisp
@@ -181,25 +181,19 @@ in future versions."
181 181 (declare (type (unsigned-byte 27) n))
182 182 (sb!vm::current-thread-offset-sap n))
183 183
184   -;;;; spinlocks
185   -(define-structure-slot-compare-and-swap
186   - compare-and-swap-spinlock-value
187   - :structure spinlock
188   - :slot value)
189   -
190 184 (declaim (inline get-spinlock release-spinlock))
191 185
192 186 ;; Should always be called with interrupts disabled.
193 187 (defun get-spinlock (spinlock)
194 188 (declare (optimize (speed 3) (safety 0)))
195 189 (let* ((new *current-thread*)
196   - (old (compare-and-swap-spinlock-value spinlock nil new)))
  190 + (old (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)))
197 191 (when old
198 192 (when (eq old new)
199 193 (error "Recursive lock attempt on ~S." spinlock))
200 194 #!+sb-thread
201 195 (flet ((cas ()
202   - (unless (compare-and-swap-spinlock-value spinlock nil new)
  196 + (unless (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
203 197 (return-from get-spinlock t))))
204 198 (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
205 199 ;; If interrupts are enabled, but we are allowed to enabled them,
@@ -226,14 +220,9 @@ in future versions."
226 220 "The value of the mutex. NIL if the mutex is free. Setfable.")
227 221
228 222 #!+(and sb-thread (not sb-lutex))
229   -(progn
230   - (define-structure-slot-addressor mutex-value-address
  223 +(define-structure-slot-addressor mutex-value-address
231 224 :structure mutex
232 225 :slot value)
233   - (define-structure-slot-compare-and-swap
234   - compare-and-swap-mutex-value
235   - :structure mutex
236   - :slot value))
237 226
238 227 (defun get-mutex (mutex &optional (new-value *current-thread*) (waitp t))
239 228 #!+sb-doc
@@ -275,7 +264,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
275 264 (setf (mutex-value mutex) new-value))
276 265 #!-sb-lutex
277 266 (let (old)
278   - (when (and (setf old (compare-and-swap-mutex-value mutex nil new-value))
  267 + (when (and (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))
279 268 waitp)
280 269 (loop while old
281 270 do (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
@@ -285,7 +274,7 @@ NIL. If WAITP is non-NIL and the mutex is in use, sleep until it is available."
285 274 (or to-sec -1)
286 275 (or to-usec 0))))
287 276 (signal-deadline)))
288   - (setf old (compare-and-swap-mutex-value mutex nil new-value))))
  277 + (setf old (sb!ext:compare-and-swap (mutex-value mutex) nil new-value))))
289 278 (not old))))
290 279
291 280 (defun release-mutex (mutex)
12 src/compiler/fndb.lisp
@@ -1554,9 +1554,9 @@
1554 1554 (defknown style-warn (string &rest t) null ())
1555 1555
1556 1556 ;;;; atomic ops
1557   -#!+(or x86 x86-64)
1558   -(progn
1559   - (defknown %simple-vector-compare-and-swap (simple-vector index t t) t
1560   - (unsafe))
1561   - (defknown %instance-compare-and-swap (instance index t t) t
1562   - (unsafe)))
  1557 +(defknown %compare-and-swap-svref (simple-vector index t t) t
  1558 + (unsafe))
  1559 +(defknown %compare-and-swap-instance-ref (instance index t t) t
  1560 + (unsafe))
  1561 +(defknown %compare-and-swap-symbol-value (symbol t t) t
  1562 + (unsafe unwind))
6 src/compiler/fun-info-funs.lisp
@@ -34,3 +34,9 @@
34 34 (ir2-convert-fixed-allocation node block name words header
35 35 lowtag inits)))))
36 36 name)
  37 +
  38 +(defun %def-casser (name offset lowtag)
  39 + (let ((fun-info (fun-info-or-lose name)))
  40 + (setf (fun-info-ir2-convert fun-info)
  41 + (lambda (node block)
  42 + (ir2-convert-casser node block name offset lowtag)))))
7 src/compiler/generic/objdef.lisp
@@ -40,8 +40,10 @@
40 40
41 41 (define-primitive-object (cons :lowtag list-pointer-lowtag
42 42 :alloc-trans cons)
43   - (car :ref-trans car :set-trans sb!c::%rplaca :init :arg)
44   - (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg))
  43 + (car :ref-trans car :set-trans sb!c::%rplaca :init :arg
  44 + :cas-trans %compare-and-swap-car)
  45 + (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg
  46 + :cas-trans %compare-and-swap-cdr))
45 47
46 48 (define-primitive-object (instance :lowtag instance-pointer-lowtag
47 49 :widetag instance-header-widetag
@@ -321,6 +323,7 @@
321 323
322 324 (plist :ref-trans symbol-plist
323 325 :set-trans %set-symbol-plist
  326 + :cas-trans %compare-and-swap-symbol-plist
324 327 :init :null)
325 328 (name :ref-trans symbol-name :init :arg)
326 329 (package :ref-trans symbol-package
14 src/compiler/generic/vm-ir2tran.lisp
@@ -32,6 +32,20 @@
32 32 name offset lowtag)
33 33 (move-lvar-result node block (list value-tn) (node-lvar node))))
34 34
  35 +#!+compare-and-swap-vops
  36 +(defoptimizer ir2-convert-casser
  37 + ((object old new) node block name offset lowtag)
  38 + (let* ((lvar (node-lvar node))
  39 + (locs (lvar-result-tns lvar (list *backend-t-primitive-type*)))
  40 + (res (first locs)))
  41 + (vop compare-and-swap-slot node block
  42 + (lvar-tn node block object)
  43 + (lvar-tn node block old)
  44 + (lvar-tn node block new)
  45 + name offset lowtag
  46 + res)
  47 + (move-lvar-result node block locs lvar)))
  48 +
35 49 (defun emit-inits (node block name result lowtag inits args)
36 50 (let ((unbound-marker-tn nil)
37 51 (funcallable-instance-tramp-tn nil))
13 src/compiler/generic/vm-macs.lisp
@@ -76,6 +76,7 @@
76 76 ((:type slot-type) t) init
77 77 (ref-known nil ref-known-p) ref-trans
78 78 (set-known nil set-known-p) set-trans
  79 + cas-trans
79 80 &allow-other-keys)
80 81 (if (atom spec) (list spec) spec)
81 82 (slots (make-slot slot-name docs rest-p offset
@@ -99,6 +100,15 @@
99 100 ,slot-type
100 101 ,set-known)))
101 102 (forms `(def-setter ,set-trans ,offset ,lowtag)))
  103 + (when cas-trans
  104 + (when rest-p
  105 + (error ":REST-P and :CAS-TRANS incompatible."))
  106 + (forms
  107 + `(progn
  108 + (defknown ,cas-trans (,type ,slot-type ,slot-type)
  109 + ,slot-type (unsafe))
  110 + #!+compare-and-swap-vops
  111 + (def-casser ,cas-trans ,offset ,lowtag))))
102 112 (when init
103 113 (inits (cons init offset)))
104 114 (when rest-p
@@ -133,6 +143,9 @@
133 143 `(%def-setter ',name ,offset ,lowtag))
134 144 (defmacro def-alloc (name words variable-length-p header lowtag inits)
135 145 `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
  146 +#!+compare-and-swap-vops
  147 +(defmacro def-casser (name offset lowtag)
  148 + `(%def-casser ',name ,offset ,lowtag))
136 149 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
137 150 ;;; are defined later in another file, since they use structure slot
138 151 ;;; setters defined later, and we can't have physical forward
6 src/compiler/globaldb.lisp
@@ -1050,6 +1050,12 @@
1050 1050 :type :definition
1051 1051 :type-spec (or fdefn null)
1052 1052 :default nil)
  1053 +
  1054 +(define-info-type
  1055 + :class :function
  1056 + :type :structure-accessor
  1057 + :type-spec (or defstruct-description null)
  1058 + :default nil)
1053 1059
1054 1060 ;;;; definitions for other miscellaneous information
1055 1061
1  src/compiler/info-functions.lisp
@@ -97,6 +97,7 @@
97 97 (frob :kind)
98 98 (frob :inline-expansion-designator)
99 99 (frob :source-transform)
  100 + (frob :structure-accessor)
100 101 (frob :assumed-type)))
101 102 (values))
102 103
8 src/compiler/x86-64/array.lisp
@@ -157,10 +157,10 @@
157 157 (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
158 158 unsigned-reg))
159 159
160   -(define-full-compare-and-swap simple-vector-compare-and-swap
161   - simple-vector vector-data-offset other-pointer-lowtag
162   - (descriptor-reg any-reg) *
163   - %simple-vector-compare-and-swap)
  160 +(define-full-compare-and-swap %compare-and-swap-svref simple-vector
  161 + vector-data-offset other-pointer-lowtag
  162 + (descriptor-reg any-reg) *
  163 + %compare-and-swap-svref)
164 164
165 165 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
166 166 ;;;; bit, 2-bit, and 4-bit vectors
67 src/compiler/x86-64/cell.lisp
@@ -46,11 +46,67 @@
46 46 temp))
47 47 ;; Else, value not immediate.
48 48 (storew value object offset lowtag))))
49   -
50   -
51 49
  50 +(define-vop (compare-and-swap-slot)
  51 + (:args (object :scs (descriptor-reg) :to :eval)
  52 + (old :scs (descriptor-reg any-reg) :target rax)
  53 + (new :scs (descriptor-reg any-reg)))
  54 + (:temporary (:sc descriptor-reg :offset rax-offset
  55 + :from (:argument 1) :to :result :target result)
  56 + rax)
  57 + (:info name offset lowtag)
  58 + (:ignore name)
  59 + (:results (result :scs (descriptor-reg any-reg)))
  60 + (:generator 5
  61 + (move rax old)
  62 + #!+sb-thread
  63 + (inst lock)
  64 + (inst cmpxchg (make-ea :qword :base object
  65 + :disp (- (* offset n-word-bytes) lowtag))
  66 + new)
  67 + (move result rax)))
  68 +
52 69 ;;;; symbol hacking VOPs
53 70
  71 +(define-vop (%compare-and-swap-symbol-value)
  72 + (:translate %compare-and-swap-symbol-value)
  73 + (:args (symbol :scs (descriptor-reg) :to (:result 1))
  74 + (old :scs (descriptor-reg any-reg) :target rax)
  75 + (new :scs (descriptor-reg any-reg)))
  76 + (:temporary (:sc descriptor-reg :offset rax-offset) rax)
  77 + #!+sb-thread
  78 + (:temporary (:sc descriptor-reg) tls)
  79 + (:results (result :scs (descriptor-reg any-reg)))
  80 + (:policy :fast-safe)
  81 + (:vop-var vop)
  82 + (:generator 15
  83 + ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
  84 + ;; or UNBOUND-MARKER as NEW: in either case we would end up
  85 + ;; doing possible damage with CMPXCHG -- so don't do that!
  86 + (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
  87 + (check (gen-label)))
  88 + (move rax old)
  89 + #!+sb-thread
  90 + (progn
  91 + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
  92 + ;; Thread-local area, not LOCK needed.
  93 + (inst cmpxchg (make-ea :qword :base thread-base-tn
  94 + :index tls :scale 1)
  95 + new)
  96 + (inst cmp rax no-tls-value-marker-widetag)
  97 + (inst jmp :ne check)
  98 + (move rax old)
  99 + (inst lock))
  100 + (inst cmpxchg (make-ea :qword :base symbol
  101 + :disp (- (* symbol-value-slot n-word-bytes)
  102 + other-pointer-lowtag)
  103 + :scale 1)
  104 + new)
  105 + (emit-label check)
  106 + (move result rax)
  107 + (inst cmp result unbound-marker-widetag)
  108 + (inst jmp :e unbound))))
  109 +
54 110 ;;; these next two cf the sparc version, by jrd.
55 111 ;;; FIXME: Deref this ^ reference.
56 112
@@ -463,9 +519,10 @@
463 519 (define-full-setter instance-index-set * instance-slots-offset
464 520 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
465 521
466   -(define-full-compare-and-swap instance-compare-and-swap instance
467   - instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg)
468   - * %instance-compare-and-swap)
  522 +(define-full-compare-and-swap %compare-and-swap-instance-ref instance
  523 + instance-slots-offset instance-pointer-lowtag
  524 + (any-reg descriptor-reg) *
  525 + %compare-and-swap-instance-ref)
469 526
470 527 ;;;; code object frobbing
471 528
8 src/compiler/x86/array.lisp
@@ -150,10 +150,10 @@
150 150 #!+sb-unicode
151 151 (def-full-data-vector-frobs simple-character-string character character-reg))
152 152
153   -(define-full-compare-and-swap simple-vector-compare-and-swap
154   - simple-vector vector-data-offset other-pointer-lowtag
155   - (descriptor-reg any-reg) *
156   - %simple-vector-compare-and-swap)
  153 +(define-full-compare-and-swap %compare-and-swap-svref simple-vector
  154 + vector-data-offset other-pointer-lowtag
  155 + (descriptor-reg any-reg) *
  156 + %compare-and-swap-svref)
157 157
158 158 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
159 159 ;;;; bit, 2-bit, and 4-bit vectors
62 src/compiler/x86/cell.lisp
@@ -29,11 +29,65 @@
29 29 (:results)
30 30 (:generator 1
31 31 (storew (encode-value-if-immediate value) object offset lowtag)))
32   -
33   -
34 32
  33 +(define-vop (compare-and-swap-slot)
  34 + (:args (object :scs (descriptor-reg) :to :eval)
  35 + (old :scs (descriptor-reg any-reg) :target eax)
  36 + (new :scs (descriptor-reg any-reg)))
  37 + (:temporary (:sc descriptor-reg :offset eax-offset
  38 + :from (:argument 1) :to :result :target result)
  39 + eax)
  40 + (:info name offset lowtag)
  41 + (:ignore name)
  42 + (:results (result :scs (descriptor-reg any-reg)))
  43 + (:generator 5
  44 + (move eax old)
  45 + #!+sb-thread
  46 + (inst lock)
  47 + (inst cmpxchg (make-ea :dword :base object
  48 + :disp (- (* offset n-word-bytes) lowtag))
  49 + new)
  50 + (move result eax)))
  51 +
35 52 ;;;; symbol hacking VOPs
36 53
  54 +(define-vop (%compare-and-swap-symbol-value)
  55 + (:translate %compare-and-swap-symbol-value)
  56 + (:args (symbol :scs (descriptor-reg) :to (:result 1))
  57 + (old :scs (descriptor-reg any-reg) :target eax)
  58 + (new :scs (descriptor-reg any-reg)))
  59 + (:temporary (:sc descriptor-reg :offset eax-offset) eax)
  60 + #!+sb-thread
  61 + (:temporary (:sc descriptor-reg) tls)
  62 + (:results (result :scs (descriptor-reg any-reg)))
  63 + (:policy :fast-safe)
  64 + (:vop-var vop)
  65 + (:generator 15
  66 + ;; This code has to pathological cases: NO-TLS-VALUE-MARKER
  67 + ;; or UNBOUND-MARKER as NEW: in either case we would end up
  68 + ;; doing possible damage with CMPXCHG -- so don't do that!
  69 + (let ((unbound (generate-error-code vop unbound-symbol-error symbol))
  70 + (check (gen-label)))
  71 + (move eax old)
  72 + #!+sb-thread
  73 + (progn
  74 + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
  75 + ;; Thread-local area, not LOCK needed.
  76 + (inst fs-segment-prefix)
  77 + (inst cmpxchg (make-ea :dword :base tls) new)
  78 + (inst cmp eax no-tls-value-marker-widetag)
  79 + (inst jmp :ne check)
  80 + (move eax old)
  81 + (inst lock))
  82 + (inst cmpxchg (make-ea :dword :base symbol
  83 + :disp (- (* symbol-value-slot n-word-bytes)
  84 + other-pointer-lowtag))
  85 + new)
  86 + (emit-label check)
  87 + (move result eax)
  88 + (inst cmp result unbound-marker-widetag)
  89 + (inst jmp :e unbound))))
  90 +
37 91 ;;; these next two cf the sparc version, by jrd.
38 92 ;;; FIXME: Deref this ^ reference.
39 93
@@ -446,10 +500,10 @@
446 500 (any-reg descriptor-reg) *
447 501 %instance-set)
448 502
449   -(define-full-compare-and-swap instance-compare-and-swap instance
  503 +(define-full-compare-and-swap %compare-and-swap-instance-ref instance
450 504 instance-slots-offset instance-pointer-lowtag
451 505 (any-reg descriptor-reg) *
452   - %instance-compare-and-swap)
  506 + %compare-and-swap-instance-ref)
453 507
454 508 ;;;; code object frobbing
455 509
16 src/pcl/cache.lisp
@@ -149,22 +149,6 @@
149 149 (defun cache-key-p (thing)
150 150 (not (symbolp thing)))
151 151
152   -(eval-when (:compile-toplevel :load-toplevel :execute)
153   - (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
154   - :structure cache
155   - :slot depth))
156   -
157   -;;; Utility macro for atomic updates without locking... doesn't
158   -;;; do much right now, and it would be nice to make this more magical.
159   -(defmacro compare-and-swap (place old new)
160   - (unless (consp place)
161   - (error "Don't know how to compare and swap ~S." place))
162   - (ecase (car place)
163   - (svref
164   - `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
165   - (cache-depth
166   - `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
167   -
168 152 ;;; Atomically update the current probe depth of a cache.
169 153 (defun note-cache-depth (cache depth)
170 154 (loop for old = (cache-depth cache)
22 tests/array.pure.lisp
@@ -221,25 +221,3 @@
221 221 (type-error ()
222 222 :good))))
223 223
224   -;;; SIMPLE-VECTOR-COMPARE-AND-SWAP
225   -
226   -(let ((v (vector 1)))
227   - ;; basics
228   - (assert (eql 1 (sb-kernel:simple-vector-compare-and-swap v 0 1 2)))
229   - (assert (eql 2 (sb-kernel:simple-vector-compare-and-swap v 0 1 3)))
230   - (assert (eql 2 (svref v 0)))
231   - ;; bounds
232   - (multiple-value-bind (res err)
233   - (ignore-errors (sb-kernel:simple-vector-compare-and-swap v -1 1 2))
234   - (assert (not res))
235   - (assert (typep err 'type-error)))
236   - (multiple-value-bind (res err)
237   - (ignore-errors (sb-kernel:simple-vector-compare-and-swap v 1 1 2))
238   - (assert (not res))
239   - (assert (typep err 'type-error))))
240   -
241   -;; type of the first argument
242   -(multiple-value-bind (res err)
243   - (ignore-errors (sb-kernel:simple-vector-compare-and-swap "foo" 1 1 2))
244   - (assert (not res))
245   - (assert (typep err 'type-error)))
77 tests/compare-and-swap.impure.lisp
... ... @@ -0,0 +1,77 @@
  1 +;;; Basics
  2 +
  3 +(defstruct xxx yyy)
  4 +
  5 +(macrolet ((test (init op)
  6 + `(let ((x ,init)
  7 + (y (list 'foo))
  8 + (z (list 'bar)))
  9 + (assert (eql nil (compare-and-swap (,op x) nil y)))
  10 + (assert (eql y (compare-and-swap (,op x) nil z)))
  11 + (assert (eql y (,op x)))
  12 + (let ((x "foo"))
  13 + (multiple-value-bind (res err)
  14 + (ignore-errors (compare-and-swap (,op x) nil nil))
  15 + (assert (not res))
  16 + (assert (typep err 'type-error)))))))
  17 + (test (cons nil :no) car)
  18 + (test (cons nil :no) first)
  19 + (test (cons :no nil) cdr)
  20 + (test (cons :no nil) rest)
  21 + (test '.foo. symbol-plist)
  22 + (test (progn (set '.bar. nil) '.bar.) symbol-value)
  23 + (test (make-xxx) xxx-yyy))
  24 +
  25 +(defvar *foo*)
  26 +
  27 +;;; thread-local bindings
  28 +
  29 +(let ((*foo* 42))
  30 + (let ((*foo* nil))
  31 + (assert (eql nil (compare-and-swap (symbol-value '*foo*) nil t)))
  32 + (assert (eql t (compare-and-swap (symbol-value '*foo*) nil :foo)))
  33 + (assert (eql t *foo*)))
  34 + (assert (eql 42 *foo*)))
  35 +
  36 +;;; unbound symbols + symbol-value
  37 +
  38 +(assert (not (boundp '*foo*)))
  39 +
  40 +(multiple-value-bind (res err)
  41 + (ignore-errors (compare-and-swap (symbol-value '*foo*) nil t))
  42 + (assert (not res))
  43 + (assert (typep err 'unbound-variable)))
  44 +
  45 +(defvar *bar* t)
  46 +
  47 +(let ((*bar* nil))
  48 + (makunbound '*bar*)
  49 + (multiple-value-bind (res err)
  50 + (ignore-errors (compare-and-swap (symbol-value '*bar*) nil t))
  51 + (assert (not res))
  52 + (assert (typep err 'unbound-variable))))
  53 +
  54 +;;; SVREF
  55 +
  56 +(defvar *v* (vector 1))
  57 +
  58 +;; basics
  59 +(assert (eql 1 (compare-and-swap (svref *v* 0) 1 2)))
  60 +(assert (eql 2 (compare-and-swap (svref *v* 0) 1 3)))
  61 +(assert (eql 2 (svref *v* 0)))
  62 +
  63 +;; bounds
  64 +(multiple-value-bind (res err)
  65 + (ignore-errors (compare-and-swap (svref *v* -1) 1 2))
  66 + (assert (not res))
  67 + (assert (typep err 'type-error)))
  68 +(multiple-value-bind (res err)
  69 + (ignore-errors (compare-and-swap (svref *v* 1) 1 2))
  70 + (assert (not res))
  71 + (assert (typep err 'type-error)))
  72 +
  73 +;; type of the first argument
  74 +(multiple-value-bind (res err)
  75 + (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
  76 + (assert (not res))
  77 + (assert (typep err 'type-error)))
2  version.lisp-expr
@@ -17,4 +17,4 @@
17 17 ;;; checkins which aren't released. (And occasionally for internal
18 18 ;;; versions, especially for internal versions off the main CVS
19 19 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
20   -"1.0.7.18"
  20 +"1.0.7.19"

0 comments on commit bfb19d3

Please sign in to comment.
Something went wrong with that request. Please try again.