diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Lelechenko (c) 2020 + +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 name of Andrew Lelechenko nor the names of other + 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,79 @@ +# quote-quot [![Hackage](http://img.shields.io/hackage/v/quote-quot.svg)](https://hackage.haskell.org/package/quote-quot) [![Stackage LTS](http://stackage.org/package/quote-quot/badge/lts)](http://stackage.org/lts/package/quote-quot) [![Stackage Nightly](http://stackage.org/package/quote-quot/badge/nightly)](http://stackage.org/nightly/package/quote-quot) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/quote-quot/badge)](https://matrix.hackage.haskell.org/package/quote-quot) [![GitHub Actions](https://github.com/Bodigrim/quote-quot/workflows/ci/badge.svg)](https://github.com/Bodigrim/quote-quot/actions?query=workflow%3Aci) + +Generate routines for integer division, employing arithmetic +and bitwise operations only, which are __2.5x-3.5x faster__ +than `quot`. Divisors must be known +in compile-time and be positive. + +```haskell +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices -ddump-simpl -dsuppress-all #-} +import Numeric.QuoteQuot + +-- Equivalent to (`quot` 10). +quot10 :: Word -> Word +quot10 = $$(quoteQuot 10) +``` + +```haskell +>>> quot10 123 +12 +``` + +Here `-ddump-splices` demonstrates the chosen implementation +for division by 10: + +```haskell +Splicing expression quoteQuot 10 ======> +((`shiftR` 3) . ((\ (W# w_a9N4) -> + let !(# hi_a9N5, _ #) = (timesWord2# w_a9N4) 14757395258967641293## + in W# hi_a9N5) . id)) +``` + +And `-ddump-simpl` demonstrates generated Core: + +```haskell + quot10 = \ x_a5t2 -> + case x_a5t2 of { W# w_acHY -> + case timesWord2# w_acHY 14757395258967641293## of + { (# hi_acIg, ds_dcIs #) -> + W# (uncheckedShiftRL# hi_acIg 3#) + } + } +``` + +Benchmarks show that this implementation is __3.5x faster__ + than ``(`quot` 10)``: + +```haskell +{-# LANGUAGE TemplateHaskell #-} +import Data.List +import Numeric.QuoteQuot +import System.CPUTime + +measure :: String -> (Word -> Word) -> IO () +measure name f = do + t0 <- getCPUTime + print $ foldl' (+) 0 $ map f [0..100000000] + t1 <- getCPUTime + putStrLn $ name ++ " " ++ show ((t1 - t0) `quot` 1000000000) ++ " ms" +{-# INLINE measure #-} + +main :: IO () +main = do + measure " (`quot` 10)" (`quot` 10) + measure "$$(quoteQuot 10)" $$(quoteQuot 10) +``` + +``` +499999960000000 + (`quot` 10) 316 ms +499999960000000 +$$(quoteQuot 10) 89 ms +``` + +Common wisdom is that such microoptimizations are negligible in practice, +but this is not always the case. For instance, quite surprisingly, +this trick alone +[made Unicode normalization of Hangul characters twice faster](https://github.com/composewell/unicode-transforms/pull/42) +in [`unicode-transforms`](http://hackage.haskell.org/package/unicode-transforms). diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,25 @@ +-- | +-- Copyright: (c) 2020 Andrew Lelechenko +-- Licence: BSD3 +-- + +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import Data.List +import Numeric.QuoteQuot +import System.CPUTime + +measure :: String -> (Word -> Word) -> IO () +measure name f = do + t0 <- getCPUTime + print $ foldl' (+) 0 $ map f [0..100000000] + t1 <- getCPUTime + putStrLn $ name ++ " " ++ show ((t1 - t0) `quot` 1000000000) ++ " ms" +{-# INLINE measure #-} + +main :: IO () +main = do + measure " (`quot` 10)" (`quot` 10) + measure "$$(quoteQuot 10)" $$(quoteQuot 10) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial release. diff --git a/quote-quot.cabal b/quote-quot.cabal new file mode 100644 --- /dev/null +++ b/quote-quot.cabal @@ -0,0 +1,60 @@ +cabal-version: >=1.10 +name: quote-quot +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +copyright: 2020 Andrew Lelechenko +maintainer: andrew.lelechenko@gmail.com +author: Andrew Lelechenko +tested-with: ghc ==8.10.3 +homepage: https://github.com/Bodigrim/divide#readme +synopsis: Divide without division +description: + Generate routines for integer division, employing arithmetic + and bitwise operations only, which are __2.5x-3.5x faster__ + than 'quot'. Divisors must be known in compile-time and be positive. + +category: Math, Numerical +build-type: Simple +extra-source-files: + changelog.md + README.md + +source-repository head + type: git + location: https://github.com/Bodigrim/quote-quot + +library + exposed-modules: Numeric.QuoteQuot + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base < 5, + template-haskell >=2.16 + +test-suite quote-quot-tests + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts + build-depends: + base, + quote-quot, + tasty, + tasty-quickcheck, + -- wide-word >=0.1.1.2, + -- 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 + build-depends: + base, + quote-quot, + template-haskell diff --git a/src/Numeric/QuoteQuot.hs b/src/Numeric/QuoteQuot.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/QuoteQuot.hs @@ -0,0 +1,230 @@ +-- | +-- Module: Numeric.QuoteQuot +-- Copyright: (c) 2020 Andrew Lelechenko +-- Licence: BSD3 +-- Maintainer: Andrew Lelechenko +-- +-- Generate routines for integer division, employing arithmetic +-- and bitwise operations only, which are __2.5x-3.5x faster__ +-- than 'quot'. Divisors must be known in compile-time and be positive. +-- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedTuples #-} + +module Numeric.QuoteQuot + ( + -- * Quasiquoters + quoteQuot + , quoteRem + , quoteQuotRem + -- * AST + , astQuot + , AST(..) + , interpretAST + ) where + +import Prelude +import Data.Bits +import GHC.Exts +import Language.Haskell.TH + +-- | 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 #-} +-- > {-# OPTIONS_GHC -ddump-splices -ddump-simpl -dsuppress-all #-} +-- > module Example where +-- > import Numeric.QuoteQuot +-- > +-- > -- Equivalent to (`quot` 10). +-- > quot10 :: Word -> Word +-- > quot10 = $$(quoteQuot 10) +-- +-- >>> quot10 123 +-- 12 +-- +-- Here @-ddump-splices@ demonstrates the chosen implementation +-- for division by 10: +-- +-- > Splicing expression quoteQuot 10 ======> +-- > ((`shiftR` 3) . ((\ (W# w_a9N4) -> +-- > let !(# hi_a9N5, _ #) = (timesWord2# w_a9N4) 14757395258967641293## +-- > in W# hi_a9N5) . id)) +-- +-- And @-ddump-simpl@ demonstrates generated Core: +-- +-- > quot10 = \ x_a5t2 -> +-- > case x_a5t2 of { W# w_acHY -> +-- > case timesWord2# w_acHY 14757395258967641293## of +-- > { (# hi_acIg, ds_dcIs #) -> +-- > W# (uncheckedShiftRL# hi_acIg 3#) +-- > } +-- > } +-- +-- Benchmarks show that this implementation is __3.5x faster__ +-- than @(`@'quot'@` 10)@. +-- +-- Note that even while 'astQuot' is polymorphic, +-- 'quoteQuot' is provided for 'Word' arguments only, +-- because other types lack a fast branchless routine for 'MulHi'. +-- For 'Word' such primitive is provided by 'timesWord2#'. +-- +quoteQuot :: Word -> Q (TExp (Word -> Word)) +quoteQuot d = go (astQuot d) + where + go :: AST Word -> Q (TExp (Word -> Word)) + go = \case + Arg -> [|| id ||] + Shr x k -> [|| (`shiftR` k) . $$(go x) ||] + Shl x k -> [|| (`shiftL` k) . $$(go x) ||] + MulHi x (W# k) -> [|| (\(W# w) -> let !(# hi, _ #) = timesWord2# w k in W# hi) . $$(go x) ||] + MulLo x k -> [|| (* k) . $$(go x) ||] + Add x y -> [|| \w -> $$(go x) w + $$(go y) w ||] + Sub x y -> [|| \w -> $$(go x) w - $$(go y) w ||] + CmpGE x (W# k) -> [|| (\(W# w) -> W# (int2Word# (w `geWord#` k))) . $$(go x) ||] + CmpLT x (W# k) -> [|| (\(W# w) -> W# (int2Word# (w `ltWord#` k))) . $$(go x) ||] + +-- | Similar to 'quoteQuot', but for 'rem'. +quoteRem :: Word -> Q (TExp (Word -> Word)) +quoteRem d = [|| snd . $$(quoteQuotRem d) ||] + +-- | Similar to 'quoteQuot', but for 'quotRem'. +quoteQuotRem :: Word -> Q (TExp (Word -> (Word, Word))) +quoteQuotRem d = [|| \w -> let q = $$(quoteQuot d) w in (q, w - d * q) ||] + +-- | An abstract syntax tree to represent +-- a function of one argument. +data AST a + = Arg + -- ^ Argument of the function + | MulHi (AST a) a + -- ^ Multiply wide and return the high word of result + | MulLo (AST a) a + -- ^ Multiply + | Add (AST a) (AST a) + -- ^ Add + | Sub (AST a) (AST a) + -- ^ Subtract + | Shl (AST a) Int + -- ^ Shift left + | Shr (AST a) Int + -- ^ Shift right with sign extension + | CmpGE (AST a) a + -- ^ 1 if greater than or equal, 0 otherwise + | CmpLT (AST a) a + -- ^ 1 if less than, 0 otherwise + deriving (Show) + +-- | Reference (but slow) interpreter of 'AST'. +-- It is not meant to be used in production +-- and is provided primarily for testing purposes. +-- +-- >>> interpretAST (astQuot (10 :: Data.Word.Word8)) 123 +-- 12 +-- +interpretAST :: (Integral a, FiniteBits a) => AST a -> (a -> a) +interpretAST ast n = go ast + where + go = \case + Arg -> n + MulHi x k -> fromInteger $ (toInteger (go x) * toInteger k) `shiftR` finiteBitSize k + MulLo x k -> go x * k + Add x y -> go x + go y + Sub x y -> go x - go y + Shl x k -> go x `shiftL` k + Shr x k -> go x `shiftR` k + CmpGE x k -> if go x >= k then 1 else 0 + CmpLT x k -> if go x < k then 1 else 0 + +-- | 'astQuot' @d@ constructs an 'AST' representing +-- a function, equivalent to 'quot' @a@ for positive @a@, +-- but avoiding division instructions. +-- +-- >>> astQuot (10 :: Data.Word.Word8) +-- Shr (MulHi Arg 205) 3 +-- +-- And indeed to divide 'Data.Word.Word8' by 10 +-- one can multiply it by 205, take the high byte and +-- shift it right by 3. Somewhat counterintuitively, +-- this sequence of operations is faster than a single +-- division on most modern achitectures. +-- +-- 'astQuot' function is polymorphic and supports both signed +-- and unsigned operands of arbitrary finite bitness. +-- Implementation is based on +-- Ch. 10 of Hacker's Delight by Henry S. Warren, 2012. +-- +astQuot :: (Integral a, FiniteBits a) => a -> AST a +astQuot k + | isSigned k = signedQuot k + | otherwise = unsignedQuot k + +unsignedQuot :: (Integral a, FiniteBits a) => a -> AST a +unsignedQuot k' + | isSigned k + = error "unsignedQuot works for unsigned types only" + | k' == 0 + = error "divisor must be positive" + | k' == 1 + = Arg + | k == 1 + = shr Arg kZeros + | k' >= 1 `shiftL` (fbs - 1) + = CmpGE Arg k' + -- Hacker's Delight, 10-8, Listing 1 + | k >= 1 `shiftL` shft + = shr (MulHi Arg magic) (shft + kZeros) + -- Hacker's Delight, 10-8, Listing 3 + | otherwise + = shr (Add (shr (Sub Arg (MulHi Arg magic)) 1) (MulHi Arg magic)) (shft - 1 + kZeros) + where + fbs = finiteBitSize k' + kZeros = countTrailingZeros k' + k = k' `shiftR` kZeros + r0 = fromInteger ((1 `shiftL` fbs) `rem` toInteger k) + shft = go r0 0 + magic = fromInteger ((1 `shiftL` (fbs + shft)) `quot` toInteger k + 1) + + go r s + | (k - r) < 1 `shiftL` s = s + | otherwise = go (r `shiftL` 1 `rem` k) (s + 1) + +signedQuot :: (Integral a, FiniteBits a) => a -> AST a +signedQuot k' + | not (isSigned k) + = error "signedQuot works for signed types only" + | k' <= 0 + = error "divisor must be positive" + | k' == 1 + = Arg + -- Hacker's Delight, 10-1, Listing 2 + | k == 1 + = shr (Add Arg (MulLo (CmpLT Arg 0) (k' - 1))) kZeros + | k' >= 1 `shiftL` (fbs - 2) + = 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) + -- Hacker's Delight, 10-3, Listing 3 + | otherwise + = Add (shr (Add Arg (MulHi Arg magic)) (shft + kZeros)) (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 + magic = fromInteger ((1 `shiftL` (fbs + shft)) `quot` toInteger k + 1) + + go r s + | (k - r) < 1 `shiftL` (s + 1) = s + | otherwise = go (r `shiftL` 1 `rem` k) (s + 1) + +shr :: AST a -> Int -> AST a +shr x 0 = x +shr x k = Shr x k diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,113 @@ +-- | +-- Copyright: (c) 2020 Andrew Lelechenko +-- Licence: BSD3 +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Data.Bits +import Data.Int +import Data.Proxy +import Data.Word +import Numeric.QuoteQuot +import Test.Tasty +import Test.Tasty.QuickCheck +import Text.Printf + +#ifdef MIN_VERSION_word24 +import Data.Int.Int24 +import Data.Word.Word24 +#endif + +#ifdef MIN_VERSION_wide_word +import Data.WideWord +#endif + +main :: IO () +main = defaultMain $ testGroup "All" [testAst, testQuotes] + +testAst :: TestTree +testAst = testGroup "Ast" + [ testGroup "Word" (mkTests (Proxy @Word)) + , testGroup "Word8" (mkTests (Proxy @Word8)) + , testGroup "Word16" (mkTests (Proxy @Word16)) + , testGroup "Word32" (mkTests (Proxy @Word32)) + , testGroup "Word64" (mkTests (Proxy @Word64)) + , testGroup "Int" (mkTests (Proxy @Int)) + , testGroup "Int8" (mkTests (Proxy @Int8)) + , testGroup "Int16" (mkTests (Proxy @Int16)) + , testGroup "Int32" (mkTests (Proxy @Int32)) + , testGroup "Int64" (mkTests (Proxy @Int64)) +#ifdef MIN_VERSION_word24 + , testGroup "Word24" (mkTests (Proxy @Word24)) + , testGroup "Int24" (mkTests (Proxy @Int24)) +#endif +#ifdef MIN_VERSION_wide_word + , testGroup "Word128" (mkTests (Proxy @Word128)) + , testGroup "Word256" (mkTests (Proxy @Word256)) + , testGroup "Int128" (mkTests (Proxy @Int128)) +#endif + ] + +mkTests + :: forall a. + (Integral a, FiniteBits a, Show a, Bounded a, Arbitrary a) + => Proxy a -> [TestTree] +mkTests _ + | isSigned (undefined :: a) = + [ testProperty "above zero" (prop @a . getNonNegative) + , testProperty "below zero" (prop @a . negate . getNonNegative) + , testProperty "above minBound" (prop @a . (minBound +) . getNonNegative) + , testProperty "below maxBound" (prop @a . (maxBound -) . getNonNegative) + ] + | otherwise = + [ testProperty "above zero" (prop @a) + , testProperty "below maxBound" (prop @a . (maxBound -)) + ] + +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) + where + ref = x `quot` y + ast = astQuot y + q = interpretAST ast x + +#ifdef MIN_VERSION_word24 +instance Arbitrary Word24 where arbitrary = arbitrarySizedBoundedIntegral +instance Arbitrary Int24 where arbitrary = arbitrarySizedBoundedIntegral +#endif + +#ifdef MIN_VERSION_wide_word +instance Arbitrary Word128 where arbitrary = arbitrarySizedBoundedIntegral +instance Arbitrary Word256 where arbitrary = arbitrarySizedBoundedIntegral +instance Arbitrary Int128 where arbitrary = arbitrarySizedBoundedIntegral +#endif + +testQuotes :: TestTree +testQuotes = testGroup "Quotes" + [ testProperty "1" $ \x -> $$(quoteQuotRem 1) x === x `quotRem` 1 + , testProperty "2" $ \x -> $$(quoteQuotRem 2) x === x `quotRem` 2 + , testProperty "3" $ \x -> $$(quoteQuotRem 3) x === x `quotRem` 3 + , testProperty "4" $ \x -> $$(quoteQuotRem 4) x === x `quotRem` 4 + , testProperty "5" $ \x -> $$(quoteQuotRem 5) x === x `quotRem` 5 + , testProperty "6" $ \x -> $$(quoteQuotRem 6) x === x `quotRem` 6 + , testProperty "7" $ \x -> $$(quoteQuotRem 7) x === x `quotRem` 7 + , testProperty "8" $ \x -> $$(quoteQuotRem 8) x === x `quotRem` 8 + , testProperty "9" $ \x -> $$(quoteQuotRem 9) x === x `quotRem` 9 + , testProperty "10" $ \x -> $$(quoteQuotRem 10) x === x `quotRem` 10 + , testProperty "maxBound" $ \x -> $$(quoteQuotRem maxBound) x === x `quotRem` maxBound + , testProperty "maxBound - 1" $ \x -> $$(quoteQuotRem (maxBound - 1)) x === x `quotRem` (maxBound - 1) + ]