@@ -38,86 +38,10 @@ import qualified Data.Vector.Generic as G
3838import qualified Data.Vector.Generic.Mutable as M
3939import qualified Data.Vector.Unboxed as Unboxed
4040
41−data instance Unboxed.MVector s Fingerprint = MFingerprintVectorOpt (Unboxed.MVector s Word64)
42−data instance Unboxed.Vector Fingerprint = FingerprintVectorOpt (Unboxed.Vector Word64)
43−
44−instance Unboxed.Unbox Fingerprint
45−
46−instance M.MVector Unboxed.MVector Fingerprint where
47− {-# INLINE basicLength #-}
48− basicLength (MFingerprintVectorOpt v) = M.basicLength v `div` 2
49− {-# INLINE basicUnsafeSlice #-}
50− basicUnsafeSlice i n (MFingerprintVectorOpt v) =
51− MFingerprintVectorOpt $ M.basicUnsafeSlice (2 * i) (2 * n) v
52− {-# INLINE basicOverlaps #-}
53− basicOverlaps (MFingerprintVectorOpt v1) (MFingerprintVectorOpt v2) =
54− M.basicOverlaps v1 v2
55− {-# INLINE basicUnsafeNew #-}
56− basicUnsafeNew n = MFingerprintVectorOpt `liftM` M.basicUnsafeNew (2 * n)
57− {-# INLINE basicInitialize #-}
58− basicInitialize (MFingerprintVectorOpt v) = M.basicInitialize v
59− {-# INLINE basicUnsafeReplicate #-}
60− basicUnsafeReplicate n_ (Fingerprint a b) = do
61− v <- M.basicUnsafeNew $ 2 * n_
62− for_ [0, 2 .. 2 * n_ - 1] $ \i -> do
63− M.basicUnsafeWrite v i a
64− M.basicUnsafeWrite v (i + 1) b
65− return $ MFingerprintVectorOpt v
66− {-# INLINE basicUnsafeRead #-}
67− basicUnsafeRead (MFingerprintVectorOpt v) i = do
68− a <- M.basicUnsafeRead v (2 * i)
69− b <- M.basicUnsafeRead v (2 * i + 1)
70− return (Fingerprint a b)
71− {-# INLINE basicUnsafeWrite #-}
72− basicUnsafeWrite (MFingerprintVectorOpt v) i (Fingerprint a b) = do
73− M.basicUnsafeWrite v (2 * i) a
74− M.basicUnsafeWrite v (2 * i + 1) b
75− {-# INLINE basicClear #-}
76− basicClear (MFingerprintVectorOpt v) = M.basicClear v
77− {-# INLINE basicSet #-}
78− basicSet (MFingerprintVectorOpt v) (Fingerprint a b) = do
79− let n = M.basicLength v
80− for_ [0, 2 .. n - 1] $ \i -> do
81− M.basicUnsafeWrite v i a
82− M.basicUnsafeWrite v (i + 1) b
83− {-# INLINE basicUnsafeCopy #-}
84− basicUnsafeCopy (MFingerprintVectorOpt v1) (MFingerprintVectorOpt v2) =
85− M.basicUnsafeCopy v1 v2
86− {-# INLINE basicUnsafeMove #-}
87− basicUnsafeMove (MFingerprintVectorOpt v1) (MFingerprintVectorOpt v2) =
88− M.basicUnsafeMove v1 v2
89− {-# INLINE basicUnsafeGrow #-}
90− basicUnsafeGrow (MFingerprintVectorOpt v) m_ =
91− MFingerprintVectorOpt <$> M.basicUnsafeGrow v (2 * m_)
92−
93−instance G.Vector Unboxed.Vector Fingerprint where
94− {-# INLINE basicUnsafeFreeze #-}
95− basicUnsafeFreeze (MFingerprintVectorOpt v) =
96− FingerprintVectorOpt <$> G.basicUnsafeFreeze v
97− {-# INLINE basicUnsafeThaw #-}
98− basicUnsafeThaw (FingerprintVectorOpt v) = do
99− MFingerprintVectorOpt <$> G.basicUnsafeThaw v
100− {-# INLINE basicLength #-}
101− basicLength (FingerprintVectorOpt v) = G.basicLength v `div` 2
102− {-# INLINE basicUnsafeSlice #-}
103− basicUnsafeSlice i_ m_ (FingerprintVectorOpt v) =
104− FingerprintVectorOpt (G.basicUnsafeSlice (2 * i_) (2 * m_) v)
105− {-# INLINE basicUnsafeIndexM #-}
106− basicUnsafeIndexM (FingerprintVectorOpt v) i_ = do
107− a <- G.basicUnsafeIndexM v (2 * i_)
108− b <- G.basicUnsafeIndexM v (2 * i_ + 1)
109− return (Fingerprint a b)
110− {-# INLINE basicUnsafeCopy #-}
111− basicUnsafeCopy (MFingerprintVectorOpt v1) (FingerprintVectorOpt v2) =
112− G.basicUnsafeCopy v1 v2
113− {-# INLINE elemseq #-}
114− elemseq _ (Fingerprint a b)
115− = G.elemseq (undefined :: Unboxed.Vector a) a
116− . G.elemseq (undefined :: Unboxed.Vector b) b
117−
11841data TypeRepVector f = TypeRepVect
119− { fingerprints :: Unboxed.Vector Fingerprint
120− , anys :: V.Vector Any
42+ { fingerprintAs :: Unboxed.Vector Word64
43+ , fingerprintBs :: Unboxed.Vector Word64
44+ , anys :: V.Vector Any
12145 }
12246
12347fromAny :: Any -> f a
@@ -125,7 +49,7 @@ fromAny = unsafeCoerce
12549
12650-- | Empty structure.
12751empty :: TypeRepVector f
128−empty = TypeRepVect mempty mempty
52+empty = TypeRepVect mempty mempty mempty
12953
13054-- | Inserts the value with its type as a key.
13155insert :: forall a f . Typeable a => a -> TypeRepVector f -> TypeRepVector f
@@ -139,11 +63,11 @@ insert = undefined
13963-- Nothing
14064lookup :: forall a f . Typeable a => TypeRepVector f -> Maybe (f a)
14165lookup tVect = fromAny . (anys tVect V.!)
142− <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprints tVect)
66+ <$> binarySearch (typeRepFingerprint (typeRep (Proxy :: Proxy a))) (fingerprintAs tVect) (fingerprintBs tVect)
14367
14468-- | Returns the size of the 'TypeRepVect'.
14569size :: TypeRepVector f -> Int
146−size = Unboxed.length . fingerprints
70+size = Unboxed.length . fingerprintAs
14771
14872data TF f where
14973 TF :: Typeable a => f a -> TF f
@@ -152,8 +76,9 @@ fromF :: Typeable a => f a -> Proxy a
15276fromF _ = Proxy
15377
15478fromList :: forall f . [TF f] -> TypeRepVector f
155−fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)
79+fromList tfs = TypeRepVect (Unboxed.fromList fpAs) (Unboxed.fromList fpBs) (V.fromList ans)
15680 where
81+ (fpAs, fpBs) = unzip $ fmap (\(Fingerprint a b) -> (a, b)) fps
15782 (fps, ans) = unzip $ sortWith fst $ map (fp &&& an) tfs
15883
15984 fp :: TF f -> Fingerprint
@@ -163,19 +88,20 @@ fromList tfs = TypeRepVect (Unboxed.fromList fps) (V.fromList ans)
16388 an (TF x) = unsafeCoerce x
16489
16590-- | Returns the index is found.
166−binarySearch :: Fingerprint -> Unboxed.Vector Fingerprint -> Maybe Int
167−binarySearch fp fpVect =
91+binarySearch :: Fingerprint -> Unboxed.Vector Word64 -> Unboxed.Vector Word64 -> Maybe Int
92+binarySearch (Fingerprint a _) fpAs _ =
16893 let
169− !(I# len) = Unboxed.length fpVect
94+ !(I# len) = Unboxed.length fpAs
17095 ind = I# (binSearchHelp (-1#) len)
17196 in
172− if fp == (fpVect Unboxed.! ind) then Just ind else Nothing
97+ -- FIXME: Check second component!
98+ if a == (fpAs Unboxed.! ind) then Just ind else Nothing
17399 where
174100 binSearchHelp :: Int# -> Int# -> Int#
175101 binSearchHelp l r = case l <# (r -# 1#) of
176102 0# -> r
177103 _ ->
178104 let m = uncheckedIShiftRA# (l +# r) 1# in
179− if Unboxed.unsafeIndex fpVect (I# m) < fp
105+ if Unboxed.unsafeIndex fpAs (I# m) < a
180106 then binSearchHelp m r
181107 else binSearchHelp l m