9e744d8 · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

[#20] Use PrimArray instead of Vector (#28)

9e744d8Veronika Romashkina8 years ago

benchmark/CacheMap.hs−9

compare with main

unifiedsplit

@@ -10,15 +10,12 @@

11module CacheMap

12 ( benchCacheMap

13− , prepareBenchCacheMap

14 ) where

13 ) where

16import Criterion.Main (Benchmark, bench, bgroup, nf)

15import Criterion.Main (Benchmark, bench, bgroup, nf)

18import Prelude hiding (lookup)

17import Prelude hiding (lookup)

20−import Control.DeepSeq (rnf)

21−import Control.Exception

22import Data.Maybe (fromJust)

19import Data.Maybe (fromJust)

23import Data.Proxy (Proxy (..))

20import Data.Proxy (Proxy (..))

24import Data.Typeable (Typeable)

21import Data.Typeable (Typeable)

@@ -53,9 +50,3 @@ buildBigMap :: forall a . (KnownNat a)

53 -> [TF (Proxy :: Nat -> *)]

50 -> [TF (Proxy :: Nat -> *)]

54buildBigMap 1 x = (TF x :)

51buildBigMap 1 x = (TF x :)

55buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))

52buildBigMap n x = (TF x :) . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))

56−

57−rknf :: TypeRepMap f -> ()

58−rknf tVect = rnf (fingerprintAs tVect, fingerprintBs tVect)

59−

60−prepareBenchCacheMap :: IO ()

61−prepareBenchCacheMap = evaluate (rknf bigMap)

benchmark/Main.hs+1−2

@@ -4,7 +4,7 @@ module Main where

5import Criterion.Main (defaultMain)

7−import CacheMap (benchCacheMap, prepareBenchCacheMap)

7+import CacheMap (benchCacheMap)

8import CMap (benchMap, prepareBenchMap)

9#if ( __GLASGOW_HASKELL__ >= 802 )

10import DMap (benchDMap, prepareBenchDMap)

@@ -15,7 +15,6 @@ import OptimalVector (benchVectorOpt, prepareBenchVectorOpt)

15main :: IO ()

16main = do

17 prepareBenchMap

18− prepareBenchCacheMap

19 --prepareBenchVector

18 --prepareBenchVector

20 prepareBenchVectorOpt

19 prepareBenchVectorOpt

21#if ( __GLASGOW_HASKELL__ >= 802 )

20#if ( __GLASGOW_HASKELL__ >= 802 )

internal/Data/TypeRep/CacheMap.hs+17−16

@@ -39,6 +39,8 @@ import Data.IntMap.Strict (IntMap)

39import Data.Kind (Type)

40import Data.List (nubBy)

41import Data.Maybe (fromJust)

42+import Data.Primitive.Array (Array, indexArray, mapArray')

43+import Data.Primitive.PrimArray (PrimArray, indexPrimArray, sizeofPrimArray)

42import Data.Proxy (Proxy (..))

44import Data.Proxy (Proxy (..))

43import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

45import Data.Typeable (Typeable, typeRep, typeRepFingerprint)

44import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))

46import GHC.Base (Any, Int (..), Int#, (*#), (+#), (<#))

@@ -49,14 +51,13 @@ import GHC.Word (Word64 (..))

49import Unsafe.Coerce (unsafeCoerce)

51import Unsafe.Coerce (unsafeCoerce)

51import qualified Data.IntMap.Strict as IM

53import qualified Data.IntMap.Strict as IM

52−import qualified Data.Vector as V

54+import qualified GHC.Exts as GHC (fromList, toList)

53−import qualified Data.Vector.Unboxed as Unboxed

55-- | Map-like data structure that keeps types as keys.

56-- | Map-like data structure that keeps types as keys.

56data TypeRepMap (f :: k -> Type) = TypeRepMap

57data TypeRepMap (f :: k -> Type) = TypeRepMap

57− { fingerprintAs :: {-# UNPACK #-} !(Unboxed.Vector Word64)

58+ { fingerprintAs :: {-# UNPACK #-} !(PrimArray Word64)

58− , fingerprintBs :: {-# UNPACK #-} !(Unboxed.Vector Word64)

59+ , fingerprintBs :: {-# UNPACK #-} !(PrimArray Word64)

59− , anys :: {-# UNPACK #-} !(V.Vector Any)

60+ , anys :: {-# UNPACK #-} !(Array Any)

60 }

61 }

62-- | Shows only 'Fingerprint's.

63-- | Shows only 'Fingerprint's.

@@ -66,8 +67,8 @@ instance Show (TypeRepMap f) where

66-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.

67-- | Returns the list of 'Fingerprint's from 'TypeRepMap'.

67toFps :: TypeRepMap f -> [Fingerprint]

68toFps :: TypeRepMap f -> [Fingerprint]

68toFps TypeRepMap{..} = zipWith Fingerprint

69toFps TypeRepMap{..} = zipWith Fingerprint

69− (Unboxed.toList fingerprintAs)

70+ (GHC.toList fingerprintAs)

70− (Unboxed.toList fingerprintBs)

71+ (GHC.toList fingerprintBs)

73-- | Empty structure.

74-- | Empty structure.

@@ -121,7 +122,7 @@ Just [True]

121Just "a"

122Just "a"

122-}

123-}

123hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g

124hoist :: (forall x. f x -> g x) -> TypeRepMap f -> TypeRepMap g

124−hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ V.map (toAny . f . fromAny) ans

125+hoist f (TypeRepMap as bs ans) = TypeRepMap as bs $ mapArray' (toAny . f . fromAny) ans

125

126

126{- | Returns 'True' if there exist value of given type.

127{- | Returns 'True' if there exist value of given type.

127

128

@@ -145,7 +146,7 @@ Just (Identity 11)

145Nothing

146Nothing

146-}

147-}

147lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)

148lookup :: forall a f . Typeable a => TypeRepMap f -> Maybe (f a)

148−lookup tVect = fromAny . (anys tVect V.!)

149+lookup tVect = fromAny . (anys tVect `indexArray`)

149 <$> cachedBinarySearch (typeFp @a)

150 <$> cachedBinarySearch (typeFp @a)

150 (fingerprintAs tVect)

151 (fingerprintAs tVect)

151 (fingerprintBs tVect)

152 (fingerprintBs tVect)

@@ -153,22 +154,22 @@ lookup tVect = fromAny . (anys tVect V.!)

153

154

154-- | Returns the size of the 'TypeRepMap'.

155-- | Returns the size of the 'TypeRepMap'.

155size :: TypeRepMap f -> Int

156size :: TypeRepMap f -> Int

156−size = Unboxed.length . fingerprintAs

157+size = sizeofPrimArray . fingerprintAs

157{-# INLINE size #-}

158{-# INLINE size #-}

158

159

159-- | Binary searched based on this article

160-- | Binary searched based on this article

160-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html

161-- http://bannalia.blogspot.com/2015/06/cache-friendly-binary-search.html

161-- with modification for our two-vector search case.

162-- with modification for our two-vector search case.

162−cachedBinarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int

163+cachedBinarySearch :: Fingerprint -> PrimArray Word64 -> PrimArray Word64 -> Maybe Int

163cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

164cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

164 where

165 where

165 go :: Int# -> Maybe Int

166 go :: Int# -> Maybe Int

166 go i = case i <# len of

167 go i = case i <# len of

167 0# -> Nothing

168 0# -> Nothing

168− _ -> let !(W64# valA) = Unboxed.unsafeIndex fpAs (I# i) in case a `ltWord#` valA of

169+ _ -> let !(W64# valA) = indexPrimArray fpAs (I# i) in case a `ltWord#` valA of

169 0# -> case a `eqWord#` valA of

170 0# -> case a `eqWord#` valA of

170 0# -> go (2# *# i +# 2#)

171 0# -> go (2# *# i +# 2#)

171− _ -> let !(W64# valB) = Unboxed.unsafeIndex fpBs (I# i) in case b `eqWord#` valB of

172+ _ -> let !(W64# valB) = indexPrimArray fpBs (I# i) in case b `eqWord#` valB of

172 0# -> case b `ltWord#` valB of

173 0# -> case b `ltWord#` valB of

173 0# -> go (2# *# i +# 2#)

174 0# -> go (2# *# i +# 2#)

174 _ -> go (2# *# i +# 1#)

175 _ -> go (2# *# i +# 1#)

@@ -176,7 +177,7 @@ cachedBinarySearch (Fingerprint (W64# a) (W64# b)) fpAs fpBs = inline (go 0#)

176 _ -> go (2# *# i +# 1#)

177 _ -> go (2# *# i +# 1#)

177

178

178 len :: Int#

179 len :: Int#

179− len = let !(I# l) = Unboxed.length fpAs in l

180+ len = let !(I# l) = sizeofPrimArray fpAs in l

180{-# INLINE cachedBinarySearch #-}

181{-# INLINE cachedBinarySearch #-}

181

182

182----------------------------------------------------------------------------

183----------------------------------------------------------------------------

@@ -194,7 +195,7 @@ typeFp = typeRepFingerprint $ typeRep $ Proxy @a

194{-# INLINE typeFp #-}

195{-# INLINE typeFp #-}

195

196

196toPairList :: TypeRepMap f -> [(Fingerprint, Any)]

197toPairList :: TypeRepMap f -> [(Fingerprint, Any)]

197−toPairList trMap = zip (toFps trMap) (V.toList $ anys trMap)

198+toPairList trMap = zip (toFps trMap) (GHC.toList $ anys trMap)

198

199

199deleteByFst :: Eq a => a -> [(a, b)] -> [(a, b)]

200deleteByFst :: Eq a => a -> [(a, b)] -> [(a, b)]

200deleteByFst x = filter ((/= x) . fst)

201deleteByFst x = filter ((/= x) . fst)

@@ -236,7 +237,7 @@ calcFp :: Typeable a => f a -> Fingerprint

236calcFp = typeRepFingerprint . typeRep . fromF

237calcFp = typeRepFingerprint . typeRep . fromF

237

238

238fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f

239fromListPairs :: [(Fingerprint, Any)] -> TypeRepMap f

239−fromListPairs kvs = TypeRepMap (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)

240+fromListPairs kvs = TypeRepMap (GHC.fromList fpAs) (GHC.fromList fpBs) (GHC.fromList ans)

240 where

241 where

241 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps

242 (fpAs, fpBs) = unzip $ map (\(Fingerprint a b) -> (a, b)) fps

242 (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs

243 (fps, ans) = unzip $ fromSortedList $ sortWith fst $ nubByFst kvs

stack.yaml+3

@@ -1 +1,4 @@

1resolver: nightly-2018-07-05

3+extra-deps:

4+ - primitive-0.6.4.0

typerep-map.cabal+1

@@ -43,6 +43,7 @@ library typerep-map-internal

43 build-depends: base

44 , containers

45 , ghc-prim

46+ , primitive

46 , vector

47 , vector

47 default-extensions: OverloadedStrings

48 default-extensions: OverloadedStrings

48 RecordWildCards

49 RecordWildCards