Merge pull request #90 from konsumlamm/BitsInteger

Implement `Bits Integer` instance

lib/Data/Bits.hs

@@ -93,6 +93,18 @@ class Bits b => FiniteBits b where
 
       w = finiteBitSize x
 
+bitDefault :: (Bits a, Num a) => Int -> a
+bitDefault i = 1 `shiftL` i
+
+testBitDefault :: (Bits a, Num a) => a -> Int -> Bool
+testBitDefault x i = (x .&. bit i) /= 0
+
+popCountDefault :: (Bits a, Num a) => a -> Int
+popCountDefault = go 0
+  where
+    go c 0 = c
+    go c w = go (c + 1) (w .&. (w - 1)) -- clear the least significant bit
+
 _overflowError :: a
 _overflowError = error "arithmetic overflow"
 
@@ -113,7 +125,9 @@ instance Bits Int where
   unsafeShiftR = primIntShr
   bitSizeMaybe _ = Just _wordSize
   bitSize _ = _wordSize
-  bit n = primIntShl 1 n
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Int where

lib/Data/Int/Instances.hs

@@ -106,7 +106,9 @@ instance Bits Int8 where
   unsafeShiftR = bini8 primIntShr
   bitSizeMaybe _ = Just 8
   bitSize _ = 8
-  bit n = i8 (primIntShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Int8 where
@@ -198,7 +200,9 @@ instance Bits Int16 where
   unsafeShiftR = bini16 primIntShr
   bitSizeMaybe _ = Just 16
   bitSize _ = 16
-  bit n = i16 (primIntShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Int16 where
@@ -290,7 +294,9 @@ instance Bits Int32 where
   unsafeShiftR = bini32 primIntShr
   bitSizeMaybe _ = Just 32
   bitSize _ = 32
-  bit n = i32 (primIntShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Int32 where
@@ -381,7 +387,9 @@ instance Bits Int64 where
   unsafeShiftR = bini64 primIntShr
   bitSizeMaybe _ = Just 64
   bitSize _ = 64
-  bit n = i64 (primIntShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Int64 where

lib/Data/Integer.hs

@@ -14,6 +14,7 @@ module Data.Integer(
 import Prelude()              -- do not import Prelude
 import Primitives
 import Control.Error
+import Data.Bits
 import Data.Bool
 import Data.Char
 import Data.Enum
@@ -99,6 +100,47 @@ instance Enum Integer where
   enumFromTo = numericEnumFromTo
   enumFromThenTo = numericEnumFromThenTo
 
+instance Bits Integer where
+  (.&.) = andI
+  (.|.) = orI
+  xor = xorI
+  complement x = negOneI - x -- -x = complement x + 1 => complement x = -1 - x
+  I sign ds `unsafeShiftL` i
+    | null ds = zeroI
+    | otherwise =
+      let (q, r) = quotRem i shiftD
+      in I sign (replicate q 0 ++ shiftLD ds r)
+  x `shiftL` i
+    | i < 0 = _overflowError
+    | otherwise = x `unsafeShiftL` i
+  I sign ds `unsafeShiftR` i
+    | null ds = zeroI
+    | otherwise =
+      let
+        (q, r) = quotRem i shiftD
+        (rs, ds') = splitAt q ds
+        (ds'', shiftedOut1s) = shiftRD ds' r
+      in case sign of
+        Minus | shiftedOut1s || any (/= 0) rs -> I sign (add1 ds'')
+        _ -> I sign ds''
+  x `shiftR` i
+    | i < 0 = _overflowError
+    | otherwise = x `unsafeShiftR` i
+  x `shift` i
+    | i < 0 = x `unsafeShiftR` (-i)
+    | i > 0 = x `unsafeShiftL` i
+    | otherwise = x
+  rotate = shift
+  bit i = oneI `shiftL` i
+  testBit = testBitI
+  zeroBits = zeroI
+  bitSizeMaybe _ = Nothing
+  popCount (I sign ds) =
+    let count = sum (map popCount ds)
+    in case sign of
+      Plus -> count
+      Minus -> -count
+
 ------------------------------------------------
 
 isZero :: Integer -> Bool
@@ -242,7 +284,7 @@ quotRemD axs y = qr zeroD (reverse axs) []
     qr ci []     res = (res, [ci])
     qr ci (x:xs) res = qr r xs (q:res)
       where
-        cx = ci * maxD + x
+        cx = ci `unsafeShiftL` shiftD + x
         q = quot cx y
         r = rem cx y
 
@@ -329,6 +371,91 @@ _intListToInteger :: [Int] -> Integer
 _intListToInteger ads@(x : ds) = if x == -1 then - f ds else f ads
   where f = foldr (\ d a -> a * integerListBase + toInteger d) 0
 
+---------------------------------
+
+andI :: Integer -> Integer -> Integer
+andI (I Plus  xs) (I Plus  ys) = bI Plus  (andDigits xs ys)
+andI (I Plus  xs) (I Minus ys) = bI Plus  (andNotDigits (sub1 ys) xs)
+andI (I Minus xs) (I Plus  ys) = bI Plus  (andNotDigits (sub1 xs) ys)
+andI (I Minus xs) (I Minus ys) = bI Minus (orDigits (sub1 xs) (sub1 ys))
+
+orI :: Integer -> Integer -> Integer
+orI (I Plus  xs) (I Plus  ys) = bI Plus  (orDigits xs ys)
+orI (I Plus  xs) (I Minus ys) = bI Minus (andNotDigits xs (sub1 ys))
+orI (I Minus xs) (I Plus  ys) = bI Minus (andNotDigits ys (sub1 xs))
+orI (I Minus xs) (I Minus ys) = bI Minus (andDigits (sub1 xs) (sub1 ys))
+
+xorI :: Integer -> Integer -> Integer
+xorI (I Plus  xs) (I Plus  ys) = bI Plus  (xorDigits xs ys)
+xorI (I Plus  xs) (I Minus ys) = bI Minus (xorDigits xs (sub1 ys))
+xorI (I Minus xs) (I Plus  ys) = bI Minus (xorDigits (sub1 xs) ys)
+xorI (I Minus xs) (I Minus ys) = bI Plus  (xorDigits (sub1 xs) (sub1 ys))
+
+bI :: Sign -> [Digit] -> Integer
+bI Plus  ds = sI Plus  ds
+bI Minus ds = sI Minus (add1 ds)
+
+add1 :: [Digit] -> [Digit]
+add1 ds = add ds [1]
+
+sub1 :: [Digit] -> [Digit]
+sub1 ds = sub ds [1]
+
+andDigits :: [Digit] -> [Digit] -> [Digit]
+andDigits (x : xs) (y : ys) = (x .&. y) : andDigits xs ys
+andDigits _        _        = []
+
+andNotDigits :: [Digit] -> [Digit] -> [Digit]
+andNotDigits []       []       = []
+andNotDigits []       ys       = ys
+andNotDigits xs       []       = []
+andNotDigits (x : xs) (y : ys) = (complement x .&. y) : andNotDigits xs ys
+
+orDigits :: [Digit] -> [Digit] -> [Digit]
+orDigits []       []       = []
+orDigits []       ys       = ys
+orDigits xs       []       = xs
+orDigits (x : xs) (y : ys) = (x .|. y) : orDigits xs ys
+
+xorDigits :: [Digit] -> [Digit] -> [Digit]
+xorDigits []       []       = []
+xorDigits []       ys       = ys
+xorDigits xs       []       = xs
+xorDigits (x : xs) (y : ys) = (x `xor` y) : xorDigits xs ys
+
+shiftLD :: [Digit] -> Int -> [Digit]
+shiftLD ds 0 = ds
+shiftLD ds i = go 0 ds
+  where
+    go ci [] = if ci == 0 then [] else [ci]
+    go ci (d : ds) =
+      let
+        x = (d `unsafeShiftL` i) .|. ci
+        co = quotMaxD x
+        s = remMaxD x
+      in s : go co ds
+
+shiftRD :: [Digit] -> Int -> ([Digit], Bool)
+shiftRD ds 0 = (ds, False)
+shiftRD ds i =
+  let (rs, ds') = splitAt 1 (shiftLD ds (shiftD - i))
+  in (ds', any (/= 0) rs)
+
+testBitI :: Integer -> Int -> Bool
+testBitI (I Plus  ds) i =
+  case ds !? q of
+    Just d -> testBit d r
+    Nothing -> False
+  where (q, r) = quotRem i shiftD
+testBitI (I Minus ds) i =
+  -- not (testBitI (complement (I Minus ds)) i)
+  case ds !? q of
+    Just d ->
+      let d' = if all (== 0) (take q ds) then d - 1 else d
+      in not (testBit d' r)
+    Nothing -> True
+  where (q, r) = quotRem i shiftD
+
 ---------------------------------
 {-
 pIntegerToInteger :: P.Integer -> Integer

lib/Data/Integer_Type.hs

@@ -14,19 +14,22 @@ data Sign = Plus | Minus
 type Digit = Word
 
 maxD :: Digit
-maxD =
+maxD = 1 `primWordShl` shiftD
+
+shiftD :: Int
+shiftD =
   if _wordSize `primIntEQ` 64 then
-    (4294967296 :: Word) -- 2^32, this is used so multiplication of two digits doesn't overflow a 64 bit Word
+    (32 :: Int) -- this is used so multiplication of two digits doesn't overflow a 64 bit Word
   else if _wordSize `primIntEQ` 32 then
-    (65536 :: Word)      -- 2^16, this is used so multiplication of two digits doesn't overflow a 32 bit Word
+    (16 :: Int) -- this is used so multiplication of two digits doesn't overflow a 32 bit Word
   else
     error "Integer: unsupported word size"
 
 quotMaxD :: Digit -> Digit
-quotMaxD d = d `primWordQuot` maxD
+quotMaxD d = d `primWordShr` shiftD
 
 remMaxD :: Digit -> Digit
-remMaxD d = d `primWordRem` maxD
+remMaxD d = d `primWordAnd` (maxD `primWordSub` 1)
 
 -- Sadly, we also need a bunch of functions.
 
@@ -38,8 +41,8 @@ _intToInteger i
   where
     f sign i =
       let
-        high = i `primWordQuot` maxD
-        low = i `primWordRem` maxD
+        high = quotMaxD i
+        low = remMaxD i
       in if high `primWordEQ` 0 then I sign [low] else I sign [low, high]
 
 _integerToInt :: Integer -> Int
@@ -51,8 +54,8 @@ _wordToInteger i
   | high `primWordEQ` 0 = I Plus [low]
   | True                = I Plus [low, high]
   where
-    high = i `primWordQuot` maxD
-    low = i `primWordRem` maxD
+    high = quotMaxD i
+    low = remMaxD i
 
 _integerToWord :: Integer -> Word
 _integerToWord (I sign ds) =
@@ -64,7 +67,7 @@ _integerToWord (I sign ds) =
       case ds of
         []          -> 0 :: Word
         [d1]        -> d1
-        d1 : d2 : _ -> d1 `primWordAdd` (maxD `primWordMul` d2)
+        d1 : d2 : _ -> d1 `primWordAdd` (d2 `primWordShl` shiftD)
 
 _integerToFloatW :: Integer -> FloatW
 _integerToFloatW (I sign ds) = s `primFloatWMul` loop ds

lib/Data/Word.hs

@@ -95,7 +95,9 @@ instance Bits Word where
   unsafeShiftR = primWordShr
   bitSizeMaybe _ = Just _wordSize
   bitSize _ = _wordSize
-  bit n = primWordShl 1 n
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Word where
@@ -189,7 +191,9 @@ instance Bits Word8 where
   unsafeShiftR = bini8 primWordShr
   bitSizeMaybe _ = Just 8
   bitSize _ = 8
-  bit n = w8 (primWordShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Word8 where
@@ -282,7 +286,9 @@ instance Bits Word16 where
   unsafeShiftR = bini16 primWordShr
   bitSizeMaybe _ = Just 16
   bitSize _ = 16
-  bit n = w16 (primWordShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Word16 where
@@ -376,7 +382,9 @@ instance Bits Word32 where
   unsafeShiftR = bini32 primWordShr
   bitSizeMaybe _ = Just 32
   bitSize _ = 32
-  bit n = w32 (primWordShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Word32 where
@@ -470,7 +478,9 @@ instance Bits Word64 where
   unsafeShiftR = bini64 primWordShr
   bitSizeMaybe _ = Just 64
   bitSize _ = 64
-  bit n = w64 (primWordShl 1 n)
+  bit = bitDefault
+  testBit = testBitDefault
+  popCount = popCountDefault
   zeroBits = 0
 
 instance FiniteBits Word64 where