1{-# LANGUAGE CPP                #-}
2{-# LANGUAGE MagicHash          #-}
3{-# LANGUAGE UnboxedTuples      #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5module Basement.Types.Word256
6    ( Word256(..)
7    , (+)
8    , (-)
9    , (*)
10    , quot
11    , rem
12    , bitwiseAnd
13    , bitwiseOr
14    , bitwiseXor
15    , complement
16    , shiftL
17    , shiftR
18    , rotateL
19    , rotateR
20    , popCount
21    , fromNatural
22    ) where
23
24import           GHC.Prim
25import           GHC.Word
26import           GHC.Types
27import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod)
28import           Data.Bits hiding (complement, popCount, bit, testBit
29                                  , rotateL, rotateR, shiftL, shiftR)
30import qualified Data.Bits as Bits
31import           Data.Function (on)
32import           Foreign.C
33import           Foreign.Ptr
34import           Foreign.Storable
35
36import           Basement.Compat.Base
37import           Basement.Compat.Natural
38import           Basement.Compat.Primitive (bool#)
39import           Basement.Numerical.Conversion
40import           Basement.Numerical.Number
41
42#include "MachDeps.h"
43
44-- | 256 bits Word
45data Word256 = Word256 {-# UNPACK #-} !Word64
46                       {-# UNPACK #-} !Word64
47                       {-# UNPACK #-} !Word64
48                       {-# UNPACK #-} !Word64
49    deriving (Eq, Typeable)
50
51instance Show Word256 where
52    show w = Prelude.show (toNatural w)
53instance Enum Word256 where
54    toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i)
55    fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0)
56    succ (Word256 a3 a2 a1 a0)
57        | a0 == maxBound =
58            if a1 == maxBound
59                then if a2 == maxBound
60                        then Word256 (succ a3) 0 0 0
61                        else Word256 a3 (succ a2) 0 0
62                else Word256 a3 a2 (succ a1) 0
63        | otherwise      = Word256 a3 a2 a1        (succ a0)
64    pred (Word256 a3 a2 a1 a0)
65        | a0 == minBound =
66            if a1 == minBound
67                then if a2 == minBound
68                        then Word256 (pred a3) maxBound maxBound maxBound
69                        else Word256 a3 (pred a2) maxBound maxBound
70                else Word256 a3 a2 (pred a1) maxBound
71        | otherwise      = Word256 a3 a2 a1        (pred a0)
72instance Bounded Word256 where
73    minBound = Word256 minBound minBound minBound minBound
74    maxBound = Word256 maxBound maxBound maxBound maxBound
75instance Ord Word256 where
76    compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
77        compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0
78      where compareEq x y next =
79                case compare x y of
80                    EQ -> next
81                    r  -> r
82    (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
83        compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0)
84      where compareLt x y next =
85                case compare x y of
86                    EQ -> next
87                    r  -> r == LT
88instance Storable Word256 where
89    sizeOf _ = 32
90    alignment _ = 32
91    peek p = Word256 <$> peek (castPtr p            )
92                     <*> peek (castPtr p `plusPtr` 8)
93                     <*> peek (castPtr p `plusPtr` 16)
94                     <*> peek (castPtr p `plusPtr` 24)
95    poke p (Word256 a3 a2 a1 a0) = do
96        poke (castPtr p             ) a3
97        poke (castPtr p `plusPtr` 8 ) a2
98        poke (castPtr p `plusPtr` 16) a1
99        poke (castPtr p `plusPtr` 24) a0
100
101instance Integral Word256 where
102    fromInteger = literal
103instance HasNegation Word256 where
104    negate = complement
105
106instance IsIntegral Word256 where
107    toInteger (Word256 a3 a2 a1 a0) =
108        (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|.
109        (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|.
110        (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|.
111        toInteger a0
112instance IsNatural Word256 where
113    toNatural (Word256 a3 a2 a1 a0) =
114        (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|.
115        (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|.
116        (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|.
117        toNatural a0
118
119instance Prelude.Num Word256 where
120    abs w = w
121    signum w@(Word256 a3 a2 a1 a0)
122        | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w
123        | otherwise                                = Word256 0 0 0 1
124    fromInteger = literal
125    (+) = (+)
126    (-) = (-)
127    (*) = (*)
128
129instance Bits.Bits Word256 where
130    (.&.) = bitwiseAnd
131    (.|.) = bitwiseOr
132    xor   = bitwiseXor
133    complement = complement
134    shiftL = shiftL
135    shiftR = shiftR
136    rotateL = rotateL
137    rotateR = rotateR
138    bitSize _ = 256
139    bitSizeMaybe _ = Just 256
140    isSigned _ = False
141    testBit = testBit
142    bit = bit
143    popCount = popCount
144
145-- | Add 2 Word256
146(+) :: Word256 -> Word256 -> Word256
147#if WORD_SIZE_IN_BITS < 64
148(+) = applyBiWordOnNatural (Prelude.+)
149#else
150(+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0))
151    (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) =
152    Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0)
153  where
154    !(# c0, s0 #) = plusWord2# a0 b0
155    !(# c1, s1 #) = plusWord3# a1 b1 c0
156    !(# c2, s2 #) = plusWord3# a2 b2 c1
157    !s3           = plusWord3NoCarry# a3 b3 c2
158
159    plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c
160    plusWord3# a b c
161        | bool# (eqWord# carry 0##) = plusWord2# x c
162        | otherwise                 =
163            case plusWord2# x c of
164                (# carry2, x' #)
165                    | bool# (eqWord# carry2 0##) -> (# carry, x' #)
166                    | otherwise                  -> (# plusWord# carry carry2, x' #)
167      where
168        (# carry, x #) = plusWord2# a b
169#endif
170
171-- temporary available until native operation available
172applyBiWordOnNatural :: (Natural -> Natural -> Natural)
173                     -> Word256
174                     -> Word256
175                     -> Word256
176applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural)
177
178-- | Subtract 2 Word256
179(-) :: Word256 -> Word256 -> Word256
180(-) a b
181    | a >= b    = applyBiWordOnNatural (Prelude.-) a b
182    | otherwise = complement (applyBiWordOnNatural (Prelude.-) b a) + 1
183
184-- | Multiplication
185(*) :: Word256 -> Word256 -> Word256
186(*) = applyBiWordOnNatural (Prelude.*)
187
188-- | Division
189quot :: Word256 -> Word256 -> Word256
190quot = applyBiWordOnNatural Prelude.quot
191
192-- | Modulo
193rem :: Word256 -> Word256 -> Word256
194rem = applyBiWordOnNatural Prelude.rem
195
196-- | Bitwise and
197bitwiseAnd :: Word256 -> Word256 -> Word256
198bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
199    Word256 (a3 Bits..&. b3) (a2 Bits..&. b2)  (a1 Bits..&. b1) (a0 Bits..&. b0)
200
201-- | Bitwise or
202bitwiseOr :: Word256 -> Word256 -> Word256
203bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
204    Word256 (a3 Bits..|. b3) (a2 Bits..|. b2)  (a1 Bits..|. b1) (a0 Bits..|. b0)
205
206-- | Bitwise xor
207bitwiseXor :: Word256 -> Word256 -> Word256
208bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) =
209    Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2)  (a1 `Bits.xor` b1) (a0 `Bits.xor` b0)
210
211-- | Bitwise complement
212complement :: Word256 -> Word256
213complement (Word256 a3 a2 a1 a0) =
214    Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0)
215
216-- | Population count
217popCount :: Word256 -> Int
218popCount (Word256 a3 a2 a1 a0) =
219    Bits.popCount a3 Prelude.+
220    Bits.popCount a2 Prelude.+
221    Bits.popCount a1 Prelude.+
222    Bits.popCount a0
223
224-- | Bitwise Shift Left
225shiftL :: Word256 -> Int -> Word256
226shiftL w@(Word256 a3 a2 a1 a0) n
227    | n < 0 || n > 255 = Word256 0 0 0 0
228    | n == 0           = w
229    | n == 64          = Word256 a2 a1 a0 0
230    | n == 128         = Word256 a1 a0 0 0
231    | n == 192         = Word256 a0 0 0 0
232    | n < 64           = mkWordShift a3 a2 a1 a0 n
233    | n < 128          = mkWordShift a2 a1 a0 0  (n Prelude.- 64)
234    | n < 192          = mkWordShift a1 a0 0  0  (n Prelude.- 128)
235    | otherwise        = mkWordShift a0 0  0  0  (n Prelude.- 192)
236  where
237    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256
238    mkWordShift w x y z s =
239        Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s)
240      where s' = inv64 s
241
242-- | Bitwise Shift Right
243shiftR :: Word256 -> Int -> Word256
244shiftR w@(Word256 a3 a2 a1 a0) n
245    | n < 0 || n > 255 = Word256 0 0 0 0
246    | n == 0           = w
247    | n == 64          = Word256 0 a3 a2 a1
248    | n == 128         = Word256 0 0 a3 a2
249    | n == 192         = Word256 0 0 0 a3
250    | n <  64          = mkWordShift a3 a2 a1 a0 n
251    | n < 128          = mkWordShift  0 a3 a2 a1 (n Prelude.- 64)
252    | n < 192          = mkWordShift  0  0 a3 a2 (n Prelude.- 128)
253    | otherwise        = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192))
254  where
255    mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256
256    mkWordShift w x y z s =
257        Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s)
258      where s' = inv64 s
259
260-- | Bitwise rotate Left
261rotateL :: Word256 -> Int -> Word256
262rotateL (Word256 a3 a2 a1 a0) n'
263    | n == 0    = Word256 a3 a2 a1 a0
264    | n == 192  = Word256 a0 a3 a2 a1
265    | n == 128  = Word256 a1 a0 a3 a2
266    | n == 64   = Word256 a2 a1 a0 a3
267    | n < 64    = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))
268                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))
269    | n < 128   = let n = n Prelude.- 64 in Word256
270                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))
271                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))
272    | n < 192   = let n = n Prelude.- 128 in Word256
273                          (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n))
274                          (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n))
275    | otherwise = let n = n Prelude.- 192 in Word256
276                          (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n))
277                          (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n))
278  where
279    n :: Int
280    n | n' >= 0   = n' `Prelude.mod` 256
281      | otherwise = 256 Prelude.- (n' `Prelude.mod` 256)
282
283-- | Bitwise rotate Left
284rotateR :: Word256 -> Int -> Word256
285rotateR w n = rotateL w (256 Prelude.- n)
286
287inv64 :: Int -> Int
288inv64 i = 64 Prelude.- i
289
290comb64 :: Word64 -> Int -> Word64 -> Int -> Word64
291comb64 x i y j =
292    (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j)
293
294-- | Test bit
295testBit :: Word256 -> Int -> Bool
296testBit (Word256 a3 a2 a1 a0) n
297    | n < 0 || n > 255 = False
298    | n > 191          = Bits.testBit a3 (n Prelude.- 192)
299    | n > 127          = Bits.testBit a2 (n Prelude.- 128)
300    | n > 63           = Bits.testBit a1 (n Prelude.- 64)
301    | otherwise        = Bits.testBit a0 n
302
303-- | bit
304bit :: Int -> Word256
305bit n
306    | n < 0 || n > 255 = Word256 0 0 0 0
307    | n > 191          = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0
308    | n > 127          = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0
309    | n > 63           = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0
310    | otherwise        = Word256 0 0 0 (Bits.bit n)
311
312literal :: Integer -> Word256
313literal i = Word256
314    (Prelude.fromInteger (i `Bits.unsafeShiftR` 192))
315    (Prelude.fromInteger (i `Bits.unsafeShiftR` 128))
316    (Prelude.fromInteger (i `Bits.unsafeShiftR` 64))
317    (Prelude.fromInteger i)
318
319fromNatural :: Natural -> Word256
320fromNatural n = Word256
321    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192))
322    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128))
323    (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64))
324    (Prelude.fromInteger $ naturalToInteger n)
325