diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2011, 2012 Mikhail Vorozhtsov +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +- Neither the names of the copyright owners nor the names of the + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data-dword.cabal b/data-dword.cabal new file mode 100644 --- /dev/null +++ b/data-dword.cabal @@ -0,0 +1,56 @@ +Name: data-dword +Version: 0.1 +Category: Data +Stability: experimental +Synopsis: Stick two binary words together to get a bigger one +Description: + This package provides Template Haskell utilities for declaring fixed-length + binary word data types. Signed and unsigned 96, 128, 160, 192, 224, and + 256-bit types are predefined. + +Homepage: https://github.com/mvv/data-dword +Bug-Reports: https://github.com/mvv/data-dword/issues + +Author: Mikhail Vorozhtsov +Maintainer: Mikhail Vorozhtsov +Copyright: 2011, 2012 Mikhail Vorozhtsov +License: BSD3 +License-File: LICENSE + +Cabal-Version: >= 1.10.0 +Build-Type: Simple + +Source-Repository head + Type: git + Location: https://github.com/mvv/data-dword.git + +Library + Default-Language: Haskell2010 + Build-Depends: + base >= 4.5 && < 5, + hashable >= 1.1, + template-haskell >= 2.8, + ghc-prim + Hs-Source-Dirs: src + GHC-Options: -Wall + Exposed-Modules: + Data.DoubleWord + Data.DoubleWord.TH + Other-Modules: + Data.DoubleWord.Base + +Test-Suite tests + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Build-Depends: + base >= 4.5 && < 5, + test-framework >= 0.5, + test-framework-quickcheck2 >= 0.2, + QuickCheck >= 2.4, + data-dword + Hs-Source-Dirs: tests + GHC-Options: -Wall + Main-Is: Tests.hs + Other-Modules: + Types + diff --git a/src/Data/DoubleWord.hs b/src/Data/DoubleWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/DoubleWord.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module provides strict (low and high halves are unpacked) +-- signed and unsigned binary word data types of sizes 96, 128, +-- 160, 192, 224, and 256 bits. +module Data.DoubleWord + ( module Data.DoubleWord.Base + , Word96(..) + , Word128(..) + , Word160(..) + , Word192(..) + , Word224(..) + , Word256(..) + , Int96(..) + , Int128(..) + , Int160(..) + , Int192(..) + , Int224(..) + , Int256(..) + ) where + +import Data.Word +import Data.Int +import Data.DoubleWord.Base +import Data.DoubleWord.TH + +mkUnpackedDoubleWord "Word96" ''Word32 "Int96" ''Int32 ''Word64 +mkUnpackedDoubleWord "Word128" ''Word64 "Int128" ''Int64 ''Word64 +mkUnpackedDoubleWord "Word160" ''Word32 "Int160" ''Int32 ''Word128 +mkUnpackedDoubleWord "Word192" ''Word64 "Int192" ''Int64 ''Word128 +mkUnpackedDoubleWord "Word224" ''Word96 "Int224" ''Int96 ''Word128 +mkUnpackedDoubleWord "Word256" ''Word128 "Int256" ''Int128 ''Word128 + diff --git a/src/Data/DoubleWord/Base.hs b/src/Data/DoubleWord/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/DoubleWord/Base.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +#include "MachDeps.h" + +module Data.DoubleWord.Base + ( BinaryWord(..) + , DoubleWord(..) + ) where + +import Data.Int +import Data.Word +import Data.Bits (Bits(..)) +#if __GLASGOW_HASKELL__ >= 705 +import GHC.Prim (plusWord2#, timesWord2#) +# if WORD_SIZE_IN_BITS == 32 +import GHC.Word (Word32(..)) +# endif +# if WORD_SIZE_IN_BITS == 64 +import GHC.Word (Word64(..)) +# endif +#endif + +-- | Extra bit-manipulation functions for binary words of fixed length. +class Bits w ⇒ BinaryWord w where + -- | The unsigned variant type + type UnsignedWord w + -- | The signed variant type + type SignedWord w + -- | Convert the word to the unsigned type (identical to 'fromIntegral') + unsignedWord ∷ w → UnsignedWord w + -- | Convert the word to the signed type (identical to 'fromIntegral') + signedWord ∷ w → SignedWord w + -- | Unwrapped addition + unwrappedAdd ∷ w → w → (w, UnsignedWord w) + -- | Unwrapped multiplication + unwrappedMul ∷ w → w → (w, UnsignedWord w) + -- | Number of leading (from MSB) zero bits + leadingZeroes ∷ w → Int + -- | Number or trailing (from LSB) zero bits + trailingZeroes ∷ w → Int + -- | The word with all bits set to 0 + allZeroes ∷ w + -- | The word with all bits set to 1 + allOnes ∷ w + -- | The word with MSB set to 1 and all the other bits set to 0 + msb ∷ w + -- | The word with LSB set to 1 and all the other bits set to 0 + lsb ∷ w + -- | Test if the MSB is 1 + testMsb ∷ w → Bool + -- | Test if the LSB is 1 + testLsb ∷ w → Bool + +instance BinaryWord Word8 where + type UnsignedWord Word8 = Word8 + type SignedWord Word8 = Int8 + unsignedWord = id + {-# INLINE unsignedWord #-} + signedWord = fromIntegral + {-# INLINE signedWord #-} + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Word16 + hi = hiWord s + lo = loWord s + {-# INLINE unwrappedAdd #-} + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Word16 + hi = hiWord p + lo = loWord p + {-# INLINE unwrappedMul #-} + leadingZeroes w | w .&. 0xF0 == 0 = go4 4 w + | otherwise = go4 0 (shiftR w 4) + where go4 off w' | w' .&. 8 /= 0 = off + | w' .&. 4 /= 0 = off + 1 + | w' .&. 2 /= 0 = off + 2 + | w' .&. 1 /= 0 = off + 3 + | otherwise = off + 4 + trailingZeroes w | w .&. 0x0F == 0 = go4 4 (shiftR w 4) + | otherwise = go4 0 w + where go4 off w' | w' .&. 1 /= 0 = off + | w' .&. 2 /= 0 = off + 1 + | w' .&. 4 /= 0 = off + 2 + | w' .&. 8 /= 0 = off + 3 + | otherwise = off + 4 + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFF + {-# INLINE allOnes #-} + msb = 0x80 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 7 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Word16 where + type UnsignedWord Word16 = Word16 + type SignedWord Word16 = Int16 + unsignedWord = id + {-# INLINE unsignedWord #-} + signedWord = fromIntegral + {-# INLINE signedWord #-} + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Word32 + lo = loWord s + hi = hiWord s + {-# INLINE unwrappedAdd #-} + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Word32 + lo = loWord p + hi = hiWord p + {-# INLINE unwrappedMul #-} + leadingZeroes w | w .&. 0xFF00 == 0 = go8 8 w + | otherwise = go8 0 (shiftR w 8) + where + go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' + | otherwise = go4 off (shiftR w' 4) + go4 off w' | w' .&. 8 /= 0 = off + | w' .&. 4 /= 0 = off + 1 + | w' .&. 2 /= 0 = off + 2 + | w' .&. 1 /= 0 = off + 3 + | otherwise = off + 4 + trailingZeroes w | w .&. 0x00FF == 0 = go8 8 (shiftR w 8) + | otherwise = go8 0 w + where + go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) + | otherwise = go4 off w' + go4 off w' | w' .&. 1 /= 0 = off + | w' .&. 2 /= 0 = off + 1 + | w' .&. 4 /= 0 = off + 2 + | w' .&. 8 /= 0 = off + 3 + | otherwise = off + 4 + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFF + {-# INLINE allOnes #-} + msb = 0x8000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 15 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Word32 where + type UnsignedWord Word32 = Word32 + type SignedWord Word32 = Int32 + unsignedWord = id + {-# INLINE unsignedWord #-} + signedWord = fromIntegral + {-# INLINE signedWord #-} +#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32 + unwrappedAdd (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo) + where (# hi', lo' #) = plusWord2# x y + hi = W32# hi' + lo = W32# lo' +#else + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Word64 + lo = loWord s + hi = hiWord s +#endif + {-# INLINE unwrappedAdd #-} +#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 32 + unwrappedMul (W32# x) (W32# y) = hi `seq` lo `seq` (hi, lo) + where (# hi', lo' #) = timesWord2# x y + lo = W32# lo' + hi = W32# hi' +#else + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Word64 + lo = loWord p + hi = hiWord p +#endif + {-# INLINE unwrappedMul #-} + leadingZeroes w | w .&. 0xFFFF0000 == 0 = go16 16 w + | otherwise = go16 0 (shiftR w 16) + where + go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w' + | otherwise = go8 off (shiftR w' 8) + go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' + | otherwise = go4 off (shiftR w' 4) + go4 off w' | w' .&. 8 /= 0 = off + | w' .&. 4 /= 0 = off + 1 + | w' .&. 2 /= 0 = off + 2 + | w' .&. 1 /= 0 = off + 3 + | otherwise = off + 4 + trailingZeroes w | w .&. 0x0000FFFF == 0 = go16 16 (shiftR w 16) + | otherwise = go16 0 w + where + go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8) + | otherwise = go8 off w' + go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) + | otherwise = go4 off w' + go4 off w' | w' .&. 1 /= 0 = off + | w' .&. 2 /= 0 = off + 1 + | w' .&. 4 /= 0 = off + 2 + | w' .&. 8 /= 0 = off + 3 + | otherwise = off + 4 + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFFFFFF + {-# INLINE allOnes #-} + msb = 0x80000000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 31 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Word64 where + type UnsignedWord Word64 = Word64 + type SignedWord Word64 = Int64 + unsignedWord = id + {-# INLINE unsignedWord #-} + signedWord = fromIntegral + {-# INLINE signedWord #-} +#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64 + unwrappedAdd (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo) + where (# hi', lo' #) = plusWord2# x y + lo = W64# lo' + hi = W64# hi' + {-# INLINE unwrappedAdd #-} +#else + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where lo = x + y + hi = if lo > x then 1 else 0 + {-# INLINABLE unwrappedAdd #-} +#endif +#if __GLASGOW_HASKELL__ >= 705 && WORD_SIZE_IN_BITS == 64 + unwrappedMul (W64# x) (W64# y) = hi `seq` lo `seq` (hi, lo) + where (# hi', lo' #) = timesWord2# x y + lo = W64# lo' + hi = W64# hi' + {-# INLINE unwrappedMul #-} +#else + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where xHi = hiWord x + xLo = loWord x + yHi = hiWord y + yLo = loWord y + hi0 = xHi * yHi + lo0 = xLo * yLo + p1 = xHi * yLo + p2 = xLo * yHi + lo = lo0 + shiftL p1 32 + shiftL p2 32 + hi = hi0 + shiftR p1 32 + shiftR p2 32 +#endif +#if WORD_SIZE_IN_BITS == 64 + leadingZeroes w | w .&. 0xFFFFFFFF00000000 == 0 = go32 32 w + | otherwise = go32 0 (shiftR w 32) + where + go32 off w' | w' .&. 0xFFFF0000 == 0 = go16 (off + 16) w' + | otherwise = go16 off (shiftR w' 16) + go16 off w' | w' .&. 0xFF00 == 0 = go8 (off + 8) w' + | otherwise = go8 off (shiftR w' 8) + go8 off w' | w' .&. 0xF0 == 0 = go4 (off + 4) w' + | otherwise = go4 off (shiftR w' 4) + go4 off w' | w' .&. 8 /= 0 = off + | w' .&. 4 /= 0 = off + 1 + | w' .&. 2 /= 0 = off + 2 + | w' .&. 1 /= 0 = off + 3 + | otherwise = off + 4 + trailingZeroes w | w .&. 0x00000000FFFFFFFF == 0 = go32 32 (shiftR w 32) + | otherwise = go32 0 w + where + go32 off w' | w' .&. 0x0000FFFF == 0 = go16 (off + 16) (shiftR w' 16) + | otherwise = go16 off w' + go16 off w' | w' .&. 0x00FF == 0 = go8 (off + 8) (shiftR w' 8) + | otherwise = go8 off w' + go8 off w' | w' .&. 0x0F == 0 = go4 (off + 4) (shiftR w' 4) + | otherwise = go4 off w' + go4 off w' | w' .&. 1 /= 0 = off + | w' .&. 2 /= 0 = off + 1 + | w' .&. 4 /= 0 = off + 2 + | w' .&. 8 /= 0 = off + 3 + | otherwise = off + 4 +#else + leadingZeroes w | hiZeroes == 32 = 32 + leadingZeroes (loWord w) + | otherwise = hiZeroes + where hiZeroes = leadingZeroes (hiWord w) + trailingZeroes w | loZeroes == 32 = 32 + trailingZeroes (hiWord w) + | otherwise = loZeroes + where loZeroes = trailingZeroes (loWord w) +#endif + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFFFFFFFFFFFFFF + {-# INLINE allOnes #-} + msb = 0x8000000000000000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 63 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Int8 where + type UnsignedWord Int8 = Word8 + type SignedWord Int8 = Int8 + unsignedWord = fromIntegral + {-# INLINE unsignedWord #-} + signedWord = id + {-# INLINE signedWord #-} + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Int16 + hi = hiWord s + lo = loWord s + {-# INLINE unwrappedAdd #-} + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Int16 + hi = hiWord p + lo = loWord p + {-# INLINE unwrappedMul #-} + leadingZeroes = leadingZeroes . unsignedWord + {-# INLINE leadingZeroes #-} + trailingZeroes = trailingZeroes . unsignedWord + {-# INLINE trailingZeroes #-} + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFF + {-# INLINE allOnes #-} + msb = 0x80 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 7 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Int16 where + type UnsignedWord Int16 = Word16 + type SignedWord Int16 = Int16 + unsignedWord = fromIntegral + {-# INLINE unsignedWord #-} + signedWord = id + {-# INLINE signedWord #-} + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Int32 + lo = loWord s + hi = hiWord s + {-# INLINE unwrappedAdd #-} + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Int32 + lo = loWord p + hi = hiWord p + {-# INLINE unwrappedMul #-} + leadingZeroes = leadingZeroes . unsignedWord + {-# INLINE leadingZeroes #-} + trailingZeroes = trailingZeroes . unsignedWord + {-# INLINE trailingZeroes #-} + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFF + {-# INLINE allOnes #-} + msb = 0x8000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 15 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Int32 where + type UnsignedWord Int32 = Word32 + type SignedWord Int32 = Int32 + unsignedWord = fromIntegral + {-# INLINE unsignedWord #-} + signedWord = id + {-# INLINE signedWord #-} +#if WORD_SIZE_IN_BITS == 32 + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where extX = if x < 0 then maxBound else 0 + extY = if y < 0 then maxBound else 0 + (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y + hi = signedWord $ hi' + extX + extY + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where extX = if x < 0 then negate y else 0 + extY = if y < 0 then negate x else 0 + (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y + hi = signedWord hi' + extX + extY +#else + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where s = fromIntegral x + fromIntegral y ∷ Int64 + lo = loWord s + hi = hiWord s + {-# INLINE unwrappedAdd #-} + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where p = fromIntegral x * fromIntegral y ∷ Int64 + lo = loWord p + hi = hiWord p + {-# INLINE unwrappedMul #-} +#endif + leadingZeroes = leadingZeroes . unsignedWord + {-# INLINE leadingZeroes #-} + trailingZeroes = trailingZeroes . unsignedWord + {-# INLINE trailingZeroes #-} + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFFFFFF + {-# INLINE allOnes #-} + msb = 0x80000000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 31 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +instance BinaryWord Int64 where + type UnsignedWord Int64 = Word64 + type SignedWord Int64 = Int64 + unsignedWord = fromIntegral + {-# INLINE unsignedWord #-} + signedWord = id + {-# INLINE signedWord #-} + unwrappedAdd x y = hi `seq` lo `seq` (hi, lo) + where extX = if x < 0 then maxBound else 0 + extY = if y < 0 then maxBound else 0 + (hi', lo) = unsignedWord x `unwrappedAdd` unsignedWord y + hi = signedWord $ hi' + extX + extY + unwrappedMul x y = hi `seq` lo `seq` (hi, lo) + where extX = if x < 0 then negate y else 0 + extY = if y < 0 then negate x else 0 + (hi', lo) = unsignedWord x `unwrappedMul` unsignedWord y + hi = signedWord hi' + extX + extY + leadingZeroes = leadingZeroes . unsignedWord + {-# INLINE leadingZeroes #-} + trailingZeroes = trailingZeroes . unsignedWord + {-# INLINE trailingZeroes #-} + allZeroes = 0 + {-# INLINE allZeroes #-} + allOnes = 0xFFFFFFFFFFFFFFFF + {-# INLINE allOnes #-} + msb = 0x8000000000000000 + {-# INLINE msb #-} + lsb = 1 + {-# INLINE lsb #-} + testMsb x = testBit x 63 + {-# INLINE testMsb #-} + testLsb x = testBit x 0 + {-# INLINE testLsb #-} + +-- | Defines a particular way to split a binary word in halves. +class BinaryWord w ⇒ DoubleWord w where + -- | The low half type + type LoWord w + -- | The high half type + type HiWord w + -- | The low half of the word + loWord ∷ w → LoWord w + -- | The high half of the word + hiWord ∷ w → HiWord w + -- | Construct a word from the low and high halves + fromHiAndLo ∷ HiWord w → LoWord w → w + -- | Extend the low half + extendLo ∷ LoWord w → w + -- | Sign-extend the low half + signExtendLo ∷ SignedWord (LoWord w) → w + +instance DoubleWord Word16 where + type LoWord Word16 = Word8 + type HiWord Word16 = Word8 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 8 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 8 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + +instance DoubleWord Word32 where + type LoWord Word32 = Word16 + type HiWord Word32 = Word16 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 16 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 16 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + +instance DoubleWord Word64 where + type LoWord Word64 = Word32 + type HiWord Word64 = Word32 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 32 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 32 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + +instance DoubleWord Int16 where + type LoWord Int16 = Word8 + type HiWord Int16 = Int8 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 8 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 8 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + +instance DoubleWord Int32 where + type LoWord Int32 = Word16 + type HiWord Int32 = Int16 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 16 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 16 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + +instance DoubleWord Int64 where + type LoWord Int64 = Word32 + type HiWord Int64 = Int32 + loWord w = fromIntegral w + {-# INLINE loWord #-} + hiWord w = fromIntegral $ shiftR w 32 + {-# INLINE hiWord #-} + fromHiAndLo hi lo = shiftL (fromIntegral hi) 32 .|. fromIntegral lo + {-# INLINE fromHiAndLo #-} + extendLo = fromIntegral + {-# INLINE extendLo #-} + signExtendLo = fromIntegral + {-# INLINE signExtendLo #-} + diff --git a/src/Data/DoubleWord/TH.hs b/src/Data/DoubleWord/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/DoubleWord/TH.hs @@ -0,0 +1,1457 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Template Haskell utilities for generating double words declarations +module Data.DoubleWord.TH + ( mkDoubleWord + , mkUnpackedDoubleWord + ) where + +import GHC.Arr (Ix(..)) +import Data.Ratio ((%)) +import Data.Bits (Bits(..)) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Hashable (Hashable(..), combine) +import Control.Applicative ((<$>), (<*>)) +import Language.Haskell.TH hiding (match) +import Data.DoubleWord.Base + +-- | Declare signed and unsigned binary word types built from +-- the specified low and high halves. The high halves /must/ have +-- less or equal bit-length than the lover half. For each data type +-- the following instances are declared: 'DoubleWord', 'Eq', 'Ord', +-- 'Bounded', 'Enum', 'Num', 'Real', 'Integral', 'Show', 'Hashable', +-- 'Ix', 'Bits', 'BinaryWord'. +mkDoubleWord ∷ String -- ^ Unsigned variant type name + → String -- ^ Unsigned variant constructor name + → Strict -- ^ Unsigned variant higher half strictness + → Name -- ^ Unsigned variant higher half type + → String -- ^ Signed variant type name + → String -- ^ Signed variant constructor name + → Strict -- ^ Signed variant higher half strictness + → Name -- ^ Signed variant higher half type + → Strict -- ^ Lower half strictness + → Name -- ^ Lower half type + → Q [Dec] +mkDoubleWord un uc uhs uhn sn sc shs shn ls ln = + (++) <$> mkDoubleWord' False un' uc' sn' sc' uhs (ConT uhn) ls (ConT ln) + <*> mkDoubleWord' True sn' sc' un' uc' shs (ConT shn) ls (ConT ln) + where un' = mkName un + uc' = mkName uc + sn' = mkName sn + sc' = mkName sc + +-- | @'mkUnpackedDoubleWord' u uh s sh l@ is an alias for +-- @'mkDoubleWord' u u 'Unpacked' uh s s 'Unpacked' sh 'Unpacked' l@ +mkUnpackedDoubleWord ∷ String -- ^ Unsigned variant type name + → Name -- ^ Unsigned variant higher half type + → String -- ^ Signed variant type name + → Name -- ^ Signed variant higher half type + → Name -- ^ Lower half type + → Q [Dec] +mkUnpackedDoubleWord un uhn sn shn ln = + mkDoubleWord un un Unpacked uhn sn sn Unpacked shn Unpacked ln + +mkDoubleWord' ∷ Bool + → Name → Name + → Name → Name + → Strict → Type + → Strict → Type + → Q [Dec] +mkDoubleWord' signed tp cn otp ocn hiS hiT loS loT = (<$> mkRules) $ (++) $ + [ DataD [] tp [] [NormalC cn [(hiS, hiT), (loS, loT)]] [] + , inst ''DoubleWord [tp] + [ TySynInstD ''LoWord [tpT] loT + , TySynInstD ''HiWord [tpT] hiT + , funLo 'loWord (VarE lo) + , inline 'loWord + , funHi 'hiWord (VarE hi) + , inline 'hiWord + , fun 'fromHiAndLo (ConE cn) + , inline 'fromHiAndLo + {- extendLo x = W allZeroes x -} + , funX 'extendLo $ appWN ['allZeroes, x] + , inline 'extendLo + {- + signExtendLo x = W (if x < 0 then allOnes else allZeroes) + (unsignedWord x) + -} + , funX 'signExtendLo $ + appW [ CondE (appVN 'testMsb [x]) + (VarE 'allOnes) (VarE 'allZeroes) + , appVN 'unsignedWord [x] ] + , inlinable 'signExtendLo + ] + , inst ''Eq [tp] $ + {- (W hi lo) == (W hi' lo') = hi == hi' && lo == lo' -} + [ funHiLo2 '(==) $ + appV '(&&) [appVN '(==) [hi, hi'], appVN '(==) [lo, lo']] + , inline '(==) ] + , inst ''Ord [tp] + {- + compare (W hi lo) (W hi' lo') = case hi `compare` hi' of + EQ → lo `compare` lo' + x → x + -} + [ funHiLo2 'compare $ + CaseE (appVN 'compare [hi, hi']) + [ Match (ConP 'EQ []) (NormalB (appVN 'compare [lo, lo'])) [] + , Match (VarP x) (NormalB (VarE x)) [] ] + , inline 'compare ] + , inst ''Bounded [tp] + {- minBound = W minBound minBound -} + [ fun 'minBound $ appWN ['minBound, 'minBound] + , inline 'minBound + {- maxBound = W maxBound maxBound -} + , fun 'maxBound $ appWN ['maxBound, 'maxBound] + , inline 'maxBound ] + , inst ''Enum [tp] + {- + succ (W hi lo) = if lo == maxBound then W (succ hi) minBound + else W hi (succ lo) + -} + [ funHiLo 'succ $ CondE (appVN '(==) [lo, 'maxBound]) + (appW [appVN 'succ [hi], VarE 'minBound]) + (appW [VarE hi, appVN 'succ [lo]]) + , inline 'succ + {- + pred (W hi lo) = if lo == minBound then W (pred hi) maxBound + else W hi (pred lo) + -} + , funHiLo 'pred $ CondE (appVN '(==) [lo, 'minBound]) + (appW [appVN 'pred [hi], VarE 'maxBound]) + (appW [VarE hi, appVN 'pred [lo]]) + , inline 'pred + {- + toEnum x + | x < 0 = if signed + then W (-1) (negate $ 1 + toEnum (negate (x + 1))) + else ERROR + | otherwise = W 0 (toEnum x) + -} + , funX 'toEnum $ + CondE (appV '(<) [VarE x, litI 0]) + (if signed + then appW [ VarE 'allOnes + , appV 'negate + [ appV '(+) + [ oneE + , appV 'toEnum + [ appV 'negate + [appV '(+) [VarE x, litI 1]] ] + ] + ] + ] + else appV 'error [litS "toEnum: nagative value"]) + (appW [VarE 'allZeroes, appVN 'toEnum [x]]) + , inline 'toEnum + {- + fromEnum (W 0 lo) = fromEnum lo + fromEnum (W (-1) lo) = if signed then negate $ fromEnum $ negate lo + else ERROR + fromEnum _ = ERROR + -} + , FunD 'fromEnum $ + Clause [ConP cn [LitP $ IntegerL 0, VarP lo]] + (NormalB $ appVN 'fromEnum [lo]) [] : + if signed + then [ Clause [ConP cn [LitP $ IntegerL (-1), VarP lo]] + (NormalB $ + appV 'negate + [appV 'fromEnum [appV 'negate [VarE lo]]]) + [] + , Clause [WildP] + (NormalB $ + appV 'error [litS "fromEnum: out of bounds"]) + [] + ] + else [ Clause [WildP] + (NormalB $ + appV 'error [litS "fromEnum: out of bounds"]) + [] ] + , inline 'fromEnum + {- enumFrom x = enumFromTo x maxBound -} + , funX 'enumFrom $ appVN 'enumFromTo [x, 'maxBound] + , inline 'enumFrom + {- + enumFromThen x y = + enumFromThenTo x y $ if y >= x then maxBound else minBound + -} + , funXY 'enumFromThen $ + appV 'enumFromThenTo + [ VarE x + , VarE y + , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound) + ] + , inline 'enumFromThen + {- + enumFromTo x y = case y `compare` x of + LT → x : down y x + EQ → [x] + GT → x : up y x + where down to c = next : if next == to then [] else down to next + where next = c - 1 + up to c = next : if next == to then [] else up to next + where next = c + 1 + -} + , FunD 'enumFromTo $ return $ + Clause + [VarP x, VarP y] + (NormalB $ + CaseE (appVN 'compare [y, x]) + [ Match + (ConP 'LT []) + (NormalB $ appC '(:) [VarE x, appVN down [y, x]]) + [] + , Match + (ConP 'EQ []) + (NormalB $ appC '(:) [VarE x, ConE '[]]) + [] + , Match + (ConP 'GT []) + (NormalB $ appC '(:) [VarE x, appVN up [y, x]]) + [] + ]) + [ FunD down $ return $ + Clause [VarP to, VarP c] + (NormalB $ + appC '(:) + [ VarE next + , CondE (appVN '(==) [next, to]) + (ConE '[]) (appVN down [to, next]) + ]) + [ValD (VarP next) + (NormalB $ appVN '(-) [c, 'lsb]) []] + , FunD up $ return $ + Clause [VarP to, VarP c] + (NormalB $ + appC '(:) + [ VarE next + , CondE (appVN '(==) [next, to]) + (ConE '[]) (appVN up [to, next]) + ]) + [ValD (VarP next) + (NormalB $ appVN '(+) [c, 'lsb]) []] + ] + , inlinable 'enumFromTo + {- + enumFromThenTo x y z = case y `compare` x of + LT → if z > x then [] else down (x - y) z x + EQ → repeat x + GT → if z < x then [] else up (y - x) z x + where down s to c = c : if next < to then [] else down s to next + where next = c - s + up s to c = c : if next > to then [] else up s to next + where next = c + s + -} + , FunD 'enumFromThenTo $ return $ + Clause [VarP x, VarP y, VarP z] + (NormalB $ + CaseE (appVN 'compare [y, x]) + [ Match + (ConP 'LT []) + (NormalB $ + CondE (appVN '(>) [z, x]) + (ConE '[]) + (appV down [appVN '(-) [x, y], VarE z, VarE x])) + [] + , Match (ConP 'EQ []) (NormalB $ appVN 'repeat [x]) [] + , Match + (ConP 'GT []) + (NormalB $ + CondE (appVN '(<) [z, x]) (ConE '[]) + (appV up [appVN '(-) [y, x], VarE z, VarE x])) + [] + ]) + [ FunD down $ return $ + Clause [VarP step, VarP to, VarP c] + (NormalB $ + appC '(:) + [ VarE c + , CondE (appVN '(<) [next, to]) + (ConE '[]) (appVN down [step, to, next]) + ]) + [ValD (VarP next) (NormalB $ appVN '(-) [c, step]) []] + , FunD up $ return $ + Clause [VarP step, VarP to, VarP c] + (NormalB $ + appC '(:) + [ VarE c + , CondE (appVN '(==) [next, to]) + (ConE '[]) (appVN up [step, to, next]) + ]) + [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]] + , inlinable 'enumFromThenTo + ] + , inst ''Num [tp] + {- + negate (W hi lo) = if lo == 0 then W (negate hi) 0 + else W (negate $ hi + 1) (negate lo) + -} + [ funHiLo 'negate $ + CondE (appVN '(==) [lo, 'allZeroes]) + (appW [appVN 'negate [hi], zeroE]) + (appW [ appV 'negate [appVN '(+) ['lsb, hi]] + , appVN 'negate [lo] ]) + , inline 'negate + {- + abs x = if SIGNED + then if x < 0 then negate x else x + else x + -} + , funX 'abs $ + if signed + then CondE (appVN '(<) [x, 'allZeroes]) + (appVN 'negate [x]) (VarE x) + else VarE x + , inline 'abs + {- + signum (W hi lo) = if SIGNED + then case hi `compare` 0 of + LT → W (-1) maxBound + EQ → if lo == 0 then 0 else 1 + GT → W 0 1 + else if hi == 0 && lo == 0 then 0 else 1 + -} + , funHiLo 'signum $ + if signed + then CaseE (appVN 'compare [hi, 'allZeroes]) + [ Match (ConP 'LT []) + (NormalB $ appWN ['allOnes, 'maxBound]) [] + , Match (ConP 'EQ []) + (NormalB $ CondE (appVN '(==) [lo, 'allZeroes]) + zeroE oneE) + [] + , Match (ConP 'GT []) (NormalB oneE) [] + ] + else CondE (appV '(&&) [ appVN '(==) [hi, 'allZeroes] + , appVN '(==) [lo, 'allZeroes] ]) + zeroE oneE + , inline 'signum + {- + (W hi lo) + (W hi' lo') = W y x + where x = lo + lo' + y = hi + hi' + if x < lo then 1 else 0 + -} + , funHiLo2' '(+) (appWN [y, x]) + [ val x $ appVN '(+) [lo, lo'] + , val y $ appV '(+) + [ appVN '(+) [hi, hi'] + , CondE (appVN '(<) [x, lo]) oneE zeroE ] + ] + , inlinable '(+) + {- + UNSIGNED: + (W hi lo) * (W hi' lo') = + W (hi * fromIntegral lo' + hi' * fromIntegral lo + + fromIntegral x) y + where (x, y) = unwrappedMul lo lo' + + SIGNED: + x * y = signedWord $ unsignedWord x * unsignedWord y + -} + , if signed + then + funXY '(*) $ + appV 'signedWord + [appV '(*) [ appVN 'unsignedWord [x] + , appVN 'unsignedWord [y] ]] + else + funHiLo2' '(*) + (appW [ appV '(+) + [ appV '(+) + [ appV '(*) [VarE hi, appVN 'fromIntegral [lo']] + , appV '(*) [VarE hi', appVN 'fromIntegral [lo]] ] + , appVN 'fromIntegral [x] ] + , VarE y ]) + [vals [x, y] (appVN 'unwrappedMul [lo, lo'])] + , inlinable '(*) + {- + fromInteger x = W (fromInteger y) (fromInteger z) + where (y, z) = x `divMod` (toInteger (maxBound ∷ L) + 1) + -} + , funX' 'fromInteger + (appW [appVN 'fromInteger [y], appVN 'fromInteger [z]]) + [vals [y, z] + (appV 'divMod + [ VarE x + , appV '(+) + [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] + ])] + , inlinable 'fromInteger + ] + , inst ''Real [tp] + {- toRational x = toInteger x % 1 -} + [ funX 'toRational $ appV '(%) [appVN 'toInteger [x], litI 1] + , inline 'toRational ] + , inst ''Integral [tp] + {- + toInteger (W hi lo) = + toInteger hi * (toInteger (maxBound ∷ L) + 1) + toInteger lo + -} + [ funHiLo 'toInteger $ + appV '(+) + [ appV '(*) + [ appVN 'toInteger [hi] + , appV '(+) + [appV 'toInteger [SigE (VarE 'maxBound) loT], litI 1] ] + , appVN 'toInteger [lo] ] + {- + UNSIGNED: + quotRem x@(W hi lo) y@(W hi' lo') = + if hi' == 0 && lo' == 0 + then error "divide by zero" + else case compare hi hi' of + LT → (0, x) + EQ → compare lo lo' of + LT → (0, x) + EQ → (1, 0) + GT | hi' == 0 → (W 0 t2, W 0 t1) + where (t2, t1) = quotRem lo lo' + GT → (1, lo - lo') + GT | lo' == 0 → (W 0 (fromIntegral t2), + W (fromIntegral t1) lo) + where (t2, t1) = quotRem hi hi' + GT | hi' == 0 && lo' == maxBound → + if t2 == 0 + then if t1 == maxBound + then (W 0 z + 1, 0) + else (W 0 z, t1) + else if t1 == maxBound + then (W 0 z + 2, 1) + else if t1 == xor maxBound 1 + then (W 0 z + 2, 0) + else (W 0 z + 1, W 0 (t1 + 1)) + where z = fromIntegral hi + (t2, t1) = unwrappedAdd z lo + GT | hi' == 0 → (t2, W 0 t1) + where (t2, t1) = div1 hi lo lo' + GT → if t1 == t2 + then (1, x - y) + else (W 0 (fromIntegral q2), shiftR r2 t2) + where t1 = leadingZeroes hi + t2 = leadingZeroes hi' + z = shiftR hi (bitSize (undefined ∷ H) - t2) + W hhh hll = shiftL x t2 + v@(W lhh lll) = shiftL y t2 + -- z hhh hll / lhh lll + ((0, q1), r1) = div2 z hhh lhh + (t4, t3) = unwrappedMul (fromIntegral q1) lll + t5 = W (fromIntegral t4) t3 + t6 = W r1 hll + (t8, t7) = unwrappedAdd t6 v + (t10, t9) = unwrappedAdd t7 v + (q2, r2) = + if t5 > t6 + then + if loWord t8 == 0 + then + if t7 >= t5 + then (q1 - 1, t7 - t5) + else + if loWord t10 == 0 + then (q1 - 2, t9 - t5) + else (q1 - 2, (maxBound - t5) + t9 + 1) + else + (q1 - 1, (maxBound - t5) + t7 + 1) + else + (q1, t6 - t5) + where div1 hhh hll by = go hhh hll 0 + where (t2, t1) = quotRem maxBound by + go h l c = + if z == 0 + then (c + W (fromIntegral t8) t7 + W 0 t10, t9) + else go (fromIntegral z) t5 + (c + (W (fromIntegral t8) t7)) + where h1 = fromIntegral h + (t4, t3) = unwrappedMul h1 (t1 + 1) + (t6, t5) = unwrappedAdd t3 l + z = t4 + t6 + (t8, t7) = unwrappedMul h1 t2 + (t10, t9) = quotRem t5 by + div2 hhh hll by = go hhh hll (0, 0) + where (t2, t1) = quotRem maxBound by + go h l c = + if z == 0 + then (addT (addT c (t8, t7)) (0, t10), t9) + else go z t5 (addT c (t8, t7)) + where (t4, t3) = unwrappedMul h (t1 + 1) + (t6, t5) = unwrappedAdd t3 l + z = t4 + t6 + (t8, t7) = unwrappedMul h t2 + (t10, t9) = quotRem t5 by + addT (lhh, lhl) (llh, lll) = (lhh + llh + t4, t3) + where (t4, t3) = unwrappedAdd lhl lll + + SIGNED: + quotRem x y = + if x < 0 + then + if y < 0 + then let (q, r) = quotRem (negate $ unsignedWord x) + (negate $ unsignedWord y) in + (signedWord q, signedWord $ negate r) + else let (q, r) = quotRem (negate $ unsignedWord x) + (unsignedWord y) in + (signedWord $ negate q, signedWord $ negate r) + else + if y < 0 + then let (q, r) = quotRem (unsignedWord x) + (negate $ unsignedWord y) in + (signedWord $ negate q, signedWord r) + else let (q, r) = quotRem (unsignedWord x) + (unsignedWord y) in + (signedWord q, signedWord r) + -} + , if signed + then + funXY 'quotRem $ + CondE (appVN 'testMsb [x]) + (CondE (appVN 'testMsb [y]) + (LetE [vals [q, r] $ + appV 'quotRem + [ appV 'unsignedWord [appVN 'negate [x]] + , appV 'unsignedWord [appVN 'negate [y]] ]] + (TupE [ appVN 'signedWord [q] + , appV 'signedWord [appVN 'negate [r]] ])) + (LetE [vals [q, r] $ + appV 'quotRem + [ appV 'unsignedWord [appVN 'negate [x]] + , appVN 'unsignedWord [y] ]] + (TupE [ appV 'signedWord [appVN 'negate [q]] + , appV 'signedWord [appVN 'negate [r]] ]))) + (CondE (appVN 'testMsb [y]) + (LetE [vals [q, r] $ + appV 'quotRem + [ appVN 'unsignedWord [x] + , appV 'unsignedWord [appVN 'negate [y]] ]] + (TupE [ appV 'signedWord [appVN 'negate [q]] + , appVN 'signedWord [r] ])) + (LetE [vals [q, r] $ + appV 'quotRem + [ appVN 'unsignedWord [x] + , appVN 'unsignedWord [y] ]] + (TupE [ appVN 'signedWord [q] + , appVN 'signedWord [r] ]))) + else + funHiLo2XY' 'quotRem + (CondE (appV '(&&) [ appVN '(==) [hi', 'allZeroes] + , appVN '(==) [lo', 'allZeroes] ]) + (appV 'error [litS "divide by zero"]) + (CaseE (appVN 'compare [hi, hi']) + [ match (ConP 'LT []) (TupE [zeroE, VarE x]) + , match (ConP 'EQ []) + (CaseE (appVN 'compare [lo, lo']) + [ match (ConP 'LT []) (TupE [zeroE, VarE x]) + , match (ConP 'EQ []) (TupE [oneE, zeroE]) + , Match (ConP 'GT []) + (GuardedB $ return + ( NormalG (appVN '(==) [hi', 'allZeroes]) + , TupE [ appWN ['allZeroes, t2] + , appWN ['allZeroes, t1] ])) + [vals [t2, t1] $ appVN 'quotRem [lo, lo']] + , match (ConP 'GT []) $ + TupE [ oneE + , appW [zeroE, appVN '(-) [lo, lo']] ] + ]) + , Match (ConP 'GT []) + (GuardedB $ return + ( NormalG (appVN '(==) [lo', 'allZeroes]) + , TupE + [ appW [zeroE, appVN 'fromIntegral [t2]] + , appW [appVN 'fromIntegral [t1], VarE lo] + ] )) + [vals [t2, t1] $ appVN 'quotRem [hi, hi']] + , Match (ConP 'GT []) + (GuardedB $ return + ( NormalG (appV '(&&) + [ appVN '(==) [hi', 'allZeroes] + , appVN '(==) [lo', 'maxBound] ]) + , CondE (appVN '(==) [t2, 'allZeroes]) + (CondE (appVN '(==) [t1, 'maxBound]) + (TupE + [ appV '(+) + [ appWN ['allZeroes, z] + , oneE ] + , zeroE ]) + (TupE + [ appWN ['allZeroes, z] + , appWN ['allZeroes, t1] ])) + (CondE (appVN '(==) [t1, 'maxBound]) + (TupE + [ appV '(+) + [appWN ['allZeroes, z], litI 2] + , oneE ]) + (CondE + (appV '(==) + [ VarE t1 + , appVN 'xor ['maxBound, 'lsb] + ]) + (TupE + [ appV '(+) + [appWN ['allZeroes, z], litI 2] + , zeroE ]) + (TupE + [ appV '(+) + [appWN ['allZeroes, z], oneE] + , appW [ zeroE + , appVN '(+) [t1, 'lsb] ] + ]))) + )) + [ val z $ appVN 'fromIntegral [hi] + , vals [t2, t1] $ appVN 'unwrappedAdd [z, lo] ] + , Match (ConP 'GT []) + (GuardedB $ return + ( NormalG (appVN '(==) [hi', 'allZeroes]) + , TupE [VarE t2, appWN ['allZeroes, t1]] )) + [vals [t2, t1] $ appVN div1 [hi, lo, lo']] + , match' (ConP 'GT []) + (CondE (appVN '(==) [t1, t2]) + (TupE [oneE, appVN '(-) [x, y]]) + (TupE [ appW [zeroE, appVN 'fromIntegral [q2]] + , appVN 'shiftR [r2, t2] ])) + [ val t1 $ appVN 'leadingZeroes [hi] + , val t2 $ appVN 'leadingZeroes [hi'] + , val z $ appV 'shiftR + [ VarE hi + , appV '(-) + [ appV 'bitSize + [SigE (VarE 'undefined) hiT] + , VarE t2 ] + ] + , ValD (ConP cn [VarP hhh, VarP hll]) + (NormalB $ appVN 'shiftL [x, t2]) [] + , ValD (AsP v $ ConP cn [VarP lhh, VarP lll]) + (NormalB $ appVN 'shiftL [y, t2]) [] + , ValD (TupP [ TupP [LitP (IntegerL 0), VarP q1] + , VarP r1 ]) + (NormalB $ appVN div2 [z, hhh, lhh]) [] + , vals [t4, t3] $ + appV 'unwrappedMul + [appVN 'fromIntegral [q1], VarE lll] + , val t5 $ appW [appVN 'fromIntegral [t4], VarE t3] + , val t6 $ appWN [r1, hll] + , vals [t8, t7] $ appVN 'unwrappedAdd [t6, v] + , vals [t10, t9] $ appVN 'unwrappedAdd [t7, v] + , vals [q2, r2] $ + CondE (appVN '(>) [t5, t6]) + (CondE (appV '(==) [appVN 'loWord [t8], zeroE]) + (CondE (appVN '(>=) [t7, t5]) + (TupE [ appVN '(-) [q1, 'lsb] + , appVN '(-) [t7, t5] ]) + (CondE (appV '(==) [ appVN 'loWord [t10] + , zeroE ]) + (TupE [ appV '(-) [VarE q1, litI 2] + , appVN '(-) [t9, t5] ]) + (TupE [ appV '(-) [VarE q1, litI 2] + , appV '(+) + [ appVN '(-) ['maxBound, t5] + , appVN '(+) [t9, 'lsb] + ] + ]))) + (TupE [ appVN '(-) [q1, 'lsb] + , appV '(+) + [ appVN '(-) ['maxBound, t5] + , appVN '(+) [t7, 'lsb] ] + ])) + (TupE [VarE q1, appVN '(-) [t6, t5]]) + ] + ])) + [ FunD div1 $ return $ + Clause [VarP hhh, VarP hll, VarP by] + (NormalB (appVN go [hhh, hll, 'allZeroes])) + [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] + , FunD go $ return $ + Clause [VarP h, VarP l, VarP c] + (NormalB + (CondE (appVN '(==) [z, 'allZeroes]) + (TupE [ appV '(+) + [ VarE c + , appV '(+) + [ appW [ appVN 'fromIntegral [t8] + , VarE t7 ] + , appWN ['allZeroes, t10] ] + ] + , VarE t9 ]) + (appV go + [ appVN 'fromIntegral [z] + , VarE t5 + , appV '(+) + [ VarE c + , appW [ appVN 'fromIntegral [t8] + , VarE t7 ] + ] + ]))) + [ val h1 $ appVN 'fromIntegral [h] + , vals [t4, t3] $ + appV 'unwrappedMul + [VarE h1, appVN '(+) [t1, 'lsb]] + , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] + , val z $ appVN '(+) [t4, t6] + , vals [t8, t7] $ appVN 'unwrappedMul [h1, t2] + , vals [t10, t9] $ appVN 'quotRem [t5, by] ] + ] + , FunD div2 $ return $ + Clause [VarP hhh, VarP hll, VarP by] + (NormalB (appV go [ VarE hhh + , VarE hll + , TupE [zeroE, zeroE]])) + [ vals [t2, t1] $ appVN 'quotRem ['maxBound, by] + , FunD go $ return $ + Clause [VarP h, VarP l, VarP c] + (NormalB + (CondE (appVN '(==) [z, 'allZeroes]) + (TupE [ appV addT + [ VarE c + , appV addT + [ TupE [VarE t8 , VarE t7] + , TupE [zeroE, VarE t10] ] + ] + , VarE t9 ]) + (appV go + [ VarE z + , VarE t5 + , appV addT + [ VarE c + , TupE [VarE t8, VarE t7] + ] + ]))) + [ vals [t4, t3] $ + appV 'unwrappedMul + [VarE h, appVN '(+) [t1, 'lsb]] + , vals [t6, t5] $ appVN 'unwrappedAdd [t3, l] + , val z $ appVN '(+) [t4, t6] + , vals [t8, t7] $ appVN 'unwrappedMul [h, t2] + , vals [t10, t9] $ appVN 'quotRem [t5, by] ] + , FunD addT $ return $ + Clause [ TupP [VarP lhh, VarP lhl] + , TupP [VarP llh, VarP lll] + ] + (NormalB (TupE [ appV '(+) + [ VarE t4 + , appVN '(+) [lhh, llh] + ] + , VarE t3 + ])) + [vals [t4, t3] $ appVN 'unwrappedAdd [lhl, lll]] + ] + ] + {- + UNSIGNED: + divMod = quotRem + + SIGNED: + divMod x y = + if x < 0 + then + if y < 0 + then let (q, r) = quotRem (negate $ unsignedWord x) + (negate $ unsignedWord y) in + (signedWord q, signedWord $ negate r) + else let (q, r) = quotRem (negate $ unsignedWord x) + (unsignedWord y) + q1 = signedWord (negate q) + r1 = signedWord (negate r) in + if r == 0 + then (q1, r1) + else (q1 - 1, r1 + y) + else + if y < 0 + then let (q, r) = quotRem (unsignedWord x) + (negate $ unsignedWord y) + q1 = signedWord (negate q) + r1 = signedWord r in + if r == 0 + then (q1, r1) + else (q1 - 1, r1 + y) + else let (q, r) = quotRem (unsignedWord x) + (unsignedWord y) in + (signedWord q, signedWord r) + -} + , if signed + then + funXY 'divMod $ + CondE (appVN 'testMsb [x]) + (CondE (appVN 'testMsb [y]) + (LetE [vals [q, r] $ + appV 'quotRem + [ appV 'unsignedWord [appVN 'negate [x]] + , appV 'unsignedWord [appVN 'negate [y]] ]] + (TupE [ appVN 'signedWord [q] + , appV 'signedWord [appVN 'negate [r]] ])) + (LetE [ vals [q, r] $ + appV 'quotRem + [ appV 'unsignedWord [appVN 'negate [x]] + , appVN 'unsignedWord [y] ] + , val q1 $ appV 'signedWord [appVN 'negate [q]] + , val r1 $ appV 'signedWord [appVN 'negate [r]] + ] + (CondE (appVN '(==) [r, 'allZeroes]) + (TupE [VarE q1, VarE r1]) + (TupE [ appVN '(-) [q1, 'lsb] + , appVN '(+) [r1, y] ])))) + (CondE (appVN 'testMsb [y]) + (LetE [ vals [q, r] $ + appV 'quotRem + [ appVN 'unsignedWord [x] + , appV 'unsignedWord [appVN 'negate [y]] ] + , val q1 $ appV 'signedWord [appVN 'negate [q]] + , val r1 $ appVN 'signedWord [r] + ] + (CondE (appVN '(==) [r, 'allZeroes]) + (TupE [VarE q1, VarE r1]) + (TupE [ appVN '(-) [q1, 'lsb] + , appVN '(+) [r1, y] ]))) + (LetE [vals [q, r] $ + appV 'quotRem + [ appVN 'unsignedWord [x] + , appVN 'unsignedWord [y] ]] + (TupE [ appVN 'signedWord [q] + , appVN 'signedWord [r] ]))) + else + fun 'divMod $ VarE 'quotRem + , inline 'divMod + ] + , inst ''Show [tp] + [ fun 'show $ appVN '(.) ['show, 'toInteger] + , inline 'show ] + , inst ''Hashable [tp] + {- hash (W hi lo) = hash hi `combine` hash lo -} + [ funHiLo 'hash $ appV 'combine [appVN 'hash [hi], appVN 'hash [lo]] + , inline 'hash + , inline 'hashWithSalt ] + , inst ''Ix [tp] + {- range (x, y) = enumFromTo x y -} + [ funTup 'range $ appVN 'enumFromTo [x, y] + , inline 'range + {- unsafeIndex (x, _) z = fromIntegral z - fromIntegral x -} + , funTupLZ 'unsafeIndex $ + appV '(-) [appVN 'fromIntegral [z], appVN 'fromIntegral [x]] + , inline 'unsafeIndex + {- inRange (x, y) z = z >= x && z <= y -} + , funTupZ 'inRange $ + appV '(&&) [appVN '(>=) [z, x], appVN '(<=) [z, y]] + , inline 'inRange ] + , inst ''Bits [tp] + {- bitSize _ = bitSize (undefined ∷ H) + bitSize (undefined ∷ L) -} + [ fun_ 'bitSize $ + appV '(+) + [ appV 'bitSize [SigE (VarE 'undefined) hiT] + , appV 'bitSize [SigE (VarE 'undefined) loT] ] + , inline 'bitSize + {- isSigned _ = SIGNED -} + , fun_ 'isSigned $ ConE $ if signed then 'True else 'False + , inline 'isSigned + {- complement (W hi lo) = W (complement hi) (complement lo) -} + , funHiLo 'complement $ + appW [appVN 'complement [hi], appVN 'complement [lo]] + , inline 'complement + {- xor (W hi lo) (W hi' lo') = W (xor hi hi') (xor lo lo') -} + , funHiLo2 'xor $ appW [appVN 'xor [hi, hi'], appVN 'xor [lo, lo']] + , inline 'xor + {- (W hi lo) .&. (W hi' lo') = W (hi .&. hi') (lo .&. lo') -} + , funHiLo2 '(.&.) $ + appW [appVN '(.&.) [hi, hi'], appVN '(.&.) [lo, lo']] + , inline '(.&.) + {- (W hi lo) .|. (W hi' lo') = W (hi .|. hi') (lo .|. lo') -} + , funHiLo2 '(.|.) $ + appW [appVN '(.|.) [hi, hi'], appVN '(.|.) [lo, lo']] + , inline '(.|.) + {- + shiftL (W hi lo) x = + if y > 0 + then W (shiftL hi x .|. fromIntegral (shiftR lo y)) + (shiftL lo x) + else W (fromIntegral $ shiftL lo $ negate y) 0 + where y = bitSize (undefined ∷ L) - x + -} + , funHiLoX' 'shiftL + (CondE (appV '(>) [VarE y, litI 0]) + (appW + [ appV '(.|.) + [ appVN 'shiftL [hi, x] + , appV 'fromIntegral [appVN 'shiftR [lo, y]] ] + , appVN 'shiftL [lo, x] ]) + (appW [ appV 'fromIntegral + [appV 'shiftL [VarE lo, appVN 'negate [y]]] + , zeroE ])) + [val y $ + appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] + , VarE x ]] + {- + shiftR (W hi lo) x = + W (shiftR hi x) + (if y >= 0 then shiftL (fromIntegral hi) y .|. shiftR lo x + else z) + where y = bitSize (undefined ∷ L) - x + z = if SIGNED + then fromIntegral $ + shiftR (fromIntegral hi ∷ SignedWord L) $ + negate y + else shiftR (fromIntegral hi) $ negate y + -} + , funHiLoX' 'shiftR + (appW [ appVN 'shiftR [hi, x] + , CondE (appV '(>=) [VarE y, litI 0]) + (appV '(.|.) + [ appV 'shiftL + [appVN 'fromIntegral [hi], VarE y] + , appVN 'shiftR [lo, x] ]) + (VarE z) ]) + [ val y $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] + , VarE x ] + , val z $ + if signed + then appV 'fromIntegral + [appV 'shiftR + [ SigE (appVN 'fromIntegral [hi]) + (AppT (ConT ''SignedWord) loT) + , appVN 'negate [y] ]] + else appV 'shiftR [ appVN 'fromIntegral [hi] + , appVN 'negate [y] ] + ] + {- + UNSIGNED: + rotateL (W hi lo) x = + if y >= 0 + then W (fromIntegral (shiftL lo y) .|. shiftR hi z) + W (shiftL (fromIntegral hi) (bitSize (undefined ∷ L) - z) + .|. shiftR lo z) + else W (fromIntegral (shiftR lo $ negate y) .|. shiftL hi x) + (shift (fromIntegral hi) (bitSize (undefined ∷ L) - z) + .|. shiftL lo x + .|. shiftR lo z) + where y = x - bitSize (undefined ∷ L) + z = bitSize (undefined ∷ W) - x + SIGNED: + rotateL x y = signedWord $ rotateL (unsignedWord x) y + -} + , if signed + then + funXY 'rotateL $ + appV 'signedWord + [appV 'rotateL [appVN 'unsignedWord [x], VarE y]] + else + funHiLoX' 'rotateL + (CondE (appV '(>=) [VarE y, litI 0]) + (appW + [ appV '(.|.) + [ appV 'fromIntegral [appVN 'shiftL [lo, y]] + , appVN 'shiftR [hi, z] ] + , appV '(.|.) + [ appV 'shiftL + [ appVN 'fromIntegral [hi] + , appV '(-) + [ appV 'bitSize [SigE (VarE 'undefined) loT] + , VarE z ] + ] + , appVN 'shiftR [lo, z] ] + ]) + (appW + [ appV '(.|.) + [ appV 'fromIntegral + [appV 'shiftR [VarE lo, appVN 'negate [y]]] + , appVN 'shiftL [hi, x] ] + , appV '(.|.) + [ appV 'shift + [ appVN 'fromIntegral [hi] + , appV '(-) + [ appV 'bitSize [SigE (VarE 'undefined) loT] + , VarE z] ] + , appV '(.|.) + [appVN 'shiftL [lo, x], appVN 'shiftR [lo, z]] ] + ])) + [ val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ] + , val z $ + appV '(-) + [ appV 'bitSize [SigE (VarE 'undefined) tpT] + , VarE x ] + ] + {- rotateR x y = rotateL x $ bitSize (undefined ∷ W) - y -} + , funXY 'rotateR $ + appV 'rotateL + [ VarE x + , appV '(-) + [appV 'bitSize [SigE (VarE 'undefined) tpT], VarE y] + ] + , inline 'rotateR + {- + bit x = if y >= 0 then W (bit y) 0 else W 0 (bit x) + where y = x - bitSize (undefined ∷ LoWord W) + -} + , funX' 'bit (CondE (appV '(>=) [VarE y, litI 0]) + (appW [appVN 'bit [y], zeroE]) + (appW [zeroE, appVN 'bit [x]])) + [val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ]] + , inline 'bit + {- + setBit (W hi lo) x = + if y >= 0 then W (setBit hi y) lo else W hi (setBit lo x) + where y = x - bitSize (undefined ∷ L) + -} + , funHiLoX' 'setBit + (CondE (appV '(>=) [VarE y, litI 0]) + (appW [appVN 'setBit [hi, y], VarE lo]) + (appW [VarE hi, appVN 'setBit [lo, x]])) + [val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ]] + , inline 'setBit + {- + clearBit (W hi lo) x = + if y >= 0 then W (clearBit hi y) lo + else W hi (clearBit lo x) + where y = x - bitSize (undefined ∷ L) + -} + , funHiLoX' 'clearBit + (CondE (appV '(>=) [VarE y, litI 0]) + (appW [appVN 'clearBit [hi, y], VarE lo]) + (appW [VarE hi, appVN 'clearBit [lo, x]])) + [val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ]] + , inline 'clearBit + {- + complementBit (W hi lo) x = + if y >= 0 then W (complementBit hi y) lo + else W hi (complementBit lo x) + where y = x - bitSize (undefined ∷ L) + -} + , funHiLoX' 'complementBit + (CondE (appV '(>=) [VarE y, litI 0]) + (appW [appVN 'complementBit [hi, y], VarE lo]) + (appW [VarE hi, appVN 'complementBit [lo, x]])) + [val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ]] + , inline 'complementBit + {- + testBit (W hi lo) x = + if y >= 0 then testBit hi y else testBit lo x + where y = x - bitSize (undefined ∷ L) + -} + , funHiLoX' 'testBit + (CondE (appV '(>=) [VarE y, litI 0]) + (appVN 'testBit [hi, y]) + (appVN 'testBit [lo, x])) + [val y $ + appV '(-) [ VarE x + , appV 'bitSize [SigE (VarE 'undefined) loT] ]] + , inline 'testBit + {- popCount (W hi lo) = popCount hi + popCount lo -} + , funHiLo 'popCount + (appV '(+) [appVN 'popCount [hi], appVN 'popCount [lo]]) + , inline 'popCount + ] + , inst ''BinaryWord [tp] + [ TySynInstD ''UnsignedWord [tpT] $ + ConT $ if signed then otp else tp + , TySynInstD ''SignedWord [tpT] $ + ConT $ if signed then tp else otp + {- + UNSIGNED: + unsignedWord = id + + SIGNED: + unsignedWord (W hi lo) = U (unsignedWord hi) lo + -} + , if signed + then + funHiLo 'unsignedWord $ + appC ocn [appVN 'unsignedWord [hi], VarE lo] + else + fun 'unsignedWord $ VarE 'id + , inline 'unsignedWord + {- + UNSIGNED: + signedWord (W hi lo) = S (signedWord hi) lo + + SIGNED: + signedWord = id + -} + , if signed + then + fun 'signedWord $ VarE 'id + else + funHiLo 'signedWord $ + appC ocn [appVN 'signedWord [hi], VarE lo] + , inline 'signedWord + {- + UNSIGNED: + unwrappedAdd (W hi lo) (W hi' lo') = (W 0 z, W y x) + where (t1, x) = unwrappedAdd lo lo' + (t3, t2) = unwrappedAdd hi (fromIntegral t1) + (t4, y) = unwrappedAdd t2 hi' + z = fromIntegral $ t3 + t4 + SIGNED: + unwrappedAdd x y = (z, t4) + where t1 = if x < 0 then maxBound else minBound + t2 = if y < 0 then maxBound else minBound + (t3, t4) = unwrappedAdd (unsignedWord x) (unsignedWord y) + z = signedWord $ t1 + t2 + t3 + -} + , if signed + then + funXY' 'unwrappedAdd (TupE [VarE z, VarE t4]) + [ val t1 $ CondE (appVN 'testMsb [x]) + (VarE 'maxBound) (VarE 'minBound) + , val t2 $ CondE (appVN 'testMsb [y]) + (VarE 'maxBound) (VarE 'minBound) + , vals [t3, t4] $ + appV 'unwrappedAdd [ appVN 'unsignedWord [x] + , appVN 'unsignedWord [y] ] + , val z $ + appV 'signedWord [appV '(+) [VarE t1, appVN '(+) [t2, t3]]] + ] + else + funHiLo2' 'unwrappedAdd + (TupE [appWN ['allZeroes, z], appWN [y, x]]) + [ vals [t1, x] $ appVN 'unwrappedAdd [lo, lo'] + , vals [t3, t2] $ + appV 'unwrappedAdd [VarE hi, appVN 'fromIntegral [t1]] + , vals [t4, y] $ appVN 'unwrappedAdd [t2, hi'] + , val z $ appV 'fromIntegral [appVN '(+) [t3, t4]] + ] + {- + UNSIGNED: + unwrappedMul (W hi lo) (W hi' lo') = + (W (hhh + fromIntegral (shiftR t9 y) + shiftL x z) + (shiftL t9 z .|. shiftR t3 y), + W (fromIntegral t3) lll) + where (llh, lll) = unwrappedMul lo lo' + (hlh, hll) = unwrappedMul (fromIntegral hi) lo' + (lhh, lhl) = unwrappedMul lo (fromIntegral hi') + (hhh, hhl) = unwrappedMul hi hi' + (t2, t1) = unwrappedAdd llh hll + (t4, t3) = unwrappedAdd t1 lhl + (t6, t5) = unwrappedAdd (fromIntegral hhl) (t2 + t4) + (t8, t7) = unwrappedAdd t5 lhh + (t10, t9) = unwrappedAdd t7 hlh + x = fromIntegral $ t6 + t8 + t10 + y = bitSize (undefined ∷ H) + z = bitSize (undefined ∷ L) - y + SIGNED: + unwrappedMul (W hi lo) (W hi' lo') = (x, y) + where t1 = W (complement hi') (complement lo') + 1 + t2 = W (complement hi) (complement lo) + 1 + (t3, y) = unwrappedMul (U (unsignedWord hi) lo) + (U (unsignedWord hi') lo') + z = signedWord t3 + x = if hi < 0 + then if hi' < 0 + then z + t1 + t2 + else z + t1 + else if hi' < 0 + then z + t2 + else z + -} + , if signed + then + funHiLo2' 'unwrappedMul (TupE [VarE x, VarE y]) + [ val t1 $ + appV '(+) [ appW [ appVN 'complement [hi'] + , appVN 'complement [lo'] ] + , oneE ] + , val t2 $ + appV '(+) [ appW [ appVN 'complement [hi] + , appVN 'complement [lo] ] + , oneE ] + , vals [t3, y] $ + appV 'unwrappedMul + [ appC ocn [appVN 'unsignedWord [hi], VarE lo] + , appC ocn [appVN 'unsignedWord [hi'], VarE lo'] ] + , val z $ appVN 'signedWord [t3] + , val x $ + CondE (appVN 'testMsb [hi]) + (CondE (appVN 'testMsb [hi']) + (appV '(+) [VarE z, appVN '(+) [t1, t2]]) + (appVN '(+) [z, t1])) + (CondE (appVN 'testMsb [hi']) + (appVN '(+) [z, t2]) (VarE z)) + ] + else + funHiLo2' 'unwrappedMul + (TupE [ appW + [ appV '(+) + [ VarE hhh + , appV '(+) + [ appV 'fromIntegral [appVN 'shiftR [t9, y]] + , appVN 'shiftL [x, z] ] + ] + , appV '(.|.) [ appVN 'shiftL [t9, z] + , appVN 'shiftR [t3, y] ] + ] + , appW [appVN 'fromIntegral [t3], VarE lll] + ]) + [ vals [llh, lll] $ appVN 'unwrappedMul [lo, lo'] + , vals [hlh, hll] $ + appV 'unwrappedMul [appVN 'fromIntegral [hi], VarE lo'] + , vals [lhh, lhl] $ + appV 'unwrappedMul [VarE lo, appVN 'fromIntegral [hi']] + , vals [hhh, hhl] $ appVN 'unwrappedMul [hi, hi'] + , vals [t2, t1] $ appVN 'unwrappedAdd [llh, hll] + , vals [t4, t3] $ appVN 'unwrappedAdd [t1, lhl] + , vals [t6, t5] $ + appV 'unwrappedAdd [ appVN 'fromIntegral [hhl] + , appVN '(+) [t2, t4] ] + , vals [t8, t7] $ appVN 'unwrappedAdd [t5, lhh] + , vals [t10, t9] $ appVN 'unwrappedAdd [t7, hlh] + , val x $ + appV 'fromIntegral + [appV '(+) [VarE t6, appVN '(+) [t8, t10]]] + , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] + , val z $ appV '(-) [ appV 'bitSize [SigE (VarE 'undefined) loT] + , VarE y ] + ] + {- + UNSIGNED: + leadingZeroes (W hi lo) = + if x == y then y + leadingZeroes lo else x + where x = leadingZeroes hi + y = bitSize (undefined ∷ H) + SIGNED: + leadingZeroes = leadingZeroes . unsignedWord + -} + , if signed + then + fun 'leadingZeroes $ appVN '(.) ['leadingZeroes, 'unsignedWord] + else + funHiLo' 'leadingZeroes + (CondE (appVN '(==) [x, y]) + (appV '(+) [VarE y, appVN 'leadingZeroes [lo]]) + (VarE x)) + [ val x $ appVN 'leadingZeroes [hi] + , val y $ appV 'bitSize [SigE (VarE 'undefined) hiT] + ] + , inline 'leadingZeroes + {- + UNSIGNED: + trailingZeroes (W hi lo) = + if x == y then y + trailingZeroes hi else x + where x = trailingZeroes lo + y = bitSize (undefined ∷ L) + SIGNED: + trailingZeroes = trailingZeroes . unsignedWord + -} + , if signed + then + fun 'trailingZeroes $ appVN '(.) ['trailingZeroes, 'unsignedWord] + else + funHiLo' 'trailingZeroes + (CondE (appVN '(==) [x, y]) + (appV '(+) [VarE y, appVN 'trailingZeroes [hi]]) + (VarE x)) + [ val x $ appVN 'trailingZeroes [lo] + , val y $ appV 'bitSize [SigE (VarE 'undefined) loT] + ] + , inline 'trailingZeroes + {- allZeroes = W allZeroes allZeroes -} + , fun 'allZeroes $ appWN ['allZeroes, 'allZeroes] + , inline 'allZeroes + {- allOnes = W allOnes allOnes -} + , fun 'allOnes $ appWN ['allOnes, 'allOnes] + , inline 'allOnes + {- msb = W msb allZeroes -} + , fun 'msb $ appWN ['msb, 'allZeroes] + , inline 'msb + {- lsb = W allZeroes lsb -} + , fun 'lsb $ appWN ['allZeroes, 'lsb] + , inline 'lsb + {- testMsb (W hi _) = testMsb hi -} + , funHi 'testMsb $ appVN 'testMsb [hi] + , inline 'testMsb + {- testLsb (W _ lo) = testLsb lo -} + , funLo 'testLsb $ appVN 'testLsb [lo] + , inline 'testLsb + ] + ] + where + x = mkName "x" + y = mkName "y" + z = mkName "z" + t1 = mkName "t1" + t2 = mkName "t2" + t3 = mkName "t3" + t4 = mkName "t4" + t5 = mkName "t5" + t6 = mkName "t6" + t7 = mkName "t7" + t8 = mkName "t8" + t9 = mkName "t9" + t10 = mkName "t10" + v = mkName "v" + q = mkName "q" + q1 = mkName "q1" + q2 = mkName "q2" + r = mkName "r" + r1 = mkName "r1" + r2 = mkName "r2" + lll = mkName "lll" + llh = mkName "llh" + lhl = mkName "lhl" + lhh = mkName "lhh" + hll = mkName "hll" + hlh = mkName "hlh" + hhl = mkName "hhl" + hhh = mkName "hhh" + h = mkName "h" + h1 = mkName "h1" + l = mkName "l" + div1 = mkName "div1" + div2 = mkName "div2" + addT = mkName "addT" + by = mkName "by" + go = mkName "go" + c = mkName "c" + next = mkName "next" + step = mkName "step" + to = mkName "to" + down = mkName "down" + up = mkName "up" + hi = mkName "hi" + lo = mkName "lo" + hi' = mkName "hi'" + lo' = mkName "lo'" + tpT = ConT tp + inst cls params = InstanceD [] (foldl AppT (ConT cls) (ConT <$> params)) + fun n e = FunD n [Clause [] (NormalB e) []] + fun_ n e = FunD n [Clause [WildP] (NormalB e) []] + funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds] + funX n e = funX' n e [] + funXY' n e ds = FunD n [Clause [VarP x, VarP y] (NormalB e) ds] + funXY n e = funXY' n e [] + funTup n e = FunD n [Clause [TupP [VarP x, VarP y]] (NormalB e) []] + funTupZ n e = + FunD n [Clause [TupP [VarP x, VarP y], VarP z] (NormalB e) []] + funTupLZ n e = + FunD n [Clause [TupP [VarP x, WildP], VarP z] (NormalB e) []] + funLo n e = FunD n [Clause [ConP cn [WildP, VarP lo]] (NormalB e) []] + funHi n e = FunD n [Clause [ConP cn [VarP hi, WildP]] (NormalB e) []] + funHiLo n e = funHiLo' n e [] + funHiLo' n e ds = + FunD n [Clause [ConP cn [VarP hi, VarP lo]] (NormalB e) ds] + funHiLoX' n e ds = + FunD n [Clause [ConP cn [VarP hi, VarP lo], VarP x] (NormalB e) ds] + funHiLo2 n e = funHiLo2' n e [] + funHiLo2' n e ds = + FunD n [Clause [ ConP cn [VarP hi, VarP lo] + , ConP cn [VarP hi', VarP lo'] ] + (NormalB e) ds] + funHiLo2XY' n e ds = + FunD n [Clause [ AsP x (ConP cn [VarP hi, VarP lo]) + , AsP y (ConP cn [VarP hi', VarP lo']) ] + (NormalB e) ds] + match' p e ds = Match p (NormalB e) ds + match p e = match' p e [] + inline n = PragmaD $ InlineP n Inline FunLike AllPhases + inlinable n = PragmaD $ InlineP n Inlinable FunLike AllPhases + val n e = ValD (VarP n) (NormalB e) [] + vals ns e = ValD (TupP (VarP <$> ns)) (NormalB e) [] + app f = foldl AppE f + appN f = app f . fmap VarE + appV f = app (VarE f) + appC f = app (ConE f) + appW = appC cn + appVN f = appN (VarE f) + appCN f = appN (ConE f) + appWN = appCN cn + litI = LitE . IntegerL + litS = LitE . StringL + zeroE = VarE 'allZeroes + oneE = VarE 'lsb + mkRules = do + let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) [] + (VarE 'fromIntegral) + (SigE (VarE 'id) (AppT (AppT ArrowT tpT) tpT)) + AllPhases + mkRules' [idRule] loT + (VarE 'loWord) + (VarE 'extendLo) + (VarE 'signExtendLo) + mkRules' rules t narrowE extE signExtE = do + let narrowRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT t) + [] + (VarE 'fromIntegral) + (SigE narrowE (AppT (AppT ArrowT tpT) t)) + AllPhases + extRule = RuleP ("fromIntegral/" ++ showT t ++ "->" ++ show tp) + [] + (VarE 'fromIntegral) + (SigE extE (AppT (AppT ArrowT t) tpT)) + AllPhases + signedRules ← do + insts ← reifyInstances ''SignedWord [t] + case insts of + [TySynInstD _ _ signT] → return $ + [ RuleP ("fromIntegral/" ++ show tp ++ "->" ++ showT signT) + [] + (VarE 'fromIntegral) + (SigE (AppE (appVN '(.) ['signedWord]) narrowE) + (AppT (AppT ArrowT tpT) signT)) + AllPhases + , RuleP ("fromIntegral/" ++ showT signT ++ "->" ++ show tp) + [] + (VarE 'fromIntegral) + (SigE signExtE (AppT (AppT ArrowT signT) tpT)) + AllPhases ] + _ → return [] + let rules' = narrowRule : extRule : signedRules ++ rules + case smallerStdTypes t of + Just ts → do + let smallRules = ts >>= \(uSmallName, sSmallName) → + let uSmallT = ConT uSmallName + sSmallT = ConT sSmallName in + [ RuleP ("fromIntegral/" ++ + show tp ++ "->" ++ show uSmallName) + [] + (VarE 'fromIntegral) + (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) + (AppT (AppT ArrowT tpT) uSmallT)) + AllPhases + , RuleP ("fromIntegral/" ++ + show uSmallName ++ "->" ++ show tp) + [] + (VarE 'fromIntegral) + (SigE (appV '(.) [extE, VarE 'fromIntegral]) + (AppT (AppT ArrowT uSmallT) tpT)) + AllPhases + , RuleP ("fromIntegral/" ++ + show tp ++ "->" ++ show sSmallName) + [] + (VarE 'fromIntegral) + (SigE (appV '(.) [VarE 'fromIntegral, narrowE]) + (AppT (AppT ArrowT tpT) sSmallT)) + AllPhases + , RuleP ("fromIntegral/" ++ + show sSmallName ++ "->" ++ show tp) + [] + (VarE 'fromIntegral) + (SigE (appV '(.) [signExtE, VarE 'fromIntegral]) + (AppT (AppT ArrowT sSmallT) tpT)) + AllPhases + ] + return $ PragmaD <$> rules' ++ smallRules + _ → do + insts ← reifyInstances ''LoWord [t] + case insts of + [TySynInstD _ _ t'] → + mkRules' rules' t' + (appV '(.) [VarE 'loWord, narrowE]) + (appV '(.) [VarE 'extendLo, extE]) + (appV '(.) [VarE 'signExtendLo, signExtE]) + _ → return $ PragmaD <$> rules' + showT (ConT n) = show n + showT t = show t + stdTypes = [(''Word64, ''Int64), (''Word32, ''Int32), + (''Word16, ''Int16), (''Word8, ''Int8)] + smallerStdTypes t = smallerStdTypes' t stdTypes + smallerStdTypes' _ [] = Nothing + smallerStdTypes' t ((ut, _) : ts) + | ConT ut == t = Just ts + | otherwise = smallerStdTypes' t ts + diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +import Test.Framework (RunnerOptions'(..), TestOptions'(..), + defaultMainWithOpts, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck hiding ((.&.)) + +import Data.Bits +import Data.Word +import Data.Int +import Data.Monoid (mempty) +import Data.DoubleWord (BinaryWord(..)) +import Types + +class Iso α τ | τ → α where + fromArbitrary ∷ α → τ + toArbitrary ∷ τ → α + +instance Iso Word64 U64 where + fromArbitrary w = U64 (fromIntegral $ w `shiftR` 32) (fromIntegral w) + toArbitrary (U64 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l + +instance Iso Int64 I64 where + fromArbitrary w = I64 (fromIntegral $ w `shiftR` 32) (fromIntegral w) + toArbitrary (I64 h l) = fromIntegral h `shiftL` 32 .|. fromIntegral l + +instance Iso Word64 UU64 where + fromArbitrary w = UU64 (fromIntegral $ w `shiftR` 48) + (U48 (fromIntegral $ w `shiftR` 32) (fromIntegral w)) + toArbitrary (UU64 h (U48 lh ll)) = fromIntegral h `shiftL` 48 + .|. fromIntegral lh `shiftL` 32 + .|. fromIntegral ll + +instance Iso Int64 II64 where + fromArbitrary w = II64 (fromIntegral $ w `shiftR` 48) + (U48 (fromIntegral $ w `shiftR` 32) (fromIntegral w)) + toArbitrary (II64 h (U48 lh ll)) = fromIntegral h `shiftL` 48 + .|. fromIntegral lh `shiftL` 32 + .|. fromIntegral ll + +main = defaultMainWithOpts + [ arbTestGroup "Word8" (0 ∷ Word8) + , arbTestGroup "Int8" (0 ∷ Int8) + , arbTestGroup "Word16" (0 ∷ Word16) + , arbTestGroup "Int16" (0 ∷ Int16) + , arbTestGroup "Word32" (0 ∷ Word32) + , arbTestGroup "Int32" (0 ∷ Int32) + , arbTestGroup "Word64" (0 ∷ Word64) + , arbTestGroup "Int64" (0 ∷ Int64) + , isoTestGroup "|Word32|Word32|" (0 ∷ U64) + , isoTestGroup "|Int32|Word32|" (0 ∷ I64) + , isoTestGroup "|Word16|Word16|Word32|" (0 ∷ UU64) + , isoTestGroup "|Int16|Word16|Word32|" (0 ∷ II64) ] + mempty { + ropt_test_options = + Just (mempty { topt_maximum_generated_tests = Just 1000 }) + } + +arbTestGroup name t = + testGroup name + [ testGroup "BinaryWord" + [ testProperty "unwrappedAdd" $ prop_unwrappedAddArb t + , testProperty "unwrappedMul" $ prop_unwrappedMulArb t + , testProperty "leadingZeroes" $ prop_leadingZeroesArb t + , testProperty "trailingZeroes" $ prop_trailingZeroesArb t + , testProperty "allZeroes" $ prop_allZeroesArb t + , testProperty "allOnes" $ prop_allOnesArb t + , testProperty "msb" $ prop_msbArb t + , testProperty "lsb" $ prop_lsbArb t + , testProperty "testMsb" $ prop_testMsbArb t + , testProperty "testLsb" $ prop_testLsbArb t ] + ] + +isoTestGroup name t = + testGroup name + [ testProperty "Iso" $ prop_conv t + , testGroup "Eq" [ testProperty "(==)" $ prop_eq t ] + , testGroup "Ord" [ testProperty "compare" $ prop_compare t ] + , testGroup "Bounded" + [ testProperty "minBound" $ prop_minBound t + , testProperty "maxBound" $ prop_maxBound t ] + , testGroup "Enum" + [ testProperty "succ" $ prop_succ t + , testProperty "pred" $ prop_pred t ] + , testGroup "Num" + [ testProperty "negate" $ prop_negate t + , testProperty "abs" $ prop_abs t + , testProperty "signum" $ prop_signum t + , testProperty "(+)" $ prop_add t + , testProperty "(-)" $ prop_sub t + , testProperty "(*)" $ prop_mul t + , testProperty "fromInteger" $ prop_fromInteger t ] + , testGroup "Real" + [ testProperty "toRational" $ prop_toRational t ] + , testGroup "Integral" + [ testProperty "toInteger" $ prop_toInteger t + , testProperty "quotRem" $ prop_quotRem t + , testProperty "quot" $ prop_quot t + , testProperty "rem" $ prop_rem t + , testProperty "divMod" $ prop_divMod t + , testProperty "div" $ prop_div t + , testProperty "mod" $ prop_mod t ] + , testGroup "Bits" + [ testProperty "complement" $ prop_complement t + , testProperty "xor" $ prop_xor t + , testProperty "(.&.)" $ prop_and t + , testProperty "(.|.)" $ prop_or t + , testProperty "shiftL" $ prop_shiftL t + , testProperty "shiftR" $ prop_shiftR t + , testProperty "rotateL" $ prop_rotateL t + , testProperty "rotateR" $ prop_rotateR t + , testProperty "bit" $ prop_bit t + , testProperty "setBit" $ prop_setBit t + , testProperty "clearBit" $ prop_clearBit t + , testProperty "complementBit" $ prop_complementBit t + , testProperty "testBit" $ prop_testBit t + , testProperty "popCount" $ prop_popCount t + ] + , testGroup "BinaryWord" + [ testProperty "unwrappedAdd" $ prop_unwrappedAdd t + , testProperty "unwrappedMul" $ prop_unwrappedMul t + , testProperty "leadingZeroes" $ prop_leadingZeroes t + , testProperty "trailingZeroes" $ prop_trailingZeroes t + , testProperty "allZeroes" $ prop_allZeroes t + , testProperty "allOnes" $ prop_allOnes t + , testProperty "msb" $ prop_msb t + , testProperty "lsb" $ prop_lsb t + , testProperty "testMsb" $ prop_testMsb t + , testProperty "testLsb" $ prop_testLsb t + ] + ] + +prop_unwrappedAddArb ∷ ∀ α + . (Integral α, BinaryWord α, Bounded (UnsignedWord α), + Integral (UnsignedWord α)) + ⇒ α → α → α → Bool +prop_unwrappedAddArb _ x y = s == toInteger x + toInteger y + where (hi, lo) = unwrappedAdd x y + s = toInteger hi * (toInteger (maxBound ∷ UnsignedWord α) + 1) + + toInteger lo + +prop_unwrappedMulArb ∷ ∀ α + . (Integral α, BinaryWord α, Bounded (UnsignedWord α), + Integral (UnsignedWord α)) + ⇒ α → α → α → Bool +prop_unwrappedMulArb _ x y = p == toInteger x * toInteger y + where (hi, lo) = unwrappedMul x y + p = toInteger hi * (toInteger (maxBound ∷ UnsignedWord α) + 1) + + toInteger lo + +prop_leadingZeroesArb ∷ ∀ α . (Num α, BinaryWord α) ⇒ α → α → Bool +prop_leadingZeroesArb _ x + | lz == 0 = testBit x (bs - 1) + | lz == bs = x == 0 + | otherwise = shiftR x (bs - lz) == 0 && testBit x (bs - lz - 1) + where lz = leadingZeroes x + bs = bitSize x + +prop_trailingZeroesArb ∷ ∀ α . (Num α, BinaryWord α) ⇒ α → α → Bool +prop_trailingZeroesArb _ x + | tz == 0 = testBit x 0 + | tz == bs = x == 0 + | otherwise = shiftL x (bs - tz) == 0 && testBit x tz + where tz = trailingZeroes x + bs = bitSize x + +prop_allZeroesArb ∷ ∀ α . BinaryWord α ⇒ α → Bool +prop_allZeroesArb a = + all (not . testBit (allZeroes ∷ α)) [0 .. bitSize a - 1] + +prop_allOnesArb ∷ ∀ α . BinaryWord α ⇒ α → Bool +prop_allOnesArb a = all (testBit (allOnes ∷ α)) [0 .. bitSize a - 1] + +prop_msbArb ∷ ∀ α . BinaryWord α ⇒ α → Bool +prop_msbArb a = testBit (msb ∷ α) (bitSize a - 1) && + all (not . testBit (msb ∷ α)) [0 .. bitSize a - 2] + +prop_lsbArb ∷ ∀ α . BinaryWord α ⇒ α → Bool +prop_lsbArb a = testBit (lsb ∷ α) 0 && + all (not . testBit (lsb ∷ α)) [1 .. bitSize a - 1] + +prop_testMsbArb ∷ ∀ α . BinaryWord α ⇒ α → α → Bool +prop_testMsbArb _ x = testMsb x == testBit x (bitSize x - 1) + +prop_testLsbArb ∷ ∀ α . BinaryWord α ⇒ α → α → Bool +prop_testLsbArb _ x = testLsb x == testBit x 0 + +toType ∷ Iso α τ ⇒ τ → α → τ +toType _ = fromArbitrary + +fromType ∷ Iso α τ ⇒ τ → τ → α +fromType _ = toArbitrary + +withUnary ∷ Iso α τ ⇒ τ → (τ → τ) → α → α +withUnary _ f = toArbitrary . f . fromArbitrary + +withUnary' ∷ Iso α τ ⇒ τ → (τ → β) → α → β +withUnary' _ f = f . fromArbitrary + +withBinary ∷ Iso α τ ⇒ τ → (τ → τ → τ) → α → α → α +withBinary _ f x y = toArbitrary $ f (fromArbitrary x) (fromArbitrary y) + +withBinary' ∷ Iso α τ ⇒ τ → (τ → τ → β) → α → α → β +withBinary' _ f x y = f (fromArbitrary x) (fromArbitrary y) + +propUnary f g t w = f w == withUnary t g w +propUnary' f g t w = f w == withUnary' t g w + +propBinary f g t w1 w2 = f w1 w2 == withBinary t g w1 w2 +propBinary' f g t w1 w2 = f w1 w2 == withBinary' t g w1 w2 + +prop_conv t w = toArbitrary (toType t w) == w + +prop_eq = propBinary' (==) (==) + +prop_compare = propBinary' compare compare + +prop_minBound t = minBound == fromType t minBound +prop_maxBound t = maxBound == fromType t maxBound + +prop_succ t w = (w /= maxBound) ==> (succ w == withUnary t succ w) +prop_pred t w = (w /= minBound) ==> (pred w == withUnary t pred w) + +prop_unwrappedAdd ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ), + BinaryWord α, BinaryWord τ, Eq α, Eq (UnsignedWord α)) + ⇒ τ → α → α → Bool +prop_unwrappedAdd t x y = h1 == toArbitrary h2 && l1 == toArbitrary l2 + where (h1, l1) = unwrappedAdd x y + (h2, l2) = unwrappedAdd (toType t x) (toType t y) + +prop_unwrappedMul ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ), + BinaryWord α, BinaryWord τ, Eq α, Eq (UnsignedWord α)) + ⇒ τ → α → α → Bool +prop_unwrappedMul t x y = h1 == toArbitrary h2 && l1 == toArbitrary l2 + where (h1, l1) = unwrappedMul x y + (h2, l2) = unwrappedMul (toType t x) (toType t y) + +prop_leadingZeroes = propUnary' leadingZeroes leadingZeroes +prop_trailingZeroes = propUnary' trailingZeroes trailingZeroes +prop_allZeroes t = allZeroes == fromType t allZeroes +prop_allOnes t = allOnes == fromType t allOnes +prop_msb t = msb == fromType t msb +prop_lsb t = lsb == fromType t lsb +prop_testMsb = propUnary' testMsb testMsb +prop_testLsb = propUnary' testLsb testLsb + +prop_negate = propUnary negate negate +prop_abs = propUnary abs abs +prop_signum = propUnary signum signum +prop_add = propBinary (+) (+) +prop_sub = propBinary (-) (-) +prop_mul = propBinary (*) (*) +prop_fromInteger t i = fromInteger i == fromType t (fromInteger i) + +prop_toRational = propUnary' toRational toRational + +prop_toInteger = propUnary' toInteger toInteger +prop_quotRem t n d = (d /= 0) ==> (qr == (fromType t q1, fromType t r1)) + where qr = quotRem n d + (q1, r1) = quotRem (fromArbitrary n) (fromArbitrary d) +prop_quot t n d = (d /= 0) ==> (q == fromType t q1) + where q = quot n d + q1 = quot (fromArbitrary n) (fromArbitrary d) +prop_rem t n d = (d /= 0) ==> (r == fromType t r1) + where r = rem n d + r1 = rem (fromArbitrary n) (fromArbitrary d) +prop_divMod t n d = (d /= 0) ==> (qr == (fromType t q1, fromType t r1)) + where qr = divMod n d + (q1, r1) = divMod (fromArbitrary n) (fromArbitrary d) +prop_div t n d = (d /= 0) ==> (q == fromType t q1) + where q = div n d + q1 = div (fromArbitrary n) (fromArbitrary d) +prop_mod t n d = (d /= 0) ==> (r == fromType t r1) + where r = mod n d + r1 = mod (fromArbitrary n) (fromArbitrary d) + +prop_complement = propUnary complement complement +prop_xor = propBinary xor xor +prop_and = propBinary (.&.) (.&.) +prop_or = propBinary (.|.) (.|.) +propOffsets f g t w = + all (\b → f w b == withUnary t (`g` b) w) [0 .. bitSize t] +prop_shiftL = propOffsets shiftL shiftL +prop_shiftR = propOffsets shiftR shiftR +prop_rotateL = propOffsets rotateL rotateL +prop_rotateR = propOffsets rotateR rotateR +prop_bit t = all (\b → bit b == fromType t (bit b)) [0 .. bitSize t - 1] +propBits f g t w = + all (\b → f w b == withUnary t (`g` b) w) [0 .. bitSize t - 1] +prop_setBit = propBits setBit setBit +prop_clearBit = propBits clearBit clearBit +prop_complementBit = propBits complementBit complementBit +prop_testBit t w = + all (\b → testBit w b == withUnary' t (`testBit` b) w) [0 .. bitSize t - 1] +prop_popCount = propUnary' popCount popCount + diff --git a/tests/Types.hs b/tests/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Types where + +import Data.Word +import Data.Int +import Data.DoubleWord.TH + +$(mkUnpackedDoubleWord "U64" ''Word32 "I64" ''Int32 ''Word32) +$(mkUnpackedDoubleWord "U48" ''Word16 "I48" ''Int16 ''Word32) +$(mkUnpackedDoubleWord "UU64" ''Word16 "II64" ''Int16 ''U48) +