diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -9,8 +9,8 @@ import Data.Word import System.Random (randomIO) -import Control.Loop (forLoop) -import Control.Loop.Internal (loop, unsafeLoop, numLoop) +import Control.Loop (forLoop, numLoop) +import Control.Loop.Internal (loop, unsafeLoop) main :: IO () diff --git a/bench/BenchFolds.hs b/bench/BenchFolds.hs new file mode 100644 --- /dev/null +++ b/bench/BenchFolds.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} + +module Main (main) where + +import Control.Monad.State.Strict +import Criterion.Main + +import Control.Loop (forLoop, forLoopFold, numLoopFold) + + +main :: IO () +main = do + + defaultMain + [ bgroup "pure" [ bench "sumFold" $ whnf sumFold 1000000 + , bench "sumFoldTooStrict" $ whnf sumFoldTooStrict 1000000 + , bench "numSumFold" $ whnf numSumFold 1000000 + ] + , bgroup "monadic" [ bench "sumFoldMonadic" $ whnf sumFoldMonadic 1000000 + ] + ] + + +-- This is too strict if you want to write something like this; +-- forLoopFold 0 (<4) (+1) (error "default should not be evaluated") (\acc x -> x) +-- Namely it evaluates acc0 even if it is never used. +-- See http://neilmitchell.blogspot.co.uk/2013/08/destroying-performance-with-strictness.html +forLoopFoldTooStrict :: a -> (a -> Bool) -> (a -> a) -> acc -> (acc -> a -> acc) -> acc +forLoopFoldTooStrict start cond inc acc0 f = go acc0 start + where + go !acc !x | cond x = go (f acc x) (inc x) + | otherwise = acc + +{-# INLINE forLoopFoldTooStrict #-} + + +sumFold :: Int -> Int +sumFold n = forLoopFold 0 (< n) (+1) 0 (+) + +sumFoldTooStrict :: Int -> Int +sumFoldTooStrict n = forLoopFoldTooStrict 0 (< n) (+1) 0 (+) + +sumFoldMonadic :: Int -> Int +sumFoldMonadic n = flip execState 0 $ do + forLoop 0 (< n) (+1) $ \i -> do + x <- get + put $! x + i + +numSumFold :: Int -> Int +numSumFold n = numLoopFold 0 (n - 1) 0 (+) -- numLoopFold is inclusive diff --git a/bench/FoldlAndIORefAreSlow.hs b/bench/FoldlAndIORefAreSlow.hs --- a/bench/FoldlAndIORefAreSlow.hs +++ b/bench/FoldlAndIORefAreSlow.hs @@ -6,6 +6,7 @@ import Criterion.Main import Data.List (foldl') import Data.IORef +import qualified Data.Vector as V import Data.Word @@ -18,9 +19,11 @@ [ bgroup "sum32" [ bench "sumW32loopIORef" $ nfIO (sumW32loopIORef 1000000) , bench "sumW32StrictState" $ whnf (\n -> execState (sumW32StrictState n) 0) 1000000 , bench "foldlW32" $ whnf (\n -> foldl' (+) 0 [0..n::Word32]) 1000000 + , bench "V.foldlW32" $ whnf (\n -> V.foldl' (+) 0 (V.enumFromTo 0 (n::Word32))) 1000000 , bench "sumIntloopIORef" $ nfIO (sumIntloopIORef 1000000) , bench "sumIntStrictState" $ whnf (\n -> execState (sumIntStrictState n) 0) 1000000 , bench "foldlInt" $ whnf (\n -> foldl' (+) 0 [0..n::Int]) 1000000 + , bench "V.foldlInt" $ whnf (\n -> V.foldl' (+) 0 (V.enumFromTo 0 (n::Int))) 1000000 ] ] diff --git a/bench/TraverseW32.hs b/bench/TraverseW32.hs --- a/bench/TraverseW32.hs +++ b/bench/TraverseW32.hs @@ -5,8 +5,8 @@ import Criterion.Main import Data.Word -import Control.Loop (forLoop) -import Control.Loop.Internal (loop, unsafeLoop, numLoop) +import Control.Loop (forLoop, numLoop) +import Control.Loop.Internal (loop, unsafeLoop) main :: IO () diff --git a/loop.cabal b/loop.cabal --- a/loop.cabal +++ b/loop.cabal @@ -1,5 +1,5 @@ name: loop -version: 0.1.0 +version: 0.2.0 license: MIT copyright: 2014 Niklas Hambüchen author: Niklas Hambüchen @@ -64,6 +64,21 @@ , criterion >= 0.6.0.0 , random >= 1.0.1.1 , vector >= 0.10.9.1 + ghc-options: + -Wall -O2 + + +benchmark bench-folds + type: exitcode-stdio-1.0 + hs-source-dirs: + bench + main-is: + BenchFolds.hs + build-depends: + base >= 4 && < 5 + , loop + , criterion >= 0.6.0.0 + , mtl >= 2.1.2 ghc-options: -Wall -O2 diff --git a/src/Control/Loop.hs b/src/Control/Loop.hs --- a/src/Control/Loop.hs +++ b/src/Control/Loop.hs @@ -26,6 +26,9 @@ -- @forLoop 1 (<= n) (+1)@. module Control.Loop ( forLoop + , forLoopFold + , numLoop + , numLoopFold ) where @@ -38,3 +41,48 @@ | otherwise = return () {-# INLINE forLoop #-} + + +-- | @forLoopFold start cond inc acc0 f@: A pure fold using a for loop +-- instead of a list for performance. +-- +-- Care is taken that @acc0@ not be strictly evaluated if unless done so by @f@. +forLoopFold :: a -> (a -> Bool) -> (a -> a) -> acc -> (acc -> a -> acc) -> acc +forLoopFold start cond inc acc0 f = go acc0 start + where + -- Not using !acc, see: + -- http://neilmitchell.blogspot.co.uk/2013/08/destroying-performance-with-strictness.html + go acc !x | cond x = let acc' = f acc x + in acc' `seq` go acc' (inc x) + | otherwise = acc + +{-# INLINE forLoopFold #-} + + +-- | @numLoop start end f@: Loops over a contiguous numerical range, including +-- @end@. +-- +-- It uses @(+ 1)@ so for most integer types it has no bounds (overflow) check. +numLoop :: (Num a, Eq a, Monad m) => a -> a -> (a -> m ()) -> m () +numLoop start end f = go start + where + go !x | x == end = f x + | otherwise = f x >> go (x+1) + +{-# INLINE numLoop #-} + + +-- | @numLoopFold start end acc0 f@: A pure fold over a contiguous numerical +-- range, including @end@. +-- +-- It uses @(+ 1)@ so for most integer types it has no bounds (overflow) check. +-- +-- Care is taken that @acc0@ not be strictly evaluated if unless done so by @f@. +numLoopFold :: (Num a, Eq a) => a -> a -> acc -> (acc -> a -> acc) -> acc +numLoopFold start end acc0 f = go acc0 start + where + go acc !x | x == end = f acc x + | otherwise = let acc' = f acc x + in acc' `seq` go acc' (x+1) + +{-# INLINE numLoopFold #-} diff --git a/src/Control/Loop/Internal.hs b/src/Control/Loop/Internal.hs --- a/src/Control/Loop/Internal.hs +++ b/src/Control/Loop/Internal.hs @@ -6,7 +6,6 @@ module Control.Loop.Internal ( loop , unsafeLoop - , numLoop ) where @@ -39,15 +38,3 @@ unsafeSucc = toEnum . (+ 1) . fromEnum {-# INLINE unsafeLoop #-} - - --- | Like `loop`, but using `Num` instead. --- --- It uses @(+ 1)@ so for most integer types it has no bounds (overflow) check. -numLoop :: (Num a, Eq a, Monad m) => a -> a -> (a -> m ()) -> m () -numLoop start end f = go start - where - go !x | x == end = f x - | otherwise = f x >> go (x+1) - -{-# INLINE numLoop #-} diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,7 +5,7 @@ import Data.Word import Test.Hspec -import Control.Loop (forLoop) +import Control.Loop (forLoop, numLoop, numLoopFold) main :: IO () @@ -13,6 +13,22 @@ describe "forLoop" $ do + it "sum [1..10], strict State" $ do + let res = flip execState 0 $ do + forLoop (1 :: Int) (<= 10) (+1) $ \i -> do + x <- get + put $! x + i + + res `shouldBe` sum [1..10] + + it "sum [-10..10], strict State" $ do + let res = flip execState 0 $ do + forLoop (-10 :: Int) (<= 10) (+1) $ \i -> do + x <- get + put $! x + i + + res `shouldBe` sum [-10..10] + it "over all of Word32, calculating sum, IORef" $ do ref <- newIORef 0 forLoop (0 :: Word32) (< maxBound) (+1) $ \i -> do @@ -35,3 +51,20 @@ put $! x + 1 res `shouldBe` (maxBound :: Word32) + + + describe "numLoop" $ do + + it "is inclusive" $ do + let res = flip execState 0 $ do + numLoop (0 :: Int) 10 $ \i -> do + x <- get + put $! x + i + + res `shouldBe` 55 + + + describe "numLoopFold" $ do + + it "is inclusive" $ do + numLoopFold (0 :: Int) 10 0 (+) `shouldBe` 55