From db9c81e7b9a67ebd26b87bf2c1686d1b4968f097 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 17 Sep 2008 20:24:21 +0000
Subject: [PATCH] 1.0.20.7: COMPARE-AND-SWAP on SYMBOL-VALUE to respect
 constants and declaimed types

 * For constant symbol names which are declaimed SPECIAL, insert the
   appropriate THE around the new value.

 * For other cases use ABOUT-TO-MODIFY-SYMBOL-VALUE.

 * Tests.
---
 NEWS                               |    6 ++++--
 src/code/late-extensions.lisp      |   23 ++++++++++++++++++++---
 tests/compare-and-swap.impure.lisp |   29 +++++++++++++++++++++++++++++
 version.lisp-expr                  |    2 +-
 4 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/NEWS b/NEWS
index 449af42..6b585e8 100644
--- a/NEWS
+++ b/NEWS
@@ -1,6 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
-  * reduced conservativism on GENCGC platforms: on average 45% less
-    pages pinned (measured from SBCL self build).
+  * enhancement: reduced conservativism on GENCGC platforms: on
+    average 45% less pages pinned (measured from SBCL self build).
+  * bug fix: SB-EXT:COMPARE-AND-SWAP on SYMBOL-VALUE can no longer
+    mutate constant symbols or violate declaimed type of the symbol.
 
 changes in sbcl-1.0.20 relative to 1.0.19:
   * minor incompatible change: OPTIMIZE qualities
diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index e6b24a3..5b0fbaa 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -66,7 +66,7 @@
              (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
                 sb!vm:instance-pointer-lowtag)))))))
 
-(defmacro compare-and-swap (place old new)
+(defmacro compare-and-swap (place old new &environment env)
   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
 Two values are considered to match if they are EQ. Returns the previous value
 of PLACE: if the returned value if EQ to OLD, the swap was carried out.
@@ -92,9 +92,26 @@ EXPERIMENTAL: Interface subject to change."
       ((cdr rest)
        `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
       (symbol-plist
-       `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old ,new))
+       `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
       (symbol-value
-       `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
+       (destructuring-bind (name) args
+         (flet ((slow (symbol)
+                  (with-unique-names (n-symbol n-old n-new)
+                    `(let ((,n-symbol ,symbol)
+                           (,n-old ,old)
+                           (,n-new ,new))
+                       (declare (symbol ,n-symbol))
+                       (about-to-modify-symbol-value ,n-symbol "compare-and-swap SYMBOL-VALUE of ~S" ,n-new)
+                       (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
+           (if (sb!xc:constantp name env)
+               (let ((cname (constant-form-value name env)))
+                 (if (eq :special (info :variable :kind cname))
+                     ;; Since we know the symbol is a special, we can just generate
+                     ;; the type check.
+                     `(%compare-and-swap-symbol-value
+                       ',cname ,old (the ,(info :variable :type cname) ,new))
+                     (slow (list 'quote cname))))
+               (slow name)))))
       (svref
        (let ((vector (car args))
              (index (cadr args)))
diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp
index 6366043..8a034ad 100644
--- a/tests/compare-and-swap.impure.lisp
+++ b/tests/compare-and-swap.impure.lisp
@@ -75,3 +75,32 @@
     (ignore-errors (compare-and-swap (svref "foo" 1) 1 2))
     (assert (not res))
     (assert (typep err 'type-error)))
+
+;; Check that we don't modify constants
+(defconstant +a-constant+ 42)
+(assert
+ (eq :error
+     (handler-case
+         (sb-ext:compare-and-swap (symbol-value '+a-constant+) 42 13)
+       (error () :error))))
+(let ((name '+a-constant+))
+  (assert
+   (eq :error
+       (handler-case
+           (sb-ext:compare-and-swap (symbol-value name) 42 13)
+         (error () :error)))))
+
+;; Check that we don't mess declaimed types
+(declaim (boolean *a-boolean*))
+(defparameter *a-boolean* t)
+(assert
+ (eq :error
+     (handler-case
+         (sb-ext:compare-and-swap (symbol-value '*a-boolean*) t 42)
+       (error () :error))))
+(let ((name '*a-boolean*))
+  (assert
+   (eq :error
+       (handler-case
+           (sb-ext:compare-and-swap (symbol-value name) t 42)
+         (error () :error)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index de3b135..7324dbc 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.20.6"
+"1.0.20.7"
-- 
1.7.10.4