From 040344ca23aefec86459f79f21af8088fc52e93f Mon Sep 17 00:00:00 2001
From: David Lichteblau <david@lichteblau.com>
Date: Thu, 7 Jun 2012 20:08:34 +0200
Subject: [PATCH] Fix inline fixnum LDB on PowerPC for certain bytespecs

Previously, the inline fixnum version of (ldb (byte 8 24) -1) would
return #x3f instead of #ff.
---
 src/compiler/ppc/arith.lisp |   20 ++++++++++++++++----
 tests/arith.impure.lisp     |   26 ++++++++++++++++++++++++++
 2 files changed, 42 insertions(+), 4 deletions(-)

diff --git a/src/compiler/ppc/arith.lisp b/src/compiler/ppc/arith.lisp
index 6e90c89..5f4bfe1 100644
--- a/src/compiler/ppc/arith.lisp
+++ b/src/compiler/ppc/arith.lisp
@@ -679,10 +679,22 @@
   (:result-types tagged-num)
   (:policy :fast-safe)
   (:generator 2
-    (inst rlwinm res x
-          (mod (- 32 posn) 32)          ; effectively rotate right
-          (- 32 size n-fixnum-tag-bits)
-          (- 31 n-fixnum-tag-bits))))
+    (let ((phantom-bits (- (+ size posn) 30)))
+      (cond
+        ((plusp phantom-bits)
+         ;; The byte to be loaded into RES includes sign bits which are not
+         ;; present in the input X physically.  RLWINM as used below would
+         ;; mask these out with 0 even for negative inputs.
+         (inst srawi res x phantom-bits)
+         (inst rlwinm res x
+               (mod (- 32 posn (- phantom-bits)) 32)
+               (- 32 size n-fixnum-tag-bits)
+               (- 31 n-fixnum-tag-bits)))
+        (t
+         (inst rlwinm res x
+               (mod (- 32 posn) 32)     ; effectively rotate right
+               (- 32 size n-fixnum-tag-bits)
+               (- 31 n-fixnum-tag-bits)))))))
 
 (define-vop (ldb-c/signed)
   (:translate %%ldb)
diff --git a/tests/arith.impure.lisp b/tests/arith.impure.lisp
index 00479d4..71b5734 100644
--- a/tests/arith.impure.lisp
+++ b/tests/arith.impure.lisp
@@ -152,3 +152,29 @@
 (assert (= (64-bit-logcount (1- (ash 1 48))) 48))
 (assert (= (64-bit-logcount (1- (ash 1 54))) 54))
 
+(declaim (inline ppc-ldb-2))
+
+(defun ppc-ldb-2 (fun value)
+  (declare (type stream socket)
+           (type (signed-byte 32) value)
+           (optimize (speed 3) (safety 0) (space 1) (debug 1)
+                     (compilation-speed 0)))
+  (funcall fun (ldb (byte 8 24) value))
+  (funcall fun (ldb (byte 8 16) value))
+  (funcall fun (ldb (byte 8 8) value))
+  (funcall fun (ldb (byte 8 0) value))
+  (values))
+
+(defun ppc-ldb-1 (fun)
+  (declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
+                     (compilation-speed 0)))
+  (loop
+     for param :across (make-array 1 :initial-element nil)
+     for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
+     do (ppc-ldb-2 fun (if param size -1))))
+
+(let ((acc '()))
+  (ppc-ldb-1 (lambda (x)
+         (push x acc)))
+  (assert (equal acc '(#xff #xff #xff #xff))))
+
-- 
1.7.10.4