959cd0d · typerep-map · git.iko.soy

git.iko.soy/typerep-map

on main help sign in

Binary search with unboxed Int#

959cd0dVladislav Zavialov9 years ago

benchmark/Main.hs+9−6

compare with main

unifiedsplit

@@ -2,13 +2,16 @@ module Main where

3import Criterion.Main (defaultMain)

5−import Map (benchMap)

5+import Map (benchMap, prepareBenchMap)

6−import OptimalVector (benchVectorOpt)

6+-- import OptimalVector (benchVectorOpt)

7−--import Vector (benchVector)

7+import Vector (benchVector, prepareBenchVector)

9main :: IO ()

10+main = do

11+ prepareBenchMap

12+ prepareBenchVector

10−main = defaultMain

13+ defaultMain

11 [ benchMap

14 [ benchMap

12− --, benchVector

15+ , benchVector

13− , benchVectorOpt

16+-- , benchVectorOpt

14 ]

17 ]

benchmark/Map.hs+8−10

@@ -12,19 +12,21 @@

13module Map

14 ( benchMap

15+ , prepareBenchMap

15 ) where

16 ) where

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

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

19import Prelude hiding (lookup)

20import Prelude hiding (lookup)

21−--import Control.DeepSeq (rnf)

22+import Control.Exception

23+import Control.DeepSeq (rnf)

22import Data.Maybe (fromJust)

24import Data.Maybe (fromJust)

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

25import Data.Proxy (Proxy (..))

24import Data.Typeable (Typeable)

26import Data.Typeable (Typeable)

25import GHC.TypeLits

27import GHC.TypeLits

27−import Data.TypeRep.Map (TypeRepMap (..), empty, insert, lookup)

29+import Data.TypeRep.Map (TypeRepMap (..), empty, insert, lookup, keys)

29benchMap :: Benchmark

31benchMap :: Benchmark

30benchMap = bgroup "map"

32benchMap = bgroup "map"

@@ -46,16 +48,12 @@ tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)

46bigMap :: TypeRepMap (Proxy :: Nat -> *)

48bigMap :: TypeRepMap (Proxy :: Nat -> *)

47bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty

49bigMap = buildBigMap 10000 (Proxy :: Proxy 0) empty

49−data Z

50−data S a

51−

52buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *)

51buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> TypeRepMap (Proxy :: Nat -> *) -> TypeRepMap (Proxy :: Nat -> *)

53buildBigMap 1 x = insert x

52buildBigMap 1 x = insert x

54buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))

53buildBigMap n x = insert x . buildBigMap (n - 1) (Proxy :: Proxy (a + 1))

56−--rknf :: TypeRepMap f -> ()

55+rknf :: TypeRepMap f -> ()

57−--rknf = rnf . keys

56+rknf = rnf . keys

59−type family BigProxy (n :: Nat) :: * where

58+prepareBenchMap :: IO ()

60− BigProxy 0 = Z

59+prepareBenchMap = evaluate (rknf bigMap)

61− BigProxy n = S (BigProxy (n - 1))

benchmark/Vector.hs+7−8

@@ -11,12 +11,15 @@

12module Vector

13 ( benchVector

14+ , prepareBenchVector

14 ) where

15 ) where

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

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

18import Prelude hiding (lookup)

19import Prelude hiding (lookup)

21+import Control.Exception

22+import Control.DeepSeq (rnf)

20import Data.Maybe (fromJust)

23import Data.Maybe (fromJust)

21import Data.Proxy (Proxy (..))

24import Data.Proxy (Proxy (..))

22import Data.Typeable (Typeable)

25import Data.Typeable (Typeable)

@@ -44,16 +47,12 @@ tenLookups tmap = (lp, lp, lp, lp, lp, lp, lp, lp)

44bigMap :: TypeRepVector (Proxy :: Nat -> *)

47bigMap :: TypeRepVector (Proxy :: Nat -> *)

45bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []

48bigMap = fromList $ buildBigMap 10000 (Proxy :: Proxy 0) []

47−data Z

48−data S a

49−

50buildBigMap :: forall a . (Typeable a, KnownNat a) => Int -> Proxy (a :: Nat) -> [TF (Proxy :: Nat -> *)] -> [TF (Proxy :: Nat -> *)]

51buildBigMap 1 x = (TF x :)

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

54−-- rknf :: TypeRepMap f -> ()

54+rknf :: TypeRepVector f -> ()

55−-- rknf = rnf . keys

55+rknf = rnf . fingerprints

57−type family BigProxy (n :: Nat) :: * where

57+prepareBenchVector :: IO ()

58− BigProxy 0 = Z

58+prepareBenchVector = evaluate (rknf bigMap)

59− BigProxy n = S (BigProxy (n - 1))

src/Data/TypeRep/Vector.hs+23−105

@@ -8,6 +8,8 @@

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE MagicHash, BangPatterns #-}

13module Data.TypeRep.Vector

15module Data.TypeRep.Vector

@@ -26,107 +28,20 @@ import Control.Arrow ((&&&))

26import Data.Proxy (Proxy (..))

28import Data.Proxy (Proxy (..))

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

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

28import Data.Word (Word64)

30import Data.Word (Word64)

29−import GHC.Base (Any)

31+import GHC.Base hiding (empty)

30import GHC.Exts (sortWith)

32import GHC.Exts (sortWith)

31import GHC.Fingerprint (Fingerprint (..))

33import GHC.Fingerprint (Fingerprint (..))

32import Unsafe.Coerce (unsafeCoerce)

34import Unsafe.Coerce (unsafeCoerce)

35+import Control.Monad.ST

36+import GHC.Prim

34import qualified Data.Vector as V

38import qualified Data.Vector as V

35import qualified Data.Vector.Generic as G

39import qualified Data.Vector.Generic as G

36import qualified Data.Vector.Generic.Mutable as M

40import qualified Data.Vector.Generic.Mutable as M

37−import qualified Data.Vector.Unboxed as Unboxed

41+import qualified Data.Vector.Storable as Storable

38−

39−data instance Unboxed.MVector s Fingerprint = MFingerprintVector (Unboxed.MVector s Word64) (Unboxed.MVector s Word64)

40−data instance Unboxed.Vector Fingerprint = FingerprintVector (Unboxed.Vector Word64) (Unboxed.Vector Word64)

41−

42−instance Unboxed.Unbox Fingerprint

43−

44−instance M.MVector Unboxed.MVector Fingerprint where

45− {-# INLINE basicLength #-}

46− basicLength (MFingerprintVector x _) = M.basicLength x

47− {-# INLINE basicUnsafeSlice #-}

48− basicUnsafeSlice i m (MFingerprintVector a b) =

49− MFingerprintVector (M.basicUnsafeSlice i m a) (M.basicUnsafeSlice i m b)

50− {-# INLINE basicOverlaps #-}

51− basicOverlaps (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) =

52− M.basicOverlaps as1 as2 || M.basicOverlaps bs1 bs2

53− {-# INLINE basicUnsafeNew #-}

54− basicUnsafeNew n_ = do

55− as <- M.basicUnsafeNew n_

56− bs <- M.basicUnsafeNew n_

57− return $ MFingerprintVector as bs

58− {-# INLINE basicInitialize #-}

59− basicInitialize (MFingerprintVector as bs) = do

60− M.basicInitialize as

61− M.basicInitialize bs

62− {-# INLINE basicUnsafeReplicate #-}

63− basicUnsafeReplicate n_ (Fingerprint a b) = do

64− as <- M.basicUnsafeReplicate n_ a

65− bs <- M.basicUnsafeReplicate n_ b

66− return $ MFingerprintVector as bs

67− {-# INLINE basicUnsafeRead #-}

68− basicUnsafeRead (MFingerprintVector as bs) i_ = do

69− a <- M.basicUnsafeRead as i_

70− b <- M.basicUnsafeRead bs i_

71− return (Fingerprint a b)

72− {-# INLINE basicUnsafeWrite #-}

73− basicUnsafeWrite (MFingerprintVector as bs) i_ (Fingerprint a b) = do

74− M.basicUnsafeWrite as i_ a

75− M.basicUnsafeWrite bs i_ b

76− {-# INLINE basicClear #-}

77− basicClear (MFingerprintVector as bs) = do

78− M.basicClear as

79− M.basicClear bs

80− {-# INLINE basicSet #-}

81− basicSet (MFingerprintVector as bs) (Fingerprint a b) = do

82− M.basicSet as a

83− M.basicSet bs b

84− {-# INLINE basicUnsafeCopy #-}

85− basicUnsafeCopy (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do

86− M.basicUnsafeCopy as1 as2

87− M.basicUnsafeCopy bs1 bs2

88− {-# INLINE basicUnsafeMove #-}

89− basicUnsafeMove (MFingerprintVector as1 bs1) (MFingerprintVector as2 bs2) = do

90− M.basicUnsafeMove as1 as2

91− M.basicUnsafeMove bs1 bs2

92− {-# INLINE basicUnsafeGrow #-}

93− basicUnsafeGrow (MFingerprintVector as bs) m_ = do

94− as' <- M.basicUnsafeGrow as m_

95− bs' <- M.basicUnsafeGrow bs m_

96− return $ MFingerprintVector as' bs'

97−

98−instance G.Vector Unboxed.Vector Fingerprint where

99− {-# INLINE basicUnsafeFreeze #-}

100− basicUnsafeFreeze (MFingerprintVector as bs) = do

101− as' <- G.basicUnsafeFreeze as

102− bs' <- G.basicUnsafeFreeze bs

103− return $ FingerprintVector as' bs'

104− {-# INLINE basicUnsafeThaw #-}

105− basicUnsafeThaw (FingerprintVector as bs) = do

106− as' <- G.basicUnsafeThaw as

107− bs' <- G.basicUnsafeThaw bs

108− return $ MFingerprintVector as' bs'

109− {-# INLINE basicLength #-}

110− basicLength (FingerprintVector x _) = G.basicLength x

111− {-# INLINE basicUnsafeSlice #-}

112− basicUnsafeSlice i_ m_ (FingerprintVector as bs) =

113− FingerprintVector (G.basicUnsafeSlice i_ m_ as) (G.basicUnsafeSlice i_ m_ bs)

114− {-# INLINE basicUnsafeIndexM #-}

115− basicUnsafeIndexM (FingerprintVector as bs) i_ = do

116− a <- G.basicUnsafeIndexM as i_

117− b <- G.basicUnsafeIndexM bs i_

118− return (Fingerprint a b)

119− {-# INLINE basicUnsafeCopy #-}

120− basicUnsafeCopy (MFingerprintVector as1 bs1) (FingerprintVector as2 bs2) = do

121− G.basicUnsafeCopy as1 as2

122− G.basicUnsafeCopy bs1 bs2

123− {-# INLINE elemseq #-}

124− elemseq _ (Fingerprint a b)

125− = G.elemseq (undefined :: Unboxed.Vector a) a

126− . G.elemseq (undefined :: Unboxed.Vector b) b

127

128data TypeRepVector f = TypeRepVect

43data TypeRepVector f = TypeRepVect

129− { fingerprints :: Unboxed.Vector Fingerprint

44+ { fingerprints :: V.Vector Fingerprint

130 , anys :: V.Vector Any

45 , anys :: V.Vector Any

131 }

46 }

132

@@ -144,7 +59,7 @@ insert = undefined

144-- | Looks up the value at the type.

59-- | Looks up the value at the type.

145-- >>> let x = lookup $ insert (11 :: Int) empty

60-- >>> let x = lookup $ insert (11 :: Int) empty

146-- >>> x :: Maybe Int

61-- >>> x :: Maybe Int

147−-- Just 11a Ty

62+-- Just 11

148-- >>> x :: Maybe ()

63-- >>> x :: Maybe ()

149-- Nothing

64-- Nothing

150lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)

65lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)

@@ -153,7 +68,7 @@ lookup tVect = fromAny . (anys tVect V.!)

153

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

69-- | Returns the size of the 'TypeRepVect'.

155size :: TypeRepVector f -> Int

70size :: TypeRepVector f -> Int

156−size = Unboxed.length . fingerprints

71+size = V.length . fingerprints

157

158data TF f where

73data TF f where

159 TF :: Typeable a => f a -> TF f

74 TF :: Typeable a => f a -> TF f

@@ -162,7 +77,7 @@ fromF :: Typeable a => f a -> Proxy a

162fromF _ = Proxy

77fromF _ = Proxy

163

164fromList :: forall f . [TF f] -> TypeRepVector f

79fromList :: forall f . [TF f] -> TypeRepVector f

165−fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)

80+fromList tfs = TypeRepVect (V.fromList fps) (V.fromList ans)

166 where

81 where

167 (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs

82 (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs

168

@@ -173,16 +88,19 @@ fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)

173 an (TF x) = unsafeCoerce x

88 an (TF x) = unsafeCoerce x

174

175-- | Returns the index is found.

90-- | Returns the index is found.

176−binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int

91+binarySearch :: Fingerprint -> V.Vector Fingerprint -> Maybe Int

177binarySearch fp fpVect =

92binarySearch fp fpVect =

93+ let

94+ !(I# len) = V.length fpVect

178− let ind = binSearchHelp (-1) (Unboxed.length fpVect) in

95+ ind = I# (binSearchHelp (-1#) len)

96+ in

179− if fp == (fpVect Unboxed.! ind) then Just ind else Nothing

97+ if fp == (fpVect V.! ind) then Just ind else Nothing

180 where

98 where

181− binSearchHelp :: Int -> Int -> Int

99+ binSearchHelp :: Int# -> Int# -> Int#

182− binSearchHelp l r = if l < r - 1

100+ binSearchHelp l r = case l <# (r -# 1#) of

183− then (

101+ 0# -> r

102+ _ ->

184− let m = (l + r) `div` 2 in

103+ let m = uncheckedIShiftRA# (l +# r) 1# in

185− if fpVect Unboxed.! m < fp

104+ if V.unsafeIndex fpVect (I# m) < fp

186 then binSearchHelp m r

105 then binSearchHelp m r

187− else binSearchHelp l m )

106+ else binSearchHelp l m

188− else r

typerep-map.cabal+1

@@ -23,6 +23,7 @@ library

23 build-depends: base

24 , containers

25 , vector

26+ , ghc-prim

26 default-language: Haskell2010

27 default-language: Haskell2010

28test-suite typerep-map-test

29test-suite typerep-map-test