diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright Andrew Martin (c) 2016 - -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 Martin 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/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,31 @@ +Copyright Andrew Martin 2016-2018 +Copyright Remy Goldschmidt 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 Andrew Martin 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,4 @@ +impure-containers +================= + +Available on [hackage](http://hackage.haskell.org/package/impure-containers). diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/impure-containers.cabal b/impure-containers.cabal --- a/impure-containers.cabal +++ b/impure-containers.cabal @@ -1,142 +1,162 @@ -name: impure-containers -version: 0.4.3 -synopsis: Mutable containers in haskell -description: Please see README.md -homepage: https://github.com/andrewthad/impure-containers#readme -license: BSD3 -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2016 Andrew Martin -category: web -build-type: Simple -cabal-version: >=1.10 -extra-source-files: - cbits/Makefile - , cbits/check.c - , cbits/defs.h - , cbits/sse-42-check.c +-------------------------------------------------------------------------------- +name: impure-containers +version: 0.5.0 +stability: Experimental +build-type: Simple +cabal-version: >= 1.10 +category: Data Structures +copyright: Copyright 2016 Andrew Martin + , Copyright 2018 Remy Goldschmidt +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +license: BSD3 +license-file: LICENSE.md +homepage: https://github.com/andrewthad/impure-containers +bug-reports: https://github.com/andrewthad/impure-containers/issues +synopsis: Mutable containers in Haskell. +description: Please see README.md +extra-source-files: README.md + , cbits/Makefile + , cbits/check.c + , cbits/defs.h + , cbits/sse-42-check.c +tested-with: GHC == 8.0.2 + +-------------------------------------------------------------------------------- + +source-repository head + type: git + tag: master + location: https://github.com/andrewthad/impure-containers + +-------------------------------------------------------------------------------- + +flag unsafe-tricks + description: If enabled, turn on unsafe GHC tricks. + default: True + +flag bounds-checking + description: If enabled, use bounds-checking array accesses. + default: False + +flag debug + description: If enabled, spew debugging output to stdout. + default: False + +flag sse42 + description: If enabled, use SSE 4.2 extensions to search cache + lines very efficiently. + The portable flag forces this off. + default: False + +flag portable + description: If enabled, use only pure Haskell code and no + GHC extensions. + default: False + +-------------------------------------------------------------------------------- + library - hs-source-dirs: src - exposed-modules: - Data.HashMap.Mutable.Basic - -- Data.Heap.Mutable.ModelA - -- Data.Heap.Mutable.ModelB - Data.Heap.Mutable.ModelC - Data.Heap.Mutable.ModelD - Data.Graph.Immutable - Data.Graph.Mutable - Data.Trie.Mutable.Bits - Data.Trie.Immutable.Bits - Data.ArrayList.Generic - Data.Graph.Types - Data.Graph.Types.Internal - Data.Primitive.PrimArray - 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 - Data.HashMap.Mutable.Internal.CacheLine - Data.HashMap.Mutable.Internal.CheapPseudoRandomBitStream - Data.HashMap.Mutable.Internal.IntArray - Data.HashMap.Mutable.Internal.Linear.Bucket - Data.HashMap.Mutable.Internal.UnsafeTricks - Data.HashMap.Mutable.Internal.Utils - build-depends: - 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 + hs-source-dirs: src + exposed-modules: Data.HashMap.Mutable.Basic + -- , Data.Heap.Mutable.ModelA + -- , Data.Heap.Mutable.ModelB + , Data.Heap.Mutable.ModelC + , Data.Heap.Mutable.ModelD + , Data.Graph.Immutable + , Data.Graph.Mutable + , Data.Trie.Mutable.Bits + , Data.Trie.Immutable.Bits + , Data.ArrayList.Generic + , Data.Graph.Types + , Data.Graph.Types.Internal + , Data.Primitive.PrimArray + , Data.Primitive.Array.Maybe + , Data.Primitive.MutVar.Maybe + , Data.Primitive.Bool + , Data.Maybe.Unsafe + -- , Data.Containers.Impure.Internal + , ImpureContainers.PrimRef + , ImpureContainers.MByteArray + , ImpureContainers.Misc.Mobility + other-modules: Data.HashMap.Mutable.Internal.Array + , Data.HashMap.Mutable.Internal.CacheLine + , Data.HashMap.Mutable.Internal.CheapPseudoRandomBitStream + , Data.HashMap.Mutable.Internal.IntArray + , Data.HashMap.Mutable.Internal.Linear.Bucket + , Data.HashMap.Mutable.Internal.UnsafeTricks + , Data.HashMap.Mutable.Internal.Utils + build-depends: 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 if flag(sse42) && !flag(portable) - cc-options: -DUSE_SSE_4_2 -msse4.2 - cpp-options: -DUSE_SSE_4_2 - C-sources: cbits/sse-42.c + cc-options: -DUSE_SSE_4_2 -msse4.2 + cpp-options: -DUSE_SSE_4_2 + c-sources: cbits/sse-42.c if !flag(portable) && !flag(sse42) - C-sources: cbits/default.c + c-sources: cbits/default.c if !flag(portable) - C-sources: cbits/common.c + c-sources: cbits/common.c if flag(portable) - cpp-options: -DNO_C_SEARCH -DPORTABLE + cpp-options: -DNO_C_SEARCH -DPORTABLE if !flag(portable) && flag(unsafe-tricks) && impl(ghc) - build-depends: ghc-prim - cpp-options: -DUNSAFETRICKS + build-depends: ghc-prim + cpp-options: -DUNSAFETRICKS if flag(debug) - cpp-options: -DDEBUG + cpp-options: -DDEBUG if flag(bounds-checking) - cpp-options: -DBOUNDS_CHECKING - - -- ghc-prof-options: -prof -auto-all - - ghc-options: - -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-unused-do-bind - -- Turn this one back on later - -- -O2 - -Flag unsafe-tricks - Description: turn on unsafe GHC tricks - Default: True - -Flag bounds-checking - Description: if on, use bounds-checking array accesses - Default: False + cpp-options: -DBOUNDS_CHECKING -Flag debug - Description: if on, spew debugging output to stdout - Default: False + -- ghc-prof-options: -prof -auto-all -Flag sse42 - Description: if on, use SSE 4.2 extensions to search cache lines very - efficiently. The portable flag forces this off. - Default: False + ghc-options: -Wall + -fwarn-tabs + -funbox-strict-fields + -fno-warn-unused-do-bind + -- -- Turn this one back on later + -- -O2 -Flag portable - Description: if on, use only pure Haskell code and no GHC extensions. - Default: False +-------------------------------------------------------------------------------- test-suite impure-containers-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: - base - , impure-containers - , containers - , test-framework - , test-framework-quickcheck2 - , QuickCheck - , HUnit - , test-framework-hunit - , vector - , transformers - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , impure-containers + , containers + , test-framework + , test-framework-quickcheck2 + , QuickCheck + , HUnit + , test-framework-hunit + , 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 + 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 - type: git - location: https://github.com/andrewthad/impure-containers +-------------------------------------------------------------------------------- diff --git a/src/Data/ArrayList/Generic.hs b/src/Data/ArrayList/Generic.hs --- a/src/Data/ArrayList/Generic.hs +++ b/src/Data/ArrayList/Generic.hs @@ -2,15 +2,15 @@ module Data.ArrayList.Generic where -import Control.Monad.Primitive -import Data.Vector.Generic.Mutable (MVector) -import Data.Vector.Generic (Vector, Mutable) -import Data.Primitive.MutVar +import Control.Monad.Primitive +import Data.Primitive.MutVar +import Data.Vector.Generic (Mutable, Vector) +import qualified Data.Vector.Generic as GV +import Data.Vector.Generic.Mutable (MVector) import qualified Data.Vector.Generic.Mutable as GM -import qualified Data.Vector.Generic as GV data ArrayList v s a = ArrayList - { arrayListSize :: !(MutVar s Int) + { arrayListSize :: !(MutVar s Int) , arrayListVector :: !(MutVar s (v s a)) } 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 @@ -56,6 +56,7 @@ import Control.Monad.ST (runST) import Data.Primitive.MutVar import Data.Coerce (coerce) +import Data.Semigroup (Semigroup) import qualified Data.Graph.Mutable as Mutable import qualified Data.ArrayList.Generic as ArrayList import qualified Data.HashMap.Mutable.Basic as HashTable @@ -64,6 +65,7 @@ import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import qualified Data.Semigroup as SG -- | Lookup a 'Vertex' by its label. lookupVertex :: Eq v => v -> Graph g e v -> Maybe (Vertex g) @@ -85,12 +87,12 @@ -- | Map of the edges in the graph. mapEdges :: (Vertex g -> Vertex g -> e -> d) -> Graph g e v -> Graph g d v -mapEdges f (Graph (SomeGraph v verts edges)) = Graph $ SomeGraph v verts $ +mapEdges f (Graph (SomeGraph v verts edges)) = Graph $ SomeGraph v verts $ V.imap ( \outerIx edgeVals -> let vertIxs = V.unsafeIndex verts outerIx in V.imap - ( \sourceIx edgeVal -> + ( \sourceIx edgeVal -> let destIx = U.unsafeIndex vertIxs sourceIx in f (Vertex sourceIx) (Vertex destIx) edgeVal ) edgeVals @@ -236,7 +238,7 @@ -> Vertex g -- ^ End vertex -> Graph g e v -- ^ Graph -> Maybe e -dijkstraDistance start end g = +dijkstraDistance start end g = getMinDistance $ atVertex end ( dijkstra (\_ _ mdist e -> addMinDistance mdist e) @@ -259,9 +261,12 @@ Nothing -> LT Just bval -> compare aval bval +instance Ord a => Semigroup (MinDistance a) where + (<>) = min + instance Ord a => Monoid (MinDistance a) where mempty = MinDistance Nothing - mappend ma mb = min ma mb + mappend = (SG.<>) -- | This is a generalization of Dijkstra\'s algorithm. Like the original, -- it takes a start 'Vertex' but unlike the original, it does not take @@ -319,12 +324,12 @@ -> t (Vertex g) -- ^ Start vertices -> Graph g e v -- ^ Graph -> Graph g e s -dijkstra f s0 v0 g = +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 :: +dijkstraFoldM :: (Ord s, Monoid s, Foldable t, PrimMonad m) => (v -> v -> s -> e -> s) -- ^ Weight function -> (v -> s -> x -> m x) -- ^ Monadic fold function @@ -333,7 +338,7 @@ -> t (Vertex g) -- ^ Start vertices -> Graph g e v -- ^ Graph -> m x -dijkstraFoldM f mf s0 acc v0 g = +dijkstraFoldM f mf s0 acc v0 g = fmap snd $ dijkstraGeneral f mf s0 acc v0 g -- | This is not exported 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 @@ -14,14 +14,14 @@ , verticesURead ) where -import Data.Graph.Types.Internal -import Control.Monad.Primitive -import qualified Data.Vector.Mutable as MV +import Control.Monad.Primitive +import Data.Graph.Types.Internal +import Data.Hashable (Hashable) +import qualified Data.HashMap.Mutable.Basic as HashTable +import Data.Primitive.MutVar +import qualified Data.Vector.Mutable as MV +import Data.Vector.Unboxed (Unbox) import qualified Data.Vector.Unboxed.Mutable as MU -import Data.Vector.Unboxed (Unbox) -import Data.Primitive.MutVar -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, diff --git a/src/Data/Graph/Types.hs b/src/Data/Graph/Types.hs --- a/src/Data/Graph/Types.hs +++ b/src/Data/Graph/Types.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} module Data.Graph.Types ( SomeGraph , Graph @@ -15,5 +14,5 @@ , STGraph ) where -import Data.Graph.Types.Internal +import Data.Graph.Types.Internal diff --git a/src/Data/Graph/Types/Internal.hs b/src/Data/Graph/Types/Internal.hs --- a/src/Data/Graph/Types/Internal.hs +++ b/src/Data/Graph/Types/Internal.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} @@ -16,14 +15,14 @@ -- module Data.Graph.Types.Internal where -import Data.HashMap.Mutable.Basic (MHashMap) -import Data.Vector (Vector,MVector) -import Data.Primitive.MutVar (MutVar) -import Data.Hashable (Hashable) -import GHC.Generics (Generic) -import Control.Monad.ST (RealWorld) -import qualified Data.Vector.Unboxed as U +import Control.Monad.ST (RealWorld) +import Data.Hashable (Hashable) +import Data.HashMap.Mutable.Basic (MHashMap) +import Data.Primitive.MutVar (MutVar) +import Data.Vector (MVector, Vector) +import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import GHC.Generics (Generic) -- | A 'Graph' with edges labeled by @e@ and vertices labeled by @v@. -- The @g@ type variable is a phatom type that associates a @@ -77,8 +76,8 @@ -- delete vertices. data MGraph s g e v = MGraph { mgraphVertexIndex :: !(MHashMap s v Int) - , mgraphCurrentId :: !(MutVar s Int) - , mgraphEdges :: !(MHashMap s IntPair e) + , mgraphCurrentId :: !(MutVar s Int) + , mgraphEdges :: !(MHashMap s IntPair e) } type IOGraph = MGraph RealWorld diff --git a/src/Data/HashMap/Mutable/Basic.hs b/src/Data/HashMap/Mutable/Basic.hs --- a/src/Data/HashMap/Mutable/Basic.hs +++ b/src/Data/HashMap/Mutable/Basic.hs @@ -32,26 +32,29 @@ ------------------------------------------------------------------------------ -import Control.Exception (assert) -import Control.Monad hiding (foldM, mapM_) -import Control.Monad.ST (ST) -import Control.Monad.Primitive (PrimMonad,PrimState,unsafePrimToPrim) +import Control.Exception (assert) +import Control.Monad hiding (foldM, mapM_) +import Control.Monad.Primitive (PrimMonad, PrimState, unsafePrimToPrim) +import Control.Monad.ST (ST) import Data.Bits -import Data.Hashable (Hashable) -import qualified Data.Hashable as H +import Data.Hashable (Hashable) import Data.Maybe import Data.Monoid -import qualified Data.Primitive.ByteArray as A -import Data.Primitive.MutVar (MutVar,readMutVar,writeMutVar,newMutVar) +import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar, writeMutVar) import Data.STRef +import Data.Semigroup (Semigroup) import GHC.Exts -import Prelude hiding (lookup, mapM_, read) +import Prelude hiding (lookup, mapM_, read) +import qualified Data.Hashable as H +import qualified Data.Primitive.ByteArray as A +import qualified Data.Primitive.ByteArray as A ------------------------------------------------------------------------------ import Data.HashMap.Mutable.Internal.Array import Data.HashMap.Mutable.Internal.CacheLine import Data.HashMap.Mutable.Internal.IntArray (Elem) import qualified Data.HashMap.Mutable.Internal.IntArray as U import Data.HashMap.Mutable.Internal.Utils +import qualified Data.Semigroup as SG ------------------------------------------------------------------------------ @@ -364,11 +367,12 @@ ------------------------------------------------------------------------------ +instance Semigroup Slot where + Slot x1 b1 <> Slot x2 b2 = if x1 == maxBound then Slot x2 b2 else Slot x1 b1 + instance Monoid Slot where mempty = Slot maxBound 0 - (Slot x1 b1) `mappend` (Slot x2 b2) = - if x1 == maxBound then Slot x2 b2 else Slot x1 b1 - + mappend = (SG.<>) ------------------------------------------------------------------------------ -- Returns the slot in the array where it would be safe to write the given key. diff --git a/src/Data/HashMap/Mutable/Internal/Array.hs b/src/Data/HashMap/Mutable/Internal/Array.hs --- a/src/Data/HashMap/Mutable/Internal/Array.hs +++ b/src/Data/HashMap/Mutable/Internal/Array.hs @@ -8,15 +8,15 @@ ) where +import Control.Monad.Primitive (PrimMonad, PrimState) import Control.Monad.ST -import Control.Monad.Primitive (PrimMonad,PrimState) #ifdef BOUNDS_CHECKING -import qualified Data.Vector.Mutable as M -import Data.Vector.Mutable (MVector) +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as M #else -import qualified Data.Primitive.Array as M -import Data.Primitive.Array (MutableArray) +import Data.Primitive.Array (MutableArray) +import qualified Data.Primitive.Array as M #endif diff --git a/src/Data/HashMap/Mutable/Internal/CacheLine.hs b/src/Data/HashMap/Mutable/Internal/CacheLine.hs --- a/src/Data/HashMap/Mutable/Internal/CacheLine.hs +++ b/src/Data/HashMap/Mutable/Internal/CacheLine.hs @@ -20,8 +20,9 @@ ) where import Control.Monad -import Control.Monad.ST (ST) -import Control.Monad.Primitive (PrimMonad,PrimState,unsafePrimToPrim) +import Control.Monad.Primitive + (PrimMonad, PrimState, unsafePrimToPrim) +import Control.Monad.ST (ST) import Data.HashMap.Mutable.Internal.IntArray (Elem, IntArray) import qualified Data.HashMap.Mutable.Internal.IntArray as M @@ -31,7 +32,7 @@ #else import Data.Bits import Data.Int -import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed as U import GHC.Int #endif @@ -39,7 +40,7 @@ import GHC.Exts #if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts (isTrue#) +import GHC.Exts (isTrue#) #else isTrue# :: Bool -> Bool isTrue# = id diff --git a/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs b/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs --- a/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs +++ b/src/Data/HashMap/Mutable/Internal/CheapPseudoRandomBitStream.hs @@ -9,11 +9,11 @@ import Control.Applicative import Control.Monad.ST -import Data.Bits ((.&.)) +import Data.Bits ((.&.)) import Data.STRef -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V -import Data.Word (Word, Word32, Word64) +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V +import Data.Word (Word, Word32, Word64) import Data.HashMap.Mutable.Internal.Utils diff --git a/src/Data/HashMap/Mutable/Internal/IntArray.hs b/src/Data/HashMap/Mutable/Internal/IntArray.hs --- a/src/Data/HashMap/Mutable/Internal/IntArray.hs +++ b/src/Data/HashMap/Mutable/Internal/IntArray.hs @@ -17,8 +17,8 @@ ) where ------------------------------------------------------------------------------ +import Control.Monad.Primitive (PrimMonad, PrimState) import Control.Monad.ST -import Control.Monad.Primitive (PrimMonad,PrimState) import Data.Bits import qualified Data.Primitive.ByteArray as A import Data.Primitive.Types (Addr (..)) diff --git a/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs b/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs --- a/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs +++ b/src/Data/HashMap/Mutable/Internal/Linear/Bucket.hs @@ -23,16 +23,18 @@ ------------------------------------------------------------------------------ -import Control.Monad hiding (foldM, mapM_) +import Control.Monad hiding + (foldM, mapM_) import qualified Control.Monad -import Control.Monad.ST (ST) +import Control.Monad.ST (ST) #ifdef DEBUG import Data.HashMap.Mutable.Internal.Utils (unsafeIOToST) #endif import Data.HashMap.Mutable.Internal.Array -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import Data.STRef -import Prelude hiding (lookup, mapM_) +import Prelude hiding + (lookup, mapM_) ------------------------------------------------------------------------------ import Data.HashMap.Mutable.Internal.UnsafeTricks 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 @@ -1,8 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -#ifdef UNSAFETRICKS {-# LANGUAGE MagicHash #-} -#endif module Data.HashMap.Mutable.Internal.UnsafeTricks ( Key @@ -17,15 +15,15 @@ ) where import Control.Monad.Primitive -import Data.Vector.Mutable (MVector) -import qualified Data.Vector.Mutable as M +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as M #ifdef UNSAFETRICKS import GHC.Exts import GHC.Types import Unsafe.Coerce #if __GLASGOW_HASKELL__ >= 707 -import GHC.Exts (isTrue#) +import GHC.Exts (isTrue#) #else isTrue# :: Bool -> Bool isTrue# = id diff --git a/src/Data/HashMap/Mutable/Internal/Utils.hs b/src/Data/HashMap/Mutable/Internal/Utils.hs --- a/src/Data/HashMap/Mutable/Internal/Utils.hs +++ b/src/Data/HashMap/Mutable/Internal/Utils.hs @@ -22,10 +22,10 @@ , unsafeIOToST ) where -import Data.Bits hiding (shiftL) +import Data.Bits hiding (shiftL) import Data.HashMap.Mutable.Internal.IntArray (Elem) -import Data.Vector (Vector) -import qualified Data.Vector as V +import Data.Vector (Vector) +import qualified Data.Vector as V #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts #else @@ -34,9 +34,9 @@ #endif #if MIN_VERSION_base(4,4,0) -import Control.Monad.ST.Unsafe (unsafeIOToST) +import Control.Monad.ST.Unsafe (unsafeIOToST) #else -import Control.Monad.ST (unsafeIOToST) +import Control.Monad.ST (unsafeIOToST) #endif ------------------------------------------------------------------------------ diff --git a/src/Data/Heap/Mutable/ModelC.hs b/src/Data/Heap/Mutable/ModelC.hs --- a/src/Data/Heap/Mutable/ModelC.hs +++ b/src/Data/Heap/Mutable/ModelC.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module provides a variant of a mutable binary min heap that is used elsewhere to implement @@ -44,24 +44,24 @@ module Data.Heap.Mutable.ModelC where -import Control.Monad -import Control.Monad.Primitive -import Data.Primitive.MutVar -import Data.Primitive.Types (sizeOf#) -import GHC.Types (Int(..)) -import Data.Vector (Vector,MVector) -import Data.Bits (unsafeShiftL,unsafeShiftR) -import Data.Word -import Data.Coerce -import Data.Vector.Unboxed (Unbox) -import Data.Primitive.Array -import Data.Primitive.ByteArray -import Debug.Trace -import qualified Data.Primitive.Array as A -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Unboxed as U +import Control.Monad +import Control.Monad.Primitive +import Data.Bits (unsafeShiftL, unsafeShiftR) +import Data.Coerce +import Data.Primitive.Array +import qualified Data.Primitive.Array as A +import Data.Primitive.ByteArray +import Data.Primitive.MutVar +import Data.Primitive.Types (sizeOf#) +import Data.Vector (MVector, Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as MV +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU +import Data.Word +import Debug.Trace +import GHC.Types (Int (..)) {-@ type Positive = {n:Int | n > 0} @-} diff --git a/src/Data/Heap/Mutable/ModelD.hs b/src/Data/Heap/Mutable/ModelD.hs --- a/src/Data/Heap/Mutable/ModelD.hs +++ b/src/Data/Heap/Mutable/ModelD.hs @@ -1,10 +1,10 @@ module Data.Heap.Mutable.ModelD where +import Control.Monad +import Control.Monad.Primitive import qualified Data.Heap.Mutable.ModelC as I -import Debug.Trace -import Data.Primitive.MutVar -import Control.Monad.Primitive -import Control.Monad +import Data.Primitive.MutVar +import Debug.Trace data Heap s p = Heap { heapRaw :: !(I.RawHeap s p) diff --git a/src/Data/Maybe/Unsafe.hs b/src/Data/Maybe/Unsafe.hs --- a/src/Data/Maybe/Unsafe.hs +++ b/src/Data/Maybe/Unsafe.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MagicHash, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} module Data.Maybe.Unsafe (UnsafeMaybe ,just ,nothing @@ -6,12 +7,12 @@ ,maybe ,toMaybe) where -import Unsafe.Coerce -import System.IO.Unsafe -import System.Mem.StableName -import GHC.Prim -import GHC.Types -import Prelude hiding (maybe) +import GHC.Prim +import GHC.Types +import Prelude hiding (maybe) +import System.IO.Unsafe +import System.Mem.StableName +import Unsafe.Coerce thunk :: Int -> Int thunk x = error "bang" 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 @@ -1,23 +1,23 @@ {-# LANGUAGE MagicHash #-} -- | This uses some unsafe hackery. -module Data.Primitive.Array.Maybe +module Data.Primitive.Array.Maybe ( MutableMaybeArray , newMaybeArray , readMaybeArray , writeMaybeArray ) where -import Control.Monad.Primitive -import Data.Primitive.Array -import GHC.Prim (reallyUnsafePtrEquality#) -import GHC.Exts (Any) -import Unsafe.Coerce (unsafeCoerce) +import Control.Monad.Primitive +import Data.Primitive.Array +import GHC.Exts (Any) +import GHC.Prim (reallyUnsafePtrEquality#) +import Unsafe.Coerce (unsafeCoerce) newtype MutableMaybeArray s a = MutableMaybeArray (MutableArray s Any) unsafeToMaybe :: Any -> Maybe a -unsafeToMaybe a = +unsafeToMaybe a = case reallyUnsafePtrEquality# a nothingSurrogate of 0# -> Just (unsafeCoerce a) _ -> Nothing @@ -32,7 +32,7 @@ Just a -> do x <- newArray i (unsafeCoerce a) return (MutableMaybeArray x) - Nothing -> do + Nothing -> do x <- newArray i nothingSurrogate return (MutableMaybeArray x) diff --git a/src/Data/Primitive/Bool.hs b/src/Data/Primitive/Bool.hs --- a/src/Data/Primitive/Bool.hs +++ b/src/Data/Primitive/Bool.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -module Data.Primitive.Bool +module Data.Primitive.Bool ( BoolByte(..) ) where -import Data.Primitive.Types +import Data.Primitive.Types import qualified Data.Primitive.Types as P -import Data.Word -import GHC.Prim -import GHC.Types (Int(..)) +import Data.Word +import GHC.Prim +import GHC.Types (Int (..)) {-@ data BoolByte = BoolByte { getBoolByte :: Bool } @-} newtype BoolByte = BoolByte { getBoolByte :: Bool } @@ -40,28 +40,28 @@ instance Prim BoolByte where sizeOf# _ = 1# alignment# _ = 1# - indexByteArray# arr# i# = toBool# (indexWord8Array# arr# i#) - readByteArray# arr# i# s# = - case readWord8Array# arr# i# s# of - { (# s1#, x# #) -> (# s1#, toBool# x# #) } - writeByteArray# arr# i# b s# = - writeWord8Array# arr# i# (fromBool# b) s# + indexByteArray# arr# i# = toBool# (indexWord8Array# arr# i#) + readByteArray# arr# i# s# = + case readWord8Array# arr# i# s# of + { (# s1#, x# #) -> (# s1#, toBool# x# #) } + writeByteArray# arr# i# b s# = + writeWord8Array# arr# i# (fromBool# b) s# setByteArray# arr# i# n# b s# = P.setByteArray# arr# i# n# (fromBool b) s# indexOffAddr# addr# i# = toBool (indexOffAddr# addr# i#) - readOffAddr# addr# i# s# = + readOffAddr# addr# i# s# = case readOffAddr# addr# i# s# of (# s1#, w #) -> (# s1#, toBool w #) writeOffAddr# addr# i# b s# = writeOffAddr# addr# i# (fromBool b) s# - setOffAddr# addr# i# n# b s# = + setOffAddr# addr# i# n# b s# = setOffAddr# addr# i# n# (fromBool b) s# - {-# INLINE sizeOf# #-} - {-# INLINE alignment# #-} - {-# INLINE indexByteArray# #-} - {-# INLINE readByteArray# #-} - {-# INLINE writeByteArray# #-} - {-# INLINE setByteArray# #-} - {-# INLINE indexOffAddr# #-} - {-# INLINE readOffAddr# #-} - {-# INLINE writeOffAddr# #-} - {-# INLINE setOffAddr# #-} + {-# INLINE sizeOf# #-} + {-# INLINE alignment# #-} + {-# INLINE indexByteArray# #-} + {-# INLINE readByteArray# #-} + {-# INLINE writeByteArray# #-} + {-# INLINE setByteArray# #-} + {-# INLINE indexOffAddr# #-} + {-# INLINE readOffAddr# #-} + {-# INLINE writeOffAddr# #-} + {-# INLINE setOffAddr# #-} 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 @@ -1,21 +1,20 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} -module Data.Primitive.MutVar.Maybe +module Data.Primitive.MutVar.Maybe ( MutMaybeVar , newMutMaybeVar , readMutMaybeVar , writeMutMaybeVar ) where -import Data.Primitive.MutVar -import Control.Monad.Primitive +import Control.Monad.Primitive +import Data.Primitive.MutVar -import Unsafe.Coerce -import GHC.Prim -import GHC.Types +import GHC.Prim +import GHC.Types +import Unsafe.Coerce -import Data.Maybe +import Data.Maybe newtype MutMaybeVar s a = MutMaybeVar (MutVar s Any) diff --git a/src/Data/Primitive/PrimArray.hs b/src/Data/Primitive/PrimArray.hs --- a/src/Data/Primitive/PrimArray.hs +++ b/src/Data/Primitive/PrimArray.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -module Data.Primitive.PrimArray +module Data.Primitive.PrimArray ( MutablePrimArray(..) , newPrimArray , readPrimArray @@ -10,11 +10,12 @@ , setPrimArray ) where -import Control.Monad.Primitive -import Data.Primitive.ByteArray -import Data.Primitive.Types -import GHC.Prim (newByteArray#,quotInt#,sizeofMutableByteArray#,(*#)) -import GHC.Types (Int(..)) +import Control.Monad.Primitive +import Data.Primitive.ByteArray +import Data.Primitive.Types +import GHC.Prim + (newByteArray#, quotInt#, sizeofMutableByteArray#, (*#)) +import GHC.Types (Int (..)) newtype MutablePrimArray s a = MutablePrimArray (MutableByteArray s) @@ -39,7 +40,7 @@ {-# INLINE sizeofMutablePrimArray #-} setPrimArray - :: (Prim a, PrimMonad m) + :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of values to fill 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 @@ -7,13 +7,13 @@ , freeze ) where -import Prelude hiding (lookup) -import Control.Monad.Primitive -import Data.Bits -import Data.Primitive.ByteArray -import Data.Primitive.MutVar.Maybe -import Data.Trie.Mutable.Bits (MTrie(..)) -import Data.Maybe.Unsafe +import Control.Monad.Primitive +import Data.Bits +import Data.Maybe.Unsafe +import Data.Primitive.ByteArray +import Data.Primitive.MutVar.Maybe +import Data.Trie.Mutable.Bits (MTrie (..)) +import Prelude hiding (lookup) data Trie k v = Trie { trieValue :: !(UnsafeMaybe v) diff --git a/src/Data/Trie/Mutable/Bits.hs b/src/Data/Trie/Mutable/Bits.hs --- a/src/Data/Trie/Mutable/Bits.hs +++ b/src/Data/Trie/Mutable/Bits.hs @@ -8,11 +8,11 @@ , insertPrefix ) where -import Prelude hiding (lookup) -import Control.Monad.Primitive -import Data.Bits -import Data.Primitive.ByteArray -import Data.Primitive.MutVar.Maybe +import Control.Monad.Primitive +import Data.Bits +import Data.Primitive.ByteArray +import Data.Primitive.MutVar.Maybe +import Prelude hiding (lookup) data MTrie s k v = MTrie { mtrieValue :: !(MutMaybeVar s v) diff --git a/src/ImpureContainers/MByteArray.hs b/src/ImpureContainers/MByteArray.hs new file mode 100644 --- /dev/null +++ b/src/ImpureContainers/MByteArray.hs @@ -0,0 +1,278 @@ +-------------------------------------------------------------------------------- + +{-# LANGUAGE MagicHash #-} + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +module ImpureContainers.MByteArray + ( -- * 'MByteArray' + MByteArray + , underlyingMutableByteArray# + + -- ** Creation + , new, newPinned, newAlignedPinned + + -- ** Element access + , read, write + + -- ** Freezing and thawing + , unsafeFreeze, unsafeThaw + + -- ** Block operations + , copyFromIByteArray + , copyFromMByteArray + , move + , set + , fill + + -- ** Information + , sizeof + , same + , contents + ) where + +-------------------------------------------------------------------------------- + +import Prelude () + +import Data.Bool (Bool) +import Data.Int (Int) +import Data.Word (Word8) + +import Control.Monad.Primitive +import Data.Coerce (coerce) +import Data.Primitive (Addr, Prim) +import qualified Data.Primitive + +import qualified GHC.Prim + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +type MByteArray s = Data.Primitive.MutableByteArray s + +-- | FIXME: doc +type IByteArray = Data.Primitive.ByteArray + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +underlyingMutableByteArray# + :: MByteArray s + -- ^ FIXME: doc + -> GHC.Prim.MutableByteArray# s + -- ^ FIXME: doc +underlyingMutableByteArray# (Data.Primitive.MutableByteArray mba) = mba +{-# INLINE underlyingMutableByteArray# #-} + +-------------------------------------------------------------------------------- + +-- | Create a new mutable byte array of the specified size in bytes. +new + :: (PrimMonad m) + => Int + -- ^ FIXME: doc + -> m (MByteArray (PrimState m)) + -- ^ FIXME: doc +new = Data.Primitive.newByteArray +{-# INLINE new #-} + +-- | Create a /pinned/ byte array of the specified size in bytes. +-- The garbage collector is guaranteed not to move it. +newPinned + :: (PrimMonad m) + => Int + -- ^ FIXME: doc + -> m (MByteArray (PrimState m)) + -- ^ FIXME: doc +newPinned = Data.Primitive.newPinnedByteArray +{-# INLINE newPinned #-} + +-- | Create a /pinned/ byte array of the specified size in bytes and with the +-- give alignment. The garbage collector is guaranteed not to move it. +newAlignedPinned + :: (PrimMonad m) + => Int + -- ^ FIXME: doc + -> Int + -- ^ FIXME: doc + -> m (MByteArray (PrimState m)) + -- ^ FIXME: doc +newAlignedPinned = Data.Primitive.newAlignedPinnedByteArray +{-# INLINE newAlignedPinned #-} + +-- | Yield a pointer to the array's data. +-- This operation is only safe on /pinned/ byte arrays allocated by +-- 'newPinnedByteArray' or 'newAlignedPinnedByteArray'. +contents + :: MByteArray s + -- ^ FIXME: doc + -> Addr + -- ^ FIXME: doc +contents = Data.Primitive.mutableByteArrayContents +{-# INLINE contents #-} + +-- | Check if the two arrays refer to the same memory block. +same + :: MByteArray s + -- ^ FIXME: doc + -> MByteArray s + -- ^ FIXME: doc + -> Bool + -- ^ FIXME: doc +same = Data.Primitive.sameMutableByteArray +{-# INLINE same #-} + +-- | Convert a mutable byte array to an immutable one without copying. +-- The array should not be modified after the conversion. +unsafeFreeze + :: (PrimMonad m) + => MByteArray (PrimState m) + -- ^ FIXME: doc + -> m IByteArray + -- ^ FIXME: doc +unsafeFreeze = Data.Primitive.unsafeFreezeByteArray +{-# INLINE unsafeFreeze #-} + +-- | Convert an immutable byte array to a mutable one without copying. The +-- original array should not be used after the conversion. +unsafeThaw + :: (PrimMonad m) + => IByteArray + -- ^ FIXME: doc + -> m (MByteArray (PrimState m)) + -- ^ FIXME: doc +unsafeThaw = Data.Primitive.unsafeThawByteArray +{-# INLINE unsafeThaw #-} + +-- | Size of the mutable byte array in bytes. +sizeof + :: MByteArray s + -- ^ FIXME: doc + -> Int + -- ^ FIXME: doc +sizeof = Data.Primitive.sizeofMutableByteArray +{-# INLINE sizeof #-} + +-- | Read a primitive value from the byte array. The offset is given in +-- elements of type @a@ rather than in bytes. +read + :: (Prim a, PrimMonad m) + => MByteArray (PrimState m) + -- ^ FIXME: doc + -> Int + -- ^ FIXME: doc + -> m a + -- ^ FIXME: doc +read = Data.Primitive.readByteArray +{-# INLINE read #-} + +-- | Write a primitive value to the byte array. The offset is given in +-- elements of type @a@ rather than in bytes. +write + :: (Prim a, PrimMonad m) + => MByteArray (PrimState m) + -- ^ FIXME: doc + -> Int + -- ^ FIXME: doc + -> a + -- ^ FIXME: doc + -> m () + -- ^ FIXME: doc +write = Data.Primitive.writeByteArray +{-# INLINE write #-} + +-- | Copy a slice of an immutable byte array to a mutable byte array. +copyFromIByteArray + :: (PrimMonad m) + => MByteArray (PrimState m) + -- ^ [FIXME: doc] destination array + -> Int + -- ^ [FIXME: doc] offset into destination array + -> IByteArray + -- ^ [FIXME: doc] source array + -> Int + -- ^ [FIXME: doc] offset into source array + -> Int + -- ^ [FIXME: doc] number of bytes to copy + -> m () + -- ^ FIXME: doc +copyFromIByteArray = Data.Primitive.copyByteArray +{-# INLINE copyFromIByteArray #-} + +-- | Copy a slice of a mutable byte array into another array. +-- The two slices must not overlap. +copyFromMByteArray + :: (PrimMonad m) + => MByteArray (PrimState m) + -- ^ [FIXME: doc] destination array + -> Int + -- ^ [FIXME: doc] offset into destination array + -> MByteArray (PrimState m) + -- ^ [FIXME: doc] source array + -> Int + -- ^ [FIXME: doc] offset into source array + -> Int + -- ^ [FIXME: doc] number of bytes to copy + -> m () + -- ^ FIXME: doc +copyFromMByteArray = Data.Primitive.copyMutableByteArray +{-# INLINE copyFromMByteArray #-} + +-- | Copy a slice of a mutable byte array into another array. +-- The given arrays are allowed to overlap. +move + :: (PrimMonad m) + => MByteArray (PrimState m) + -- ^ [FIXME: doc] destination array + -> Int + -- ^ [FIXME: doc] offset into destination array + -> MByteArray (PrimState m) + -- ^ [FIXME: doc] source array + -> Int + -- ^ [FIXME: doc] offset into source array + -> Int + -- ^ [FIXME: doc] number of bytes to copy + -> m () + -- ^ FIXME: doc +move = Data.Primitive.moveByteArray +{-# INLINE move #-} + +-- | Fill a slice of a mutable byte array with a value. +-- +-- The offset and length parameters are given as a number of elements +-- of type @a@ rather than in bytes. In other words, the offset and length +-- work like C arrays, rather than like C pointers. +set + :: (Prim a, PrimMonad m) + => MByteArray (PrimState m) + -- ^ [FIXME: doc] array to fill + -> Int + -- ^ [FIXME: doc] offset into array + -> Int + -- ^ [FIXME: doc] number of values to fill + -> a + -- ^ [FIXME: doc] value to fill with + -> m () + -- ^ FIXME: doc +set = Data.Primitive.setByteArray +{-# INLINE set #-} + +-- | Fill a slice of a mutable byte array with a byte. +fill + :: (PrimMonad m) + => MByteArray (PrimState m) + -- ^ [FIXME: doc] array to fill + -> Int + -- ^ [FIXME: doc] offset into array + -> Int + -- ^ [FIXME: doc] number of bytes to fill + -> Word8 + -- ^ [FIXME: doc] byte to fill with + -> m () + -- ^ FIXME: doc +fill = Data.Primitive.fillByteArray +{-# INLINE fill #-} + +-------------------------------------------------------------------------------- diff --git a/src/ImpureContainers/Misc/Mobility.hs b/src/ImpureContainers/Misc/Mobility.hs new file mode 100644 --- /dev/null +++ b/src/ImpureContainers/Misc/Mobility.hs @@ -0,0 +1,32 @@ +-------------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +module ImpureContainers.Misc.Mobility + ( Mobility (Mobile, Pinned) + , M + , P + ) where + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +data Mobility + = -- | FIXME: doc + Mobile + | -- | FIXME: doc + Pinned + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +type M = 'Mobile + +-- | FIXME: doc +type P = 'Pinned + +-------------------------------------------------------------------------------- diff --git a/src/ImpureContainers/PrimRef.hs b/src/ImpureContainers/PrimRef.hs new file mode 100644 --- /dev/null +++ b/src/ImpureContainers/PrimRef.hs @@ -0,0 +1,397 @@ +-------------------------------------------------------------------------------- + +-- License: +-- Copyright 2015 Edward Kmett +-- Copyright 2018 Remy Goldschmidt +-- +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. 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. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + +-------------------------------------------------------------------------------- + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Unsafe #-} + +-------------------------------------------------------------------------------- + +-- | Unboxed primitive references. +-- +-- Note: Edward Kmett wrote everything in this module. It was sitting +-- unpackaged on GitHub, so I took it and published it as a part of +-- this package. +module ImpureContainers.PrimRef + ( -- * 'PrimRef' + PrimRef + + -- ** Creation + , new + , newPinned + , newAlignedPinned + + -- ** Simple functions + , read + , write + , contents + + -- ** Atomic mutators + , atomicReadInt + , atomicWriteInt + , casInt + , fetchAddInt + , fetchSubInt + , fetchAndInt + , fetchNandInt + , fetchOrInt + , fetchXorInt + + -- ** Unsafe functions + , unsafeToMByteArray + , unsafeFromMByteArray + ) where + +-------------------------------------------------------------------------------- + +import Prelude () + +import Control.Applicative (pure) +import Data.Eq (Eq ((==))) +import Data.Function (($)) + +import Control.Monad.Primitive + (PrimMonad, PrimState, primitive, primitive_) + +import Data.Primitive (Addr, Prim, alignment, sizeOf) + +import qualified GHC.Prim as GHC.Prim +import GHC.Types (Int (I#)) + +import ImpureContainers.MByteArray (MByteArray) +import qualified ImpureContainers.MByteArray as MByteArray + +-------------------------------------------------------------------------------- + +-- FIXME: when GHC supports creating newtypes in kind #, we should create a +-- type called PrimRef# to reduce indirections even further. +-- see https://ghc.haskell.org/trac/ghc/ticket/1311 for progress. + +-- | FIXME: doc +newtype PrimRef s a + = MkPrimRef (MByteArray s) + +type role PrimRef nominal nominal + +-------------------------------------------------------------------------------- + +-- | Create a primitive reference. +new + :: (PrimMonad m, Prim a) + => a + -- ^ FIXME: doc + -> m (PrimRef (PrimState m) a) + -- ^ FIXME: doc +new a = do + m <- MByteArray.new (sizeOf a) + MByteArray.write m 0 a + pure (MkPrimRef m) +{-# INLINE new #-} + +-- | Create a pinned primitive reference. +newPinned + :: (PrimMonad m, Prim a) + => a + -- ^ FIXME: doc + -> m (PrimRef (PrimState m) a) + -- ^ FIXME: doc +newPinned a = do + m <- MByteArray.newPinned (sizeOf a) + MByteArray.write m 0 a + pure (MkPrimRef m) +{-# INLINE newPinned #-} + +-- | Create a pinned primitive reference with the appropriate alignment for +-- its contents. +newAlignedPinned + :: (PrimMonad m, Prim a) + => a + -- ^ FIXME: doc + -> m (PrimRef (PrimState m) a) + -- ^ FIXME: doc +newAlignedPinned a = do + m <- MByteArray.newAlignedPinned (sizeOf a) (alignment a) + MByteArray.write m 0 a + pure (MkPrimRef m) +{-# INLINE newAlignedPinned #-} + +-- | Read a primitive value from the reference +read + :: (PrimMonad m, Prim a) + => PrimRef (PrimState m) a + -- ^ FIXME: doc + -> m a + -- ^ FIXME: doc +read (MkPrimRef m) = MByteArray.read m 0 +{-# INLINE read #-} + +-- | Write a primitive value to the reference +write + :: (PrimMonad m, Prim a) + => PrimRef (PrimState m) a + -- ^ FIXME: doc + -> a + -- ^ FIXME: doc + -> m () + -- ^ FIXME: doc +write (MkPrimRef m) a = MByteArray.write m 0 a +{-# INLINE write #-} + +-- | FIXME: doc +instance Eq (PrimRef s a) where + (MkPrimRef m) == (MkPrimRef n) = MByteArray.same m n + {-# INLINE (==) #-} + +-- | Yield a pointer to the data of a 'PrimRef'. +-- +-- This operation is only safe on pinned byte arrays allocated by +-- 'newPinned' or 'newAlignedPinned'. +contents + :: PrimRef s a + -- ^ FIXME: doc + -> Addr + -- ^ FIXME: doc +contents (MkPrimRef m) = MByteArray.contents m +{-# INLINE contents #-} + +-------------------------------------------------------------------------------- + +-- | Given a reference, read an element. +-- +-- Implies a full memory barrier. +atomicReadInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that reads the primitive reference and returns + -- its current value as an 'Int'. +atomicReadInt (MkPrimRef mba) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.atomicReadIntArray# m 0# s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference, write an element. +-- +-- Implies a full memory barrier. +atomicWriteInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ The new value the primitive reference should take on. + -> m () + -- ^ A 'PrimMonad' action that writes the given 'Int' to the given + -- primitive reference. +atomicWriteInt (MkPrimRef mba) (I# x) = primitive_ $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + GHC.Prim.atomicWriteIntArray# m 0# x s + +-- | Given a primitive reference, the expected old value, and the new value, +-- perform an atomic compare-and-swap, i.e.: write the new value if the +-- current value matches the provided old value. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +casInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ The expected old value. + -> Int + -- ^ The new value. + -> m Int + -- ^ A 'PrimMonad' action that atomically writes the new value to the + -- primitive reference if the current value matches the expected old value, + -- and then returns the old value of the primitive reference. +casInt (MkPrimRef mba) (I# oldValue) (I# newValue) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.casIntArray# m 0# oldValue newValue s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference, and a value to add, atomically add the value to the +-- element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchAddInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to add to the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of adding the given 'Int' to its + -- current value, and then returns the value the primitive reference + -- had before this modification. +fetchAddInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchAddIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference and a value to subtract, atomically subtract the value +-- from the element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchSubInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to subtract from the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of subtracting the given 'Int' from + -- its current value, and then returns the value the primitive reference + -- had before this modification. +fetchSubInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchSubIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference and a value with which to bitwise AND, atomically AND +-- the value with the element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchAndInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to AND with the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of bitwise ANDing the given 'Int' + -- with the primitive reference's current value, and then returns the value + -- the primitive reference had before this modification. +fetchAndInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchAndIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference and a value with which to bitwise NAND, atomically NAND +-- the value with the element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchNandInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to NAND with the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of bitwise NANDing the given 'Int' + -- with the primitive reference's current value, and then returns the value + -- the primitive reference had before this modification. +fetchNandInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchNandIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference and a value with which to bitwise OR, atomically OR +-- the value with the element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchOrInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to OR with the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of bitwise ORing the given 'Int' + -- with the primitive reference's current value, and then returns the value + -- the primitive reference had before this modification. +fetchOrInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchOrIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-- | Given a reference, and a value with which to bitwise XOR, atomically XOR +-- the value with the element. +-- +-- Returns the value of the element before the operation. +-- +-- Implies a full memory barrier. +fetchXorInt + :: (PrimMonad m) + => PrimRef (PrimState m) Int + -- ^ A primitive reference. + -> Int + -- ^ An 'Int' to XOR with the current value of the primitive reference. + -> m Int + -- ^ A 'PrimMonad' action that atomically sets the value of the given + -- primitive reference to the result of bitwise XORing the given 'Int' + -- with the primitive reference's current value, and then returns the value + -- the primitive reference had before this modification. +fetchXorInt (MkPrimRef mba) (I# x) = primitive $ \s -> do + let m = MByteArray.underlyingMutableByteArray# mba + case GHC.Prim.fetchXorIntArray# m 0# x s of + (# s', result #) -> (# s', I# result #) + +-------------------------------------------------------------------------------- + +-- | FIXME: doc +unsafeToMByteArray + :: PrimRef s a + -- ^ FIXME: doc + -> MByteArray s + -- ^ FIXME: doc +unsafeToMByteArray (MkPrimRef mba) = mba +{-# INLINE unsafeToMByteArray #-} + +-- | FIXME: doc +unsafeFromMByteArray + :: MByteArray s + -- ^ FIXME: doc + -> PrimRef s a + -- ^ FIXME: doc +unsafeFromMByteArray = MkPrimRef +{-# INLINE unsafeFromMByteArray #-} + +-------------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,40 +2,42 @@ module Main (main) where -import Test.QuickCheck (Gen, Arbitrary(..), choose, shrinkIntegral, - listOf, vectorOf) -import Test.Framework (defaultMain, testGroup, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion,(@?=)) -import Data.Monoid (All(..)) -import Data.Traversable -import Data.Foldable -import Control.Applicative -import Data.Coerce -import Data.Functor.Compose +import Control.Applicative +import Data.Coerce +import Data.Foldable +import Data.Functor.Compose +import Data.Monoid (All (..)) +import Data.Traversable +import Test.Framework + (Test, defaultMain, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck + (Arbitrary (..), Gen, choose, listOf, shrinkIntegral, + vectorOf) -import Data.Word -import Data.Functor.Identity -import Data.Function (on) -import Data.List (groupBy) -import Control.Monad -import Control.Monad.ST -import qualified Data.List as List -import qualified Data.Set as Set -import qualified Data.Map.Strict as Map -import Debug.Trace +import Control.Monad +import Control.Monad.ST +import Data.Function (on) +import Data.Functor.Identity +import Data.List (groupBy) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Word +import Debug.Trace -import Data.Primitive.Array.Maybe +import Data.Primitive.Array.Maybe -import qualified Data.Vector as V -import qualified Data.ArrayList.Generic as ArrayList -import qualified Data.Heap.Mutable.ModelD as HeapD -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) +import qualified Data.ArrayList.Generic as ArrayList +import qualified Data.Graph.Immutable as Graph +import qualified Data.Graph.Mutable as MGraph +import qualified Data.Heap.Mutable.ModelD as HeapD +import Data.Maybe.Unsafe hiding (maybe) +import qualified Data.Maybe.Unsafe as UMaybe +import qualified Data.Trie.Mutable.Bits as BitTrie +import qualified Data.Vector as V main :: IO () main = defaultMain tests @@ -177,9 +179,9 @@ (Just _,Nothing) -> False (Just start, Just end) -> let expected = Min (sum xs) - in expected == Graph.atVertex end - (Graph.dijkstra - (\_ _ (Min x) distance -> Min (x + distance)) + in expected == Graph.atVertex end + (Graph.dijkstra + (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) (Identity start) g )