diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = return () diff --git a/impure-containers.cabal b/impure-containers.cabal --- a/impure-containers.cabal +++ b/impure-containers.cabal @@ -1,5 +1,5 @@ name: impure-containers -version: 0.4.0 +version: 0.4.1 synopsis: Mutable containers in haskell description: Please see README.md homepage: https://github.com/andrewthad/impure-containers#readme @@ -25,7 +25,6 @@ -- Data.Heap.Mutable.ModelB Data.Heap.Mutable.ModelC Data.Heap.Mutable.ModelD - -- Data.Vector.Unique Data.Graph.Immutable Data.Graph.Mutable Data.Trie.Mutable.Bits @@ -37,6 +36,7 @@ Data.Primitive.Array.Maybe Data.Primitive.MutVar.Maybe Data.Primitive.Bool + Data.Maybe.Unsafe -- Data.Containers.Impure.Internal other-modules: Data.HashMap.Mutable.Internal.Array @@ -47,11 +47,11 @@ Data.HashMap.Mutable.Internal.UnsafeTricks Data.HashMap.Mutable.Internal.Utils build-depends: - base >= 4.7 && < 5 - , hashable - , primitive - , vector - , containers + base >= 4.8 && < 5 + , hashable >= 1.2 && < 1.3 + , primitive >= 0.6 && < 0.7 + , vector >= 0.11 && < 0.13 + , containers > 0.5 && < 0.6 , ghc-prim default-language: Haskell2010 @@ -124,6 +124,17 @@ , vector , transformers ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark impure-containers-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: + base + , impure-containers + , criterion + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 default-language: Haskell2010 source-repository head diff --git a/src/Data/Graph/Immutable.hs b/src/Data/Graph/Immutable.hs --- a/src/Data/Graph/Immutable.hs +++ b/src/Data/Graph/Immutable.hs @@ -14,6 +14,7 @@ ( -- * Graph Operations lookupVertex , lookupEdge + , atVertex , mapVertices , traverseVertices_ , traverseEdges_ @@ -26,14 +27,15 @@ , with -- * Algorithms , dijkstra - , dijkstraMonoidal - , dijkstraMonoidalCover + , dijkstraDistance + , dijkstraFoldM -- * Size and Vertex , sizeInt , vertexInt -- * Vertices , verticesRead , verticesLength + , verticesTraverse , verticesTraverse_ , verticesToVertexList , verticesToVector @@ -71,6 +73,9 @@ Nothing -> Nothing Just ix -> Just (V.unsafeIndex (V.unsafeIndex edges x) ix) +atVertex :: Vertex g -> Graph g e v -> v +atVertex v g = verticesRead (vertices g) v + -- | Not the same as 'fmap' because the function also takes the vertex id. mapVertices :: (Vertex g -> a -> b) -> Graph g e a -> Graph g e b mapVertices f (Graph sg) = Graph sg @@ -93,7 +98,6 @@ ) allVertices -- | Traverse the neighbors of a specific vertex. --- Change this to use unsafeRead some time soon. traverseNeighbors_ :: Applicative m => (Vertex g -> v -> e -> m a) -> Vertex g @@ -101,13 +105,13 @@ -> m () traverseNeighbors_ f (Vertex x) (Graph g) = let allVertices = graphVertices g - theVertices = graphOutboundNeighborVertices g V.! x - edges = graphOutboundNeighborEdges g V.! x + theVertices = V.unsafeIndex (graphOutboundNeighborVertices g) x + edges = V.unsafeIndex (graphOutboundNeighborEdges g) x numNeighbors = U.length theVertices go !i = if i < numNeighbors - then let vertexNum = theVertices U.! i - vertexVal = allVertices V.! vertexNum - edgeVal = edges V.! i + then let vertexNum = U.unsafeIndex theVertices i + vertexVal = V.unsafeIndex allVertices vertexNum + edgeVal = V.unsafeIndex edges i in f (Vertex vertexNum) vertexVal edgeVal *> go (i + 1) else pure () in go 0 @@ -118,7 +122,7 @@ vertices (Graph (SomeGraph v _ _)) = Vertices v -- | Set the vertices of a graph. -setVertices :: Vertices g v -> Graph g e v -> Graph g e v +setVertices :: Vertices g v -> Graph g e w -> Graph g e v setVertices (Vertices x) (Graph (SomeGraph _ a b)) = Graph (SomeGraph x a b) -- | Get the number of vertices in a graph. @@ -207,16 +211,17 @@ -- The source code of this function provides an example of how to use -- the generalized variants of Dijkstra\'s algorithm provided by this -- module. -dijkstra :: (Num e, Ord e) +dijkstraDistance :: (Num e, Ord e) => Vertex g -- ^ Start vertex -> Vertex g -- ^ End vertex -> Graph g e v -- ^ Graph -> Maybe e -dijkstra start end g = getMinDistance - ( dijkstraMonoidal +dijkstraDistance start end g = + getMinDistance $ atVertex end + ( dijkstra (\_ _ mdist e -> addMinDistance mdist e) (MinDistance (Just 0)) - start end g + (Identity start) g ) where addMinDistance (MinDistance m) e = MinDistance (fmap (+ e) m) @@ -238,17 +243,6 @@ mempty = MinDistance Nothing mappend ma mb = min ma mb --- | A generalized version of Dijkstra\'s algorithm. -dijkstraMonoidal :: (Ord s, Monoid s) - => (v -> v -> s -> e -> s) -- Weight combining function - -> s -- ^ Weight to assign start vertex - -> Vertex g -- ^ Start vertex - -> Vertex g -- ^ End vertex - -> Graph g e v -- ^ Graph - -> s -dijkstraMonoidal f s start end g = - verticesRead (dijkstraMonoidalCover f s (Identity start) g) end - -- | This is a generalization of Dijkstra\'s algorithm. Like the original, -- it takes a start 'Vertex' but unlike the original, it does not take -- an end. It will continue traversing the 'Graph' until it has touched @@ -298,14 +292,41 @@ -- -- This function could be written without unsafely pattern matching -- on 'Vertex', but doing so allows us to use a faster heap implementation. -dijkstraMonoidalCover :: +dijkstra :: (Ord s, Monoid s, Foldable t) => (v -> v -> s -> e -> s) -- ^ Weight function - -> s -- ^ Weight to assign start vertex - -> t (Vertex g) -- ^ Start vertices - -> Graph g e v -- ^ Graph - -> Vertices g s -dijkstraMonoidalCover f s0 v0 g = runST $ do + -> s -- ^ Weight to assign start vertex + -> t (Vertex g) -- ^ Start vertices + -> Graph g e v -- ^ Graph + -> Graph g e s +dijkstra f s0 v0 g = + fst $ runST $ dijkstraGeneral f (\_ _ _ -> return ()) s0 () v0 g + +-- Traverse every vertex in the graph and monadically fold +-- their values. +dijkstraFoldM :: + (Ord s, Monoid s, Foldable t, PrimMonad m) + => (v -> v -> s -> e -> s) -- ^ Weight function + -> (v -> s -> x -> m x) -- ^ Monadic fold function + -> s -- ^ Weight to assign start vertex + -> x -- ^ Initial accumulator + -> t (Vertex g) -- ^ Start vertices + -> Graph g e v -- ^ Graph + -> m x +dijkstraFoldM f mf s0 acc v0 g = + fmap snd $ dijkstraGeneral f mf s0 acc v0 g + +-- | This is not exported +dijkstraGeneral :: + (Ord s, Monoid s, Foldable t, PrimMonad m) + => (v -> v -> s -> e -> s) -- ^ Weight function + -> (v -> s -> x -> m x) -- ^ Monadic fold + -> s -- ^ Weight to assign start vertex + -> x -- ^ Initial fold value + -> t (Vertex g) -- ^ Start vertices + -> Graph g e v -- ^ Graph + -> m (Graph g e s, x) +dijkstraGeneral f step s0 x0 v0 g = do let theSize = size g oldVertices = vertices g newVertices <- Mutable.verticesReplicate theSize mempty @@ -318,10 +339,10 @@ -- We know it's ok in this case because the min heap does not -- create Ints that we did not push onto it. Heap.unsafePush s0 (getVertexInternal v) heap - let go = do + let go x = do m <- Heap.pop heap case m of - Nothing -> return True + Nothing -> return (BoolWith True x) Just (s,unwrappedVertexIx) -> do -- Unsafe cast from Int to Vertex let vertex = Vertex unwrappedVertexIx @@ -336,13 +357,16 @@ (getVertexInternal neighborVertex) heap ) vertex g - return False - runMe = do - isDone <- go - if isDone then return () else runMe - runMe + xNext <- step value s x + return (BoolWith False xNext) + runMe x = do + BoolWith isDone xNext <- go x + if isDone then return xNext else runMe xNext + xFinal <- runMe x0 newVerticesFrozen <- verticesFreeze newVertices - return newVerticesFrozen + return (setVertices newVerticesFrozen g, xFinal) + +data BoolWith a = BoolWith Bool !a -- mutableIForM_ :: PrimMonad m => MVector (PrimState m) a -> (Int -> a -> m b) -> m () -- mutableIForM_ m f = forM_ (take (MV.length m) (enumFrom 0)) $ \i -> do diff --git a/src/Data/Graph/Mutable.hs b/src/Data/Graph/Mutable.hs --- a/src/Data/Graph/Mutable.hs +++ b/src/Data/Graph/Mutable.hs @@ -23,10 +23,11 @@ import Data.Hashable (Hashable) import qualified Data.HashMap.Mutable.Basic as HashTable --- | $mutgraph --- Operations that mutate a 'MGraph'. Vertices and edges can both be added, --- and edges can be deleted, but vertices cannot be deleted. Providing such --- an operation would undermine the safety that this library provides. +{- $mutgraph + Operations that mutate a 'MGraph'. Vertices and edges can both be added, + and edges can be deleted, but vertices cannot be deleted. Providing such + an operation would undermine the safety that this library provides. +-} -- | This does two things: -- @@ -60,16 +61,17 @@ Nothing -> HashTable.insert edges (IntPair a b) e Just eOld -> HashTable.insert edges (IntPair a b) (combine eOld e) --- | $mutvertices --- Operations that mutate a 'MVertices' or a 'MUVertices'. These functions have nothing --- to do with 'MGraph' and are not usually needed by end users of this library. They --- are useful for users writing algorithms that need to mark vertices in a graph as --- it is traversed. --- --- All of these operations are --- wrappers around operations from @Data.Vector.Mutable@ and @Data.Vector.Unbox.Mutable@. --- As long as you do not import @Data.Graph.Types.Internal@, this library guarentees that --- these operations will not fail at runtime. +{- $mutvertices + Operations that mutate a 'MVertices' or a 'MUVertices'. These functions have nothing + to do with 'MGraph' and are not usually needed by end users of this library. They + are useful for users writing algorithms that need to mark vertices in a graph as + it is traversed. + + All of these operations are + wrappers around operations from @Data.Vector.Mutable@ and @Data.Vector.Unbox.Mutable@. + As long as you do not import @Data.Graph.Types.Internal@, this library guarentees that + these operations will not fail at runtime. +-} verticesReplicate :: PrimMonad m => Size g -> v -> m (MVertices (PrimState m) g v) verticesReplicate (Size i) v = fmap MVertices (MV.replicate i v) diff --git a/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs b/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs --- a/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs +++ b/src/Data/HashMap/Mutable/Internal/UnsafeTricks.hs @@ -21,6 +21,7 @@ import qualified Data.Vector.Mutable as M #ifdef UNSAFETRICKS import GHC.Exts +import GHC.Types import Unsafe.Coerce #if __GLASGOW_HASKELL__ >= 707 diff --git a/src/Data/Maybe/Unsafe.hs b/src/Data/Maybe/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Maybe/Unsafe.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +module Data.Maybe.Unsafe (UnsafeMaybe + ,just + ,nothing + ,fromMaybe + ,maybe + ,toMaybe) where + +import Unsafe.Coerce +import System.IO.Unsafe +import System.Mem.StableName +import GHC.Prim +import GHC.Types +import Prelude hiding (maybe) + +thunk :: Int -> Int +thunk x = error "bang" +{-# NOINLINE thunk #-} + +thunkStableName :: StableName (Int -> Int) +thunkStableName = unsafePerformIO (makeStableName thunk) + +-- | nothingSurrogate stands in for the value Nothing; we distinguish it by pointer +nothingSurrogate :: Any +nothingSurrogate = unsafeCoerce thunk +{-# NOINLINE nothingSurrogate #-} + +nothingStableName :: StableName Any +nothingStableName = unsafePerformIO (makeStableName nothingSurrogate) + +newtype UnsafeMaybe a = UnsafeMaybe Any + +instance Functor UnsafeMaybe where + fmap f = maybe nothing (just . f) + +instance Applicative UnsafeMaybe where + pure = just + {-# INLINE pure #-} + -- (UnsafeMaybe f) <*> (UnsafeMaybe x) = case reallyUnsafePtrEquality# f nothingSurrogate of + -- 0# -> case reallyUnsafePtrEquality# x nothingSurrogate of + -- 0# -> just ((unsafeCoerce f) (unsafeCoerce x)) + -- _ -> nothing + -- _ -> nothing + mf <*> mx = maybe nothing (\f -> maybe nothing (just . f) mx) mf + {-# INLINE (<*>) #-} + +instance Monad UnsafeMaybe where + return = just + -- (UnsafeMaybe x) >>= f = case reallyUnsafePtrEquality# x nothingSurrogate of + -- 0# -> f (unsafeCoerce x) + -- _ -> nothing + mx >>= f = maybe nothing f mx + + +just :: a -> UnsafeMaybe a +just a = UnsafeMaybe (unsafeCoerce a) + +nothing :: UnsafeMaybe a +nothing = UnsafeMaybe nothingSurrogate + +fromMaybe :: Maybe a -> UnsafeMaybe a +fromMaybe (Just a) = just a +fromMaybe Nothing = nothing +{-# INLINE fromMaybe #-} + +maybe :: b -> (a -> b) -> UnsafeMaybe a -> b +maybe !def transform (UnsafeMaybe !a) = case eqStableName thunkStableName named || + eqStableName nothingStableName named of + False -> transform (unsafeCoerce a) + True -> def + where named = unsafePerformIO (makeStableName a) +{-# INLINE maybe #-} + +-- toMaybe :: UnsafeMaybe a -> Maybe a +-- toMaybe (UnsafeMaybe a) = case reallyUnsafePtrEquality# a nothingSurrogate of +-- 0# -> Just (unsafeCoerce a) +-- _ -> Nothing +-- {-# INLINE toMaybe #-} + +toMaybe :: UnsafeMaybe a -> Maybe a +toMaybe = maybe Nothing Just diff --git a/src/Data/Primitive/Array/Maybe.hs b/src/Data/Primitive/Array/Maybe.hs --- a/src/Data/Primitive/Array/Maybe.hs +++ b/src/Data/Primitive/Array/Maybe.hs @@ -10,7 +10,8 @@ import Control.Monad.Primitive import Data.Primitive.Array -import GHC.Prim (reallyUnsafePtrEquality#,Any) +import GHC.Prim (reallyUnsafePtrEquality#) +import GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) newtype MutableMaybeArray s a = MutableMaybeArray (MutableArray s Any) diff --git a/src/Data/Primitive/MutVar/Maybe.hs b/src/Data/Primitive/MutVar/Maybe.hs --- a/src/Data/Primitive/MutVar/Maybe.hs +++ b/src/Data/Primitive/MutVar/Maybe.hs @@ -13,6 +13,7 @@ import Unsafe.Coerce import GHC.Prim +import GHC.Types import Data.Maybe diff --git a/src/Data/Trie/Immutable/Bits.hs b/src/Data/Trie/Immutable/Bits.hs --- a/src/Data/Trie/Immutable/Bits.hs +++ b/src/Data/Trie/Immutable/Bits.hs @@ -13,15 +13,16 @@ import Data.Primitive.ByteArray import Data.Primitive.MutVar.Maybe import Data.Trie.Mutable.Bits (MTrie(..)) +import Data.Maybe.Unsafe data Trie k v = Trie - { trieValue :: !(Maybe v) - , trieLeft :: !(Maybe (Trie k v)) - , trieRight :: !(Maybe (Trie k v)) + { trieValue :: !(UnsafeMaybe v) + , trieLeft :: !(UnsafeMaybe (Trie k v)) + , trieRight :: !(UnsafeMaybe (Trie k v)) } empty :: Trie k v -empty = Trie Nothing Nothing Nothing +empty = Trie nothing nothing nothing -- | This gives the best match, that is, the -- value stored at the longest prefix that @@ -30,7 +31,7 @@ => Trie k v -> k -> Maybe v -lookup theTrie theKey = go Nothing theTrie theKey where +lookup theTrie theKey = toMaybe (go nothing theTrie theKey) where totalBits :: Int totalBits = finiteBitSize theKey -- mask :: k @@ -39,7 +40,7 @@ zero = zeroBits go !mres (Trie mval mleft mright) key = let chosen = if (mask .&. key) == zero then mleft else mright - in case chosen of + in case toMaybe chosen of Nothing -> mval Just nextTrie -> go mval nextTrie (unsafeShiftL key 1) @@ -55,5 +56,5 @@ immutableRight <- case mright of Just right -> fmap Just $ go right Nothing -> return Nothing - return (Trie mval immutableLeft immutableRight) + return undefined --(Trie mval immutableLeft immutableRight) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,6 +16,7 @@ import Data.Functor.Compose import Data.Word +import Data.Functor.Identity import Data.Function (on) import Data.List (groupBy) import Control.Monad @@ -33,6 +34,8 @@ import qualified Data.Graph.Mutable as MGraph import qualified Data.Graph.Immutable as Graph import qualified Data.Trie.Mutable.Bits as BitTrie +import qualified Data.Maybe.Unsafe as UMaybe +import Data.Maybe.Unsafe hiding (maybe) main :: IO () main = defaultMain tests @@ -58,6 +61,10 @@ [ testProperty "Basic Insert and Lookup" bitTrieBasic , testProperty "Prefixes" bitTriePrefix ] + , testGroup "Unsafe Maybe" + [ testCase "Unsafe Maybe functions" unsafeMaybeWorks + -- , testProperty "Unsafe Maybe Quickcheck props" unsafeMaybeProp + ] ] testElements :: Int @@ -170,7 +177,11 @@ (Just _,Nothing) -> False (Just start, Just end) -> let expected = Min (sum xs) - in expected == Graph.dijkstraMonoidal (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) start end g + in expected == Graph.atVertex end + (Graph.dijkstra + (\_ _ (Min x) distance -> Min (x + distance)) + (Min 0) (Identity start) g + ) data Thing = Foo | Bar Int | Baz Bool deriving (Eq,Show) @@ -195,6 +206,17 @@ , Just $ Baz True, Nothing , Nothing, Just (Bar 15) ) + +unsafeMaybeWorks :: IO () +unsafeMaybeWorks = (a,b,c,d,e,f,g,h) @?= (Nothing,Just 0,1,Nothing,Just 3,Nothing,Just 4,Nothing) + where a = toMaybe $ nothing :: Maybe Int + b = toMaybe $ just (0 :: Int) + c = UMaybe.maybe (0 :: Int) (+1) (just 0) + d = toMaybe $ nothing :: Maybe Int + e = toMaybe $ fmap (+1) (just 2) + f = toMaybe $ fmap (+1) nothing + g = toMaybe $ just (just 4) >>= id + h = toMaybe $ UMaybe.maybe nothing (const nothing) nothing :: Maybe Int bitTrieBasic :: [Word8] -> Bool bitTrieBasic xs =