From 6b0e40584d83dfc32e028b5835d973bdbd61e182 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Mon, 7 Nov 2011 14:18:38 -0500
Subject: [PATCH] Correct address computation in atomic-incf/aref for wide
 fixnums

 Reported by Martin Cracauer.

 Fixes lp#887220.
---
 NEWS                           |    4 ++++
 src/compiler/x86-64/array.lisp |    3 ++-
 tests/compiler.pure.lisp       |   16 ++++++++++++++++
 3 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index 99ca95c..f79f635 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.53:
+  * bug fix: on 64-bit targets, atomic-incf/aref does index computation
+    correctly, even on wide-fixnum builds. (lp#887220)
+
 changes in sbcl-1.0.53 relative to sbcl-1.0.52:
   * enhancement: on 64-bit targets, in src/compiler/generic/early-vm.lisp,
     the parameter n-fixnum-tag-bits may now vary from 1 (fixnum =
diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp
index 26fd1a9..28060d9 100644
--- a/src/compiler/x86-64/array.lisp
+++ b/src/compiler/x86-64/array.lisp
@@ -764,7 +764,8 @@
   (:result-types unsigned-num)
   (:generator 4
     (inst xadd (make-ea :qword :base array
-                        :scale 1 :index index
+                        :scale (ash 1 (- word-shift n-fixnum-tag-bits))
+                        :index index
                         :disp (- (* vector-data-offset n-word-bytes)
                                  other-pointer-lowtag))
           diff :lock)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 73cc33d..1712620 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4028,3 +4028,19 @@
   (compile nil `(lambda (x)
                   (declare (type character x))
                   (eql x #\U0010FFFF))))
+
+;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
+(with-test (:name :bug-887220)
+  (let ((incfer (compile
+                 nil
+                 `(lambda (vector index)
+                    (declare (type (simple-array sb-ext:word (4))
+                                   vector)
+                             (type (mod 4) index))
+                    (sb-ext:atomic-incf (aref vector index) 1)
+                    vector))))
+    (assert (equalp (funcall incfer
+                             (make-array 4 :element-type 'sb-ext:word
+                                           :initial-element 0)
+                             1)
+                    #(0 1 0 0)))))
-- 
1.7.10.4