summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE30
-rw-r--r--README.md12
-rw-r--r--Setup.hs2
-rw-r--r--bench/Bench.hs45
-rw-r--r--intset-imperative.cabal69
-rw-r--r--src/Data/IntSet/Bounded/Imperative.hs155
-rw-r--r--test-fixed/Spec.hs36
-rw-r--r--test-random/Spec.hs80
8 files changed, 429 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..02531eb
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Henri Verroken (c) 2018
+
+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 Henri Verroken 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
index 0000000..301212d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,12 @@
+# intset-imperative
+
+[![Travis](https://travis-ci.org/hverr/haskell-intset-imperative.svg?branch=master)](https://travis-ci.org/hverr/haskell-intset-imperative)
+[![Hackage](https://img.shields.io/hackage/v/intset-imperative.svg?maxAge=600)](https://hackage.haskell.org/package/intset-imperative)
+[![Stackage Nightly](http://stackage.org/package/intset-imperative/badge/nightly)](http://stackage.org/nightly/package/intset-imperative)
+[![Stackage LTS](http://stackage.org/package/intset-imperative/badge/lts)](http://stackage.org/lts/package/intset-imperative)
+
+
+An imperative integer set written in Haskell.
+
+## Extra resources
+- Blog Post: [*Making Haskell as fast as C: Imperative programming in Haskell*](https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bench/Bench.hs b/bench/Bench.hs
new file mode 100644
index 0000000..d57f390
--- /dev/null
+++ b/bench/Bench.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+
+import Control.Monad
+
+import Criterion.Main
+
+import Data.Word
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+import System.Random
+
+main :: IO ()
+main = defaultMain [
+ bgroup "intset" [ let n = 1000; !v = generateInts 0 n (fromIntegral n) in bench (show n) $ whnfIO (benchIntset 0 n v)
+ , let n = 10*1000; !v = generateInts 0 n (fromIntegral n) in bench (show n) $ whnfIO (benchIntset 0 n v)
+ , let n = 100*1000; !v = generateInts 0 n (fromIntegral n) in bench (show n) $ whnfIO (benchIntset 0 n v)
+ , let n = 1000*1000; !v = generateInts 0 n (fromIntegral n) in bench (show n) $ whnfIO (benchIntset 0 n v)
+ , let n = 10*1000*1000; !v = generateInts 0 n (fromIntegral n) in bench (show n) $ whnfIO (benchIntset 0 n v)
+ ]
+ ]
+
+benchIntset :: Word64
+ -> Word64
+ -> Vector Word64
+ -> IO ()
+benchIntset minB maxB xs = do
+ s <- BIS.empty minB maxB
+ forM_ xs $ \i -> do
+ BIS.insert s i
+ f <- BIS.member s i
+ unless f $
+ throwIO $ userError "implementation errors"
+
+generateInts :: Word64
+ -> Word64
+ -> Int
+ -> Vector Word64
+generateInts minB maxB n =
+ V.fromList . take n $ randomRs (minB, maxB) (mkStdGen 0x214f36c9)
diff --git a/intset-imperative.cabal b/intset-imperative.cabal
new file mode 100644
index 0000000..6ab39a8
--- /dev/null
+++ b/intset-imperative.cabal
@@ -0,0 +1,69 @@
+name: intset-imperative
+version: 0.1.0.0
+description:
+ An imperative integer set written in Haskell.
+ .
+ Read <https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html> for more information.
+synopsis: An imperative integer set written in Haskell.
+homepage: https://github.com/hverr/haskell-intset-imperative#readme
+bug-reports: https://github.com/hverr/haskell-intset-imperative/issues
+author: Henri Verroken
+maintainer: henriverroken@gmail.com
+copyright: 2018 Henri Verroken
+license: BSD3
+license-file: LICENSE
+category: Data Structures
+build-type: Simple
+cabal-version: >= 1.10
+extra-source-files:
+ README.md
+
+source-repository head
+ type: git
+ location: https://github.com/hverr/intset-imperative
+
+library
+ exposed-modules: Data.IntSet.Bounded.Imperative
+ hs-source-dirs: src
+ build-depends: base >=4.7 && <5
+ , deepseq
+ , primitive
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+test-suite intset-imperative-test-random
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test-random
+ build-depends: base >=4.7 && <5
+ , intset-imperative
+ , mtl
+ , primitive
+ , random
+ , transformers
+ , unordered-containers
+ default-language: Haskell2010
+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+
+test-suite intset-imperative-test-fixed
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs: test-fixed
+ build-depends: base >=4.7 && <5
+ , intset-imperative
+ default-language: Haskell2010
+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+
+benchmark intset-imperative-bench
+ type: exitcode-stdio-1.0
+ hs-source-dirs: bench
+ main-is: Bench.hs
+ build-depends: base
+ , intset-imperative
+ , containers
+ , criterion
+ , random
+ , unordered-containers
+ , vector
+ ghc-options: -Wall -O2
+ default-language: Haskell2010
diff --git a/src/Data/IntSet/Bounded/Imperative.hs b/src/Data/IntSet/Bounded/Imperative.hs
new file mode 100644
index 0000000..d3f09d6
--- /dev/null
+++ b/src/Data/IntSet/Bounded/Imperative.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+-- | An imperative integer set written in Haskell.
+--
+-- See \"/Making Haskell as fast as C: Imperative programming in Haskell/\" for a more detailed discussion, <https://deliquus.com/posts/2018-07-30-imperative-programming-in-haskell.html>.
+module Data.IntSet.Bounded.Imperative (
+ -- * Types
+ IntSet
+, IOIntSet
+, intSetMinBound
+, intSetMaxBound
+
+ -- * Construction
+, empty
+
+ -- * Insertion
+, insert
+
+ -- * Query
+, member
+, notMember
+
+ -- * Deletion
+, delete
+) where
+
+import Control.DeepSeq (deepseq)
+import Control.Monad.Primitive (PrimMonad(..))
+import Control.Monad.ST (ST)
+
+import Data.Bits
+import Data.Primitive.ByteArray
+import Data.Primitive.MutVar
+import Data.Word (Word64)
+
+-- | A strict bounded integer set.
+--
+-- The set is very efficient when accessing elements within the bounds
+-- of the set. It uses a regular list to hold numbers outside of this
+-- range.
+--
+-- The type parameter @s@ is determined by the monad the data structure
+-- lives in.
+data IntSet s = IntSet {
+ intSetMinBound# :: {-# UNPACK #-} !Word64
+ , intSetMaxBound# :: {-# UNPACK #-} !Word64
+ , intSetInBounds# :: {-# UNPACK #-} !(MutableByteArray s)
+ , intSetOutBounds# :: {-# UNPACK #-} !(MutVar s [Word64])
+ }
+
+-- | An 'IntSet' inside the 'IO' monad.
+type IOIntSet = IntSet (PrimState IO)
+
+-- | Get the minimum efficient bound of the integer set.
+intSetMinBound :: IntSet s -> Word64
+intSetMinBound = intSetMinBound#
+{-# INLINE intSetMinBound #-}
+
+-- | Get the maximum efficient bound of the integer set.
+intSetMaxBound :: IntSet s -> Word64
+intSetMaxBound = intSetMaxBound#
+{-# INLINE intSetMaxBound #-}
+
+-- | Construct an empty integer set.
+empty :: PrimMonad m
+ => Word64 -- ^ Minimum bound of the integer set
+ -> Word64 -- ^ Maximum bound of the integer set
+ -> m (IntSet (PrimState m))
+empty !minB !maxB = do
+ let !numInBounds = (maxB - minB) `div` 8 + 1
+ set <- newByteArray (fromIntegral numInBounds)
+ fillByteArray set 0 (fromIntegral numInBounds) 0
+ outBounds <- newMutVar []
+ return $! IntSet {
+ intSetMinBound# = minB
+ , intSetMaxBound# = maxB
+ , intSetInBounds# = set
+ , intSetOutBounds# = outBounds
+ }
+{-# SPECIALIZE empty :: Word64 -> Word64 -> IO (IntSet (PrimState IO)) #-}
+{-# SPECIALIZE empty :: Word64 -> Word64 -> ST s (IntSet s) #-}
+
+-- | Insert the integer in a set.
+insert :: PrimMonad m
+ => IntSet (PrimState m)
+ -> Word64
+ -> m ()
+insert !set !n = do
+ if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+ let !n' = n - intSetMinBound# set
+ let !o = fromIntegral $ n' `shiftR` 6
+ let !i = fromIntegral $ n' .&. 63
+ let !mask = (1 :: Word64) `shiftL` i
+ b <- readByteArray (intSetInBounds# set) o
+ let !b' = b .|. mask
+ writeByteArray (intSetInBounds# set) o b'
+
+ else do
+ ns <- readMutVar (intSetOutBounds# set)
+ let !ns' = if n `elem` ns then ns else (n:ns)
+ writeMutVar (intSetOutBounds# set) ns'
+{-# SPECIALIZE insert :: IntSet (PrimState IO) -> Word64 -> IO () #-}
+{-# SPECIALIZE insert :: IntSet s -> Word64 -> ST s () #-}
+
+-- | Delete the integer from the set.
+delete :: PrimMonad m
+ => IntSet (PrimState m)
+ -> Word64
+ -> m ()
+delete !set !n = do
+ if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+ let !n' = n - intSetMinBound# set
+ let !o = fromIntegral $ n' `shiftR` 6
+ let !i = fromIntegral $ n' .&. 63
+ let !mask = (1 :: Word64) `shiftL` i
+ b <- readByteArray (intSetInBounds# set) o
+ let !b' = b .&. (complement mask)
+ writeByteArray (intSetInBounds# set) o b'
+
+ else do
+ ns <- readMutVar (intSetOutBounds# set)
+ let ns' = filter (/= n) ns
+ ns' `deepseq` writeMutVar (intSetOutBounds# set) ns'
+{-# SPECIALIZE delete :: IntSet (PrimState IO) -> Word64 -> IO () #-}
+{-# SPECIALIZE delete :: IntSet s -> Word64 -> ST s () #-}
+
+-- | Is the integer in the set?
+member :: PrimMonad m
+ => IntSet (PrimState m)
+ -> Word64
+ -> m Bool
+member !set !n = do
+ if n >= intSetMinBound# set && n <= intSetMaxBound# set then do
+ let !n' = n - intSetMinBound# set
+ let !o = fromIntegral $ n' `shiftR` 6
+ let !i = fromIntegral $ n' .&. 63
+ let !mask = (1 :: Word64) `shiftL` i
+ b <- readByteArray (intSetInBounds# set) o
+ return $! (b .&. mask) /= 0
+
+ else do
+ ns <- readMutVar (intSetOutBounds# set)
+ return $! n `elem` ns
+{-# SPECIALIZE member :: IntSet (PrimState IO) -> Word64 -> IO Bool #-}
+{-# SPECIALIZE member :: IntSet s -> Word64 -> ST s Bool #-}
+
+-- | Is the integer not in the set?
+notMember :: PrimMonad m
+ => IntSet (PrimState m)
+ -> Word64
+ -> m Bool
+notMember !set !n = not <$> member set n
+{-# INLINE notMember #-}
+{-# SPECIALIZE notMember :: IntSet (PrimState IO) -> Word64 -> IO Bool #-}
+{-# SPECIALIZE notMember :: IntSet s -> Word64 -> ST s Bool #-}
diff --git a/test-fixed/Spec.hs b/test-fixed/Spec.hs
new file mode 100644
index 0000000..9104d57
--- /dev/null
+++ b/test-fixed/Spec.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+
+import Data.Word
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+main :: IO ()
+main = do
+ let minB = 1000
+ minC = minB - 100
+ let maxB = 2000
+ maxC = maxB + 100
+ set <- BIS.empty minB maxB
+ forM_ [minC..maxC] $ \n ->
+ pass set minC maxC n
+
+pass :: BIS.IOIntSet -> Word64 -> Word64 -> Word64 -> IO ()
+pass !set !minC !maxC !n = do
+ when ((maxC - n) `rem` 100 == 0) $
+ print (maxC - n)
+
+ BIS.delete set (n-1)
+ BIS.insert set n
+
+ forM_ [minC..maxC] $ \i -> do
+ f <- BIS.member set i
+ unless ((not f && (i /= n)) || (f && (i == n))) $
+ throwIO . TestError $ "test error at " ++ show (n, i)
+
+data TestError = TestError String deriving (Show)
+
+instance Exception TestError
diff --git a/test-random/Spec.hs b/test-random/Spec.hs
new file mode 100644
index 0000000..b875a43
--- /dev/null
+++ b/test-random/Spec.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Primitive
+import Control.Monad.State
+
+import Data.HashSet (HashSet)
+import Data.Word
+import qualified Data.HashSet as HS
+
+import qualified Data.IntSet.Bounded.Imperative as BIS
+
+import System.Random
+
+main :: IO ()
+main = evalStateT testOnce (mkStdGen 0x28761967)
+
+testOnce :: StateT StdGen IO ()
+testOnce = do
+ let minB = 0
+ let maxB = 1*1000
+
+ let newRand :: StateT StdGen IO Word64
+ newRand = do
+ f <- getRandom
+ if f then getRandom else getRandomR (minB, maxB)
+
+ doAll 1000 HS.empty newRand =<< liftIO (BIS.empty minB maxB)
+
+ liftIO $ putStrLn "Success"
+ where
+ doAll :: Int -> HashSet Word64 -> StateT StdGen IO Word64 -> BIS.IntSet (PrimState IO) -> StateT StdGen IO ()
+ doAll !k !s' newRand s
+ | k <= 0 = return ()
+ | otherwise = do
+ when (k `rem` 100 == 0) $
+ liftIO $ print k
+
+ forM_ (HS.toList s') $ \n -> do
+ f <- liftIO $ BIS.member s n
+ unless f $
+ liftIO . throwIO $ TestError "added number did not return true"
+
+ replicateM_ 100 $ do
+ n <- getRandom
+ f <- liftIO $ BIS.member s n
+ let g = HS.member n s'
+ when (g /= f) $
+ liftIO . throwIO $ TestError "random number did not match"
+
+ n <- newRand
+ liftIO $ BIS.insert s n
+
+ m <- newRand
+ liftIO $ BIS.delete s m
+
+ doAll (k-1) (HS.delete m $ HS.insert n s') newRand s
+
+
+getRandom :: (MonadState g m, RandomGen g, Random a) => m a
+getRandom = do
+ g <- get
+ let (!x, !h) = random g
+ put h
+ return x
+
+getRandomR :: (MonadState g m, RandomGen g, Random a) => (a, a) -> m a
+getRandomR b = do
+ g <- get
+ let (!x, !h) = randomR b g
+ put h
+ return x
+
+
+data TestError = TestError String deriving (Show)
+
+instance Exception TestError