diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -6,6 +6,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Main (main) where @@ -44,18 +45,33 @@ $ measureInt "quoteQuot" $$(quoteQuot (n :: Int)) \ ] +#define benchDivInt(n) \ + bgroup (show (n :: Int)) \ + [ measureInt "div" (`div` (n :: Int)) \ + , bcompare ("$NF == \"div\" && $(NF-1) == \"" ++ show (n :: Int) ++ "\" && $(NF-2) == \"Int\"") \ + $ measureInt "quoteDiv" $$(quoteDiv (n :: Int)) \ + ] + main :: IO () main = defaultMain [ bgroup "Word" [ benchWord(3) , benchWord(5) , benchWord(7) + , benchWord(10000) ] #if MIN_VERSION_base(4,15,0) , bgroup "Int" [ benchInt(3) , benchInt(5) , benchInt(7) + , benchInt(10000) + ] + , bgroup "DivInt" + [ benchDivInt(3) + , benchDivInt(5) + , benchDivInt(7) + , benchDivInt(10000) ] #endif ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.2.2.0 + +* Add `quoteDiv`, `quoteMod` and `quoteDivMod`. +* Define `instance MulHi {Int,Word}64` even on 32-bit arch. + ## 0.2.1.0 * Add `quoteAST` and `assumeNonNegArg`. diff --git a/quote-quot.cabal b/quote-quot.cabal --- a/quote-quot.cabal +++ b/quote-quot.cabal @@ -1,12 +1,15 @@ -cabal-version: >=1.10 +cabal-version: 2.2 name: quote-quot -version: 0.2.1.0 -license: BSD3 +version: 0.2.2.0 +license: BSD-3-Clause license-file: LICENSE copyright: 2020-2022 Andrew Lelechenko maintainer: andrew.lelechenko@gmail.com author: Andrew Lelechenko -tested-with: ghc ==8.10.7, ghc ==9.0.2, ghc ==9.2.2 +tested-with: + ghc ==9.2.8 ghc ==9.4.8 ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 + ghc ==9.12.2 ghc ==9.14.1 + homepage: https://github.com/Bodigrim/quote-quot#readme synopsis: Divide without division description: @@ -16,7 +19,7 @@ category: Math, Numerical build-type: Simple -extra-source-files: +extra-doc-files: changelog.md README.md @@ -30,8 +33,8 @@ default-language: Haskell2010 ghc-options: -Wall -Wcompat build-depends: - base < 5, - template-haskell >=2.16 + base >=4.18 && < 5, + template-haskell-lift >= 0.1 && < 0.2 test-suite quote-quot-tests type: exitcode-stdio-1.0 @@ -43,19 +46,17 @@ base, quote-quot, tasty, - tasty-quickcheck, - -- wide-word >=0.1.1.2, + tasty-quickcheck + -- wide-word >=0.1.9, -- word24, - template-haskell benchmark quote-quot-bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: bench default-language: Haskell2010 - ghc-options: -Wall -O2 -Wcompat + ghc-options: -Wall -O2 -Wcompat -fproc-alignment=64 build-depends: base, quote-quot, - tasty-bench >= 0.3, - template-haskell + tasty-bench >= 0.3.3 diff --git a/src/Numeric/QuoteQuot.hs b/src/Numeric/QuoteQuot.hs --- a/src/Numeric/QuoteQuot.hs +++ b/src/Numeric/QuoteQuot.hs @@ -10,13 +10,17 @@ -- {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LexicalNegation #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} - -{-# OPTIONS_GHC -Wno-missing-signatures #-} +{- HLINT ignore "Redundant lambda" -} module Numeric.QuoteQuot ( @@ -24,6 +28,9 @@ quoteQuot , quoteRem , quoteQuotRem + , quoteDiv + , quoteMod + , quoteDivMod -- * AST , astQuot , AST(..) @@ -31,19 +38,17 @@ , quoteAST , assumeNonNegArg , MulHi(..) + , Unsigned ) where -#include "MachDeps.h" - -import Prelude -import Data.Bits -import Data.Int -import Data.Word -import GHC.Exts -import Language.Haskell.TH.Syntax +import Data.Bits (shiftL, shiftR, isSigned, FiniteBits, countTrailingZeros, finiteBitSize) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word ( Word8, Word16, Word32, Word64 ) +import GHC.Exts (dataToTag#, Int(..), Word(..), timesInt2#, timesWord2#) +import Language.Haskell.TH.Lift (Lift, Quote, Code) --- | Quote integer division ('quot') by a compile-time known divisor, --- which generates source code, employing arithmetic and bitwise operations only. +-- | Quote integer division ('quot') by a compile-time known divisor, which +-- generates source code, employing arithmetic and bitwise operations only. -- This is usually __2.5x-3.5x faster__ than using normal 'quot'. -- -- > {-# LANGUAGE TemplateHaskell #-} @@ -79,71 +84,108 @@ -- Benchmarks show that this implementation is __3.5x faster__ -- than @(`@'quot'@` 10)@. -- -quoteQuot :: -#if MIN_VERSION_template_haskell(2,17,0) - (MulHi a, Lift a, Quote m) => a -> Code m (a -> a) -#else - (MulHi a, Lift a) => a -> Q (TExp (a -> a)) -#endif +quoteQuot :: forall a m. (MulHi a, Lift a, Quote m) => a -> Code m (a -> a) quoteQuot d = quoteAST (astQuot d) -- | Similar to 'quoteQuot', but for 'rem'. -quoteRem :: -#if MIN_VERSION_template_haskell(2,17,0) - (MulHi a, Lift a, Quote m) => a -> Code m (a -> a) -#else - (MulHi a, Lift a) => a -> Q (TExp (a -> a)) -#endif +quoteRem :: (MulHi a, Lift a, Quote m) => a -> Code m (a -> a) quoteRem d = [|| snd . $$(quoteQuotRem d) ||] -- | Similar to 'quoteQuot', but for 'quotRem'. -quoteQuotRem :: -#if MIN_VERSION_template_haskell(2,17,0) - (MulHi a, Lift a, Quote m) => a -> Code m (a -> (a, a)) -#else - (MulHi a, Lift a) => a -> Q (TExp (a -> (a, a))) -#endif +quoteQuotRem :: (MulHi a, Lift a, Quote m) => a -> Code m (a -> (a, a)) quoteQuotRem d = [|| \w -> let q = $$(quoteQuot d) w in (q, w - d * q) ||] +-- | Similar to 'quoteQuot', but for 'div'. +-- +-- @since 0.2.2.0 +quoteDiv :: forall a m. (MulHi a, Lift a, MulHi (Unsigned a), Lift (Unsigned a), Quote m) => a -> Code m (a -> a) +quoteDiv d + | isSigned d + = [|| \(i :: a') -> let w2i = fromIntegral :: Unsigned a' -> a' in + if i < 0 + then w2i -(1 + $$go (fromIntegral -(i + 1))) + else w2i $ $$go (fromIntegral i) ||] + | otherwise = quoteQuot d + where + go :: Code m (Unsigned a -> Unsigned a) + go = quoteAST (unsignedQuot (fromIntegral d)) + +-- | Similar to 'quoteQuot', but for 'mod'. +-- +-- @since 0.2.2.0 +quoteMod :: (MulHi a, Lift a, MulHi (Unsigned a), Lift (Unsigned a), Quote m) => a -> Code m (a -> a) +quoteMod d = [|| snd . $$(quoteDivMod d) ||] + +-- | Similar to 'quoteQuot', but for 'divMod'. +-- +-- @since 0.2.2.0 +quoteDivMod :: (MulHi a, Lift a, MulHi (Unsigned a), Lift (Unsigned a), Quote m) => a -> Code m (a -> (a, a)) +quoteDivMod d = [|| \w -> let q = $$(quoteDiv d) w in (q, w - d * q) ||] + +-- | Associate the corresponding unsigned type. +-- +-- @since 0.2.2.0 +type family Unsigned t +type instance Unsigned Int = Word +type instance Unsigned Word = Word +type instance Unsigned Int8 = Word8 +type instance Unsigned Word8 = Word8 +type instance Unsigned Int16 = Word16 +type instance Unsigned Word16 = Word16 +type instance Unsigned Int32 = Word32 +type instance Unsigned Word32 = Word32 +type instance Unsigned Int64 = Word64 +type instance Unsigned Word64 = Word64 + -- | Types allowing to multiply wide and return the high word of result. class (Integral a, FiniteBits a) => MulHi a where mulHi :: a -> a -> a instance MulHi Word8 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Word16) `shiftR` 8) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 8) + where widen = fromIntegral :: Word8 -> Word16 instance MulHi Word16 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Word32) `shiftR` 16) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 16) + where widen = fromIntegral :: Word16 -> Word32 instance MulHi Word32 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Word64) `shiftR` 32) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 32) + where widen = fromIntegral :: Word32 -> Word64 -#if WORD_SIZE_IN_BITS == 64 +-- | This instance is not efficient on 32-bit architecture. instance MulHi Word64 where - mulHi x y = fromIntegral (fromIntegral x `mulHi` fromIntegral y :: Word) -#endif + mulHi x y + | finiteBitSize (0 :: Word) == 64 + = fromIntegral (fromIntegral x `mulHi` fromIntegral y :: Word) + | otherwise + = defaultMulHi x y instance MulHi Word where mulHi (W# x) (W# y) = let !(# hi, _ #) = timesWord2# x y in W# hi instance MulHi Int8 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Int16) `shiftR` 8) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 8) + where widen = fromIntegral :: Int8 -> Int16 instance MulHi Int16 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Int32) `shiftR` 16) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 16) + where widen = fromIntegral :: Int16 -> Int32 instance MulHi Int32 where - mulHi x y = fromIntegral ((fromIntegral x * fromIntegral y :: Int64) `shiftR` 32) + mulHi x y = fromIntegral ((widen x * widen y) `shiftR` 32) + where widen = fromIntegral :: Int32 -> Int64 -#if MIN_VERSION_base(4,15,0) -#if WORD_SIZE_IN_BITS == 64 +-- | This instance is not efficient on 32-bit architecture. instance MulHi Int64 where - mulHi x y = fromIntegral (fromIntegral x `mulHi` fromIntegral y :: Int) -#endif + mulHi x y + | finiteBitSize (0 :: Int) == 64 + = fromIntegral (fromIntegral x `mulHi` fromIntegral y :: Int) + | otherwise + = defaultMulHi x y instance MulHi Int where mulHi (I# x) (I# y) = let !(# _, hi, _ #) = timesInt2# x y in I# hi -#endif -- | An abstract syntax tree to represent -- a function of one argument. @@ -191,7 +233,7 @@ where go = \case Arg -> n - MulHi x k -> fromInteger $ (toInteger (go x) * toInteger k) `shiftR` finiteBitSize k + MulHi x k -> defaultMulHi (go x) k MulLo x k -> go x * k Add x y -> go x + go y Sub x y -> go x - go y @@ -200,13 +242,17 @@ CmpGE x k -> if go x >= k then 1 else 0 CmpLT x k -> if go x < k then 1 else 0 +defaultMulHi :: (Integral a, FiniteBits a) => a -> a -> a +defaultMulHi x y = + fromInteger $ (toInteger x * toInteger y) `shiftR` finiteBitSize x + +iprop :: Integral a => (a -> Bool) -> a -> a +iprop p = \i -> fromIntegral (I# (dataToTag# (p i))) +{-# INLINE iprop #-} + + -- | Embed 'AST' into Haskell expression. -quoteAST :: -#if MIN_VERSION_template_haskell(2,17,0) - (MulHi a, Lift a, Quote m) => AST a -> Code m (a -> a) -#else - (MulHi a, Lift a) => AST a -> Q (TExp (a -> a)) -#endif +quoteAST :: (MulHi a, Lift a, Quote m) => AST a -> Code m (a -> a) quoteAST = \case Arg -> [|| id ||] Shr x k -> [|| (`shiftR` k) . $$(quoteAST x) ||] @@ -215,8 +261,8 @@ MulLo x k -> [|| (* k) . $$(quoteAST x) ||] Add x y -> [|| \w -> $$(quoteAST x) w + $$(quoteAST y) w ||] Sub x y -> [|| \w -> $$(quoteAST x) w - $$(quoteAST y) w ||] - CmpGE x k -> [|| (\w -> fromIntegral (I# (dataToTag# (w >= k)))) . $$(quoteAST x) ||] - CmpLT x k -> [|| (\w -> fromIntegral (I# (dataToTag# (w < k)))) . $$(quoteAST x) ||] + CmpGE x k -> [|| iprop (>= k) . $$(quoteAST x) ||] + CmpLT x k -> [|| iprop (< k) . $$(quoteAST x) ||] -- | 'astQuot' @d@ constructs an 'AST' representing -- a function, equivalent to 'quot' @a@ for positive @a@, @@ -255,16 +301,17 @@ = CmpGE Arg k' -- Hacker's Delight, 10-8, Listing 1 | k >= 1 `shiftL` shft - = shr (MulHi Arg magic) (shft + kZeros) + = shr (MulHi Arg magic) shft' -- Hacker's Delight, 10-8, Listing 3 | otherwise - = shr (Add (shr (Sub Arg (MulHi Arg magic)) 1) (MulHi Arg magic)) (shft - 1 + kZeros) + = shr (Add (shr (Sub Arg (MulHi Arg magic)) 1) (MulHi Arg magic)) (shft' - 1) where fbs = finiteBitSize k' kZeros = countTrailingZeros k' k = k' `shiftR` kZeros r0 = fromInteger ((1 `shiftL` fbs) `rem` toInteger k) shft = go r0 0 + shft' = shft + kZeros magic = fromInteger ((1 `shiftL` (fbs + shft)) `quot` toInteger k + 1) go r s @@ -286,16 +333,17 @@ = Sub (CmpGE Arg k') (CmpLT Arg (1 - k')) -- Hacker's Delight, 10-3, Listing 2 | magic >= 0 - = Add (shr (MulHi Arg magic) (shft + kZeros)) (CmpLT Arg 0) + = Add (shr (MulHi Arg magic) shft') (CmpLT Arg 0) -- Hacker's Delight, 10-3, Listing 3 | otherwise - = Add (shr (Add Arg (MulHi Arg magic)) (shft + kZeros)) (CmpLT Arg 0) + = Add (shr (Add Arg (MulHi Arg magic)) shft') (CmpLT Arg 0) where fbs = finiteBitSize k' kZeros = countTrailingZeros k' k = k' `shiftR` kZeros r0 = fromInteger ((1 `shiftL` fbs) `rem` toInteger k) shft = go r0 0 + shft' = shft + kZeros magic = fromInteger ((1 `shiftL` (fbs + shft)) `quot` toInteger k + 1) go r s diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -19,7 +19,6 @@ import Numeric.QuoteQuot import Test.Tasty import Test.Tasty.QuickCheck -import Text.Printf #ifdef MIN_VERSION_word24 import Data.Int.Int24 @@ -31,7 +30,7 @@ #endif main :: IO () -main = defaultMain $ testGroup "All" [testAst, testQuotes] +main = defaultMain $ testGroup "All" [testAst, testQuotes, testDivs, testMulHi] testAst :: TestTree testAst = testGroup "Ast" @@ -53,6 +52,7 @@ , testGroup "Word128" (mkTests (Proxy @Word128)) , testGroup "Word256" (mkTests (Proxy @Word256)) , testGroup "Int128" (mkTests (Proxy @Int128)) + , testGroup "Int256" (mkTests (Proxy @Int256)) #endif ] @@ -77,24 +77,22 @@ prop :: (Integral a, FiniteBits a, Show a) => a -> Positive a -> Property -prop x (Positive y) = counterexample - (printf - "%s `quot` %s = %s /= %s = eval (%s) %s" - (show x) (show y) (show ref) (show q) (show ast) (show x)) - (q == ref) +prop x (Positive y) = + (q === qref) .&&. (d === dref) where - ref = x `quot` y - ast = astQuot y - q = interpretAST ast x + qref = x `quot` y + dref = x `div` y + qast = astQuot y + dast = assumeNonNegArg (astQuot y) + q = interpretAST qast x + d | x < 0 = -(interpretAST dast (-(x + 1)) + 1) + | otherwise = q propNonNeg :: (Integral a, FiniteBits a, Show a) => NonNegative a -> Positive a -> Property -propNonNeg (NonNegative x) (Positive y) = counterexample - (printf - "%s `quot` %s = %s /= %s = eval (%s) %s" - (show x) (show y) (show ref) (show q) (show ast) (show x)) - (q == ref) +propNonNeg (NonNegative x) (Positive y) = + q === ref where ref = x `quot` y ast = assumeNonNegArg $ astQuot y @@ -109,6 +107,7 @@ instance Arbitrary Word128 where arbitrary = arbitrarySizedBoundedIntegral instance Arbitrary Word256 where arbitrary = arbitrarySizedBoundedIntegral instance Arbitrary Int128 where arbitrary = arbitrarySizedBoundedIntegral +instance Arbitrary Int256 where arbitrary = arbitrarySizedBoundedIntegral #endif #define testQuotes(ty) \ @@ -124,25 +123,88 @@ , testProperty "10" $ \x -> $$(quoteQuotRem (10 :: ty)) x === x `quotRem` 10 \ , testProperty "maxBound" $ \x -> $$(quoteQuotRem (maxBound :: ty)) x === x `quotRem` maxBound \ , testProperty "maxBound - 1" $ \x -> $$(quoteQuotRem (maxBound - 1 :: ty)) x === x `quotRem` (maxBound - 1) \ - ] \ + ] +#define testDivs(ty) \ + [ testProperty "1" $ \x -> $$(quoteDivMod (1 :: ty)) x === x `divMod` 1 \ + , testProperty "2" $ \x -> $$(quoteDivMod (2 :: ty)) x === x `divMod` 2 \ + , testProperty "3" $ \x -> $$(quoteDivMod (3 :: ty)) x === x `divMod` 3 \ + , testProperty "4" $ \x -> $$(quoteDivMod (4 :: ty)) x === x `divMod` 4 \ + , testProperty "5" $ \x -> $$(quoteDivMod (5 :: ty)) x === x `divMod` 5 \ + , testProperty "6" $ \x -> $$(quoteDivMod (6 :: ty)) x === x `divMod` 6 \ + , testProperty "7" $ \x -> $$(quoteDivMod (7 :: ty)) x === x `divMod` 7 \ + , testProperty "8" $ \x -> $$(quoteDivMod (8 :: ty)) x === x `divMod` 8 \ + , testProperty "9" $ \x -> $$(quoteDivMod (9 :: ty)) x === x `divMod` 9 \ + , testProperty "10" $ \x -> $$(quoteDivMod (10 :: ty)) x === x `divMod` 10 \ + , testProperty "maxBound" $ \x -> $$(quoteDivMod (maxBound :: ty)) x === x `divMod` maxBound \ + , testProperty "maxBound - 1" $ \x -> $$(quoteDivMod (maxBound - 1 :: ty)) x === x `divMod` (maxBound - 1) \ + ] + testQuotes :: TestTree testQuotes = testGroup "Quotes" [ testGroup "Word8" testQuotes(Word8) , testGroup "Word16" testQuotes(Word16) , testGroup "Word32" testQuotes(Word32) -#if WORD_SIZE_IN_BITS == 64 , testGroup "Word64" testQuotes(Word64) -#endif , testGroup "Word" testQuotes(Word) - , testGroup "Int8" testQuotes(Int8) , testGroup "Int16" testQuotes(Int16) , testGroup "Int32" testQuotes(Int32) -#if MIN_VERSION_base(4,15,0) -#if WORD_SIZE_IN_BITS == 64 , testGroup "Int64" testQuotes(Int64) -#endif , testGroup "Int" testQuotes(Int) -#endif ] + +testDivs :: TestTree +testDivs = testGroup "Divs" + [ testGroup "Word8" testDivs(Word8) + , testGroup "Word16" testDivs(Word16) + , testGroup "Word32" testDivs(Word32) + , testGroup "Word64" testDivs(Word64) + , testGroup "Word" testDivs(Word) + , testGroup "Int8" testDivs(Int8) + , testGroup "Int16" testDivs(Int16) + , testGroup "Int32" testDivs(Int32) + , testGroup "Int64" testDivs(Int64) + , testGroup "Int" testDivs(Int) + ] + +testMulHi :: TestTree +testMulHi = testGroup "MulHi" + [ testGroup "Word" (mkTestsMulHi (Proxy @Word)) + , testGroup "Word8" (mkTestsMulHi (Proxy @Word8)) + , testGroup "Word16" (mkTestsMulHi (Proxy @Word16)) + , testGroup "Word32" (mkTestsMulHi (Proxy @Word32)) + , testGroup "Word64" (mkTestsMulHi (Proxy @Word64)) + , testGroup "Int" (mkTestsMulHi (Proxy @Int)) + , testGroup "Int8" (mkTestsMulHi (Proxy @Int8)) + , testGroup "Int16" (mkTestsMulHi (Proxy @Int16)) + , testGroup "Int32" (mkTestsMulHi (Proxy @Int32)) + , testGroup "Int64" (mkTestsMulHi (Proxy @Int64)) + ] + +mkTestsMulHi + :: forall a. + (MulHi a, Show a, Bounded a, Arbitrary a) + => Proxy a -> [TestTree] +mkTestsMulHi _ = [ combineMods mod1 mod2 | mod1 <- mods, mod2 <- mods] + where + mods :: [(String, a -> Bool, a -> a)] + mods + | isSigned (undefined :: a) = + [ ("above zero", (>= 0), id) + , ("below zero", (>= 0), negate) + , ("above minBound", (>= 0), (minBound +)) + , ("below maxBound", (>= 0), (maxBound -)) + ] + | otherwise = + [ ("above zero", const True, id) + , ("below maxBound", const True, (maxBound -)) + ] + + combineMods (name1, pred1, tr1) (name2, pred2, tr2) = + testProperty (name1 ++ ", " ++ name2) $ + \x y -> pred1 x && pred2 y ==> propMulHi (tr1 x) (tr2 y) + +propMulHi :: (MulHi a, Show a) => a -> a -> Property +propMulHi x y = mulHi x y === + fromInteger ((toInteger x * toInteger y) `shiftR` finiteBitSize x)