Try to speed up reading files a bit by using a hash table to store the already-seen promotions.

This didn't actually make anything faster on my test cases -- maybe
this isn't actually the bottleneck?  Anyway, this should make the
code perform better in the face of large numbers of promotions.

2 files changed, 104 insertions, 15 deletions

diff --git a/tools/resolver-visualize/Resolver/Log.hs b/tools/resolver-visualize/Resolver/Log.hs
index 56bc3b7c..6819218f 100644
--- a/tools/resolver-visualize/Resolver/Log.hs
+++ b/tools/resolver-visualize/Resolver/Log.hs
@@ -15,9 +15,10 @@ import Control.Monad.Reader
 import Control.Monad.ST
 import Data.Array
 import Data.ByteString.Char8(ByteString)
+import qualified Data.HashTable as HashTable
 import Data.IORef
 import Data.List(foldl')
-import Data.Maybe(catMaybes, listToMaybe)
+import Data.Maybe(catMaybes, isJust, listToMaybe)
 import Resolver.Parse
 import Resolver.Types
 import Resolver.Util(while)
@@ -214,14 +215,14 @@ data LogParseState = LogParseState {
       --
       -- Used to ensure that only new promotions are included in the
       -- promotions of a particular step.
-      logParseSeenPromotions :: Set.Set Promotion,
+      logParseSeenPromotions :: Maybe (HashTable.HashTable FastPromotion ()),
       -- | The last seen line indicating the resolver is examining a
       -- choice.
       --
       -- Could be "trying to resolve (dep) by installing (ver)", or
       -- "trying to leave (dep) unresolved".
       logParseLastSeenTryChoice :: !LinkChoice
-    } deriving(Show)
+    }
 
 initialState sourceName =
     LogParseState { logParseParseState = initialParseState,
@@ -231,7 +232,7 @@ initialState sourceName =
                     logParseCurrentLine = 0,
                     logParseCurrentLineStart = 0,
                     logParseGeneratingSuccessorsInfo = Nothing,
-                    logParseSeenPromotions = Set.empty,
+                    logParseSeenPromotions = Nothing,
                     logParseLastSeenTryChoice = Unknown }
 
 -- | The log parsing state monad.
@@ -263,7 +264,7 @@ startNewRun loc =
                       st { logParseAllStepsReversed         = [],
                            logParseAllRunsReversed          = runsRev',
                            logParseGeneratingSuccessorsInfo = Nothing,
-                           logParseSeenPromotions           = Set.empty,
+                           logParseSeenPromotions           = Nothing,
                            logParseLastSeenTryChoice        = Unknown }
        put st'
 
@@ -324,15 +325,23 @@ getGeneratingSuccessorsInfo = get >>= return . logParseGeneratingSuccessorsInfo
 
 promotionIsSeen :: Promotion -> LogParse Bool
 promotionIsSeen p = do st <- get
-                       return $ Set.member p (logParseSeenPromotions st)
+                       (case logParseSeenPromotions st of
+                          Nothing   -> return False
+                          Just (ht) -> do found <- liftIO $ HashTable.lookup ht (makeFastPromotion p)
+                                          return $ isJust found)
+
+getOrMakeSeenPromotionsTable :: LogParse (HashTable.HashTable FastPromotion ())
+getOrMakeSeenPromotionsTable =
+    do st <- get
+       case logParseSeenPromotions st of
+         Just ht -> return ht
+         Nothing -> do rval <- liftIO $ HashTable.new (==) fastPromotionHash
+                       put st { logParseSeenPromotions = Just rval }
+                       return rval
 
 addSeenPromotion :: Promotion -> LogParse ()
-addSeenPromotion p = do st <- get
-                        let seenPromotions  = logParseSeenPromotions st
-                            seenPromotions' = Set.insert p seenPromotions
-                            st'             = st { logParseSeenPromotions = seenPromotions' }
-                        (p `seq` seenPromotions' `seq`
-                         put st')
+addSeenPromotion p = do hashTable <- getOrMakeSeenPromotionsTable
+                        liftIO $ HashTable.insert hashTable (makeFastPromotion p) ()
 
 -- | Not strict in the contents of the Maybe.
 setGeneratingSuccessorsInfo :: Maybe GeneratingSuccessorsInfo -> LogParse ()
diff --git a/tools/resolver-visualize/Resolver/Types.hs b/tools/resolver-visualize/Resolver/Types.hs
index 9adbef93..80a77413 100644
--- a/tools/resolver-visualize/Resolver/Types.hs
+++ b/tools/resolver-visualize/Resolver/Types.hs
@@ -1,12 +1,38 @@
 -- | The core data types used to represent packages, versions, and
 -- other problem resolver structures.
 
-module Resolver.Types where
+module Resolver.Types(
+                      Package(..),
+                      Version(..),
+                      Dep(..),
+                      Choice(..),
+                      Solution(..),
+                      FastSolution(fastSol, fastSolHash),
+                      makeFastSolution,
+                      maximumTierNum,
+                      alreadyGeneratedTierNum,
+                      deferTierNum,
+                      minimumTierNum,
+                      Tier(..),
+                      maximumTier,
+                      conflictTier,
+                      alreadyGeneratedTier,
+                      deferTier,
+                      minimumTier,
+                      showsTierComponent,
+                      Promotion(..),
+                      FastPromotion(fastPromotion, fastPromotionHash),
+                      makeFastPromotion
+                     ) where
 
 import Data.ByteString.Char8(ByteString)
+import Data.HashTable(hashString)
+import Data.Int(Int32)
 import Data.Set(Set)
+import qualified Data.Set as Set
 import Data.List
 import Data.Map(Map)
+import qualified Data.Map as Map
 
 -- | Represents a package.
 --
@@ -92,12 +118,34 @@ instance Ord Solution where
     sol1 `compare` sol2 =
         foldr combine EQ [solScore sol1 `compare` solScore sol2,
                           solTier sol1 `compare` solTier sol2,
+                          Set.size (solBrokenDeps sol1) `compare` Set.size (solBrokenDeps sol2),
+                          Set.size (solForbiddenVersions sol1) `compare` Set.size (solForbiddenVersions sol2),
+                          Map.size (solChoices sol1) `compare` Map.size (solChoices sol2),
                           solBrokenDeps sol1 `compare` solBrokenDeps sol2,
                           solForbiddenVersions sol1 `compare` solForbiddenVersions sol2,
                           solChoices sol1 `compare` solChoices sol2]
             where combine EQ o2 = o2
                   combine o1 _  = o1
 
+-- | Used to insert solutions into hash tables reasonably quickly.
+--
+-- Created by hashing the output of the Show instance.
+data FastSolution = FastSolution { fastSol :: Solution, fastSolHash :: Int32 }
+                  deriving(Show)
+
+instance Eq FastSolution where
+    fs1 == fs2 = fastSolHash fs1 == fastSolHash fs2 &&
+                 fastSol fs1 == fastSol fs2
+
+instance Ord FastSolution where
+    fs1 `compare` fs2 = case fastSolHash fs1 `compare` fastSolHash fs2 of
+                          EQ -> fastSol fs1 `compare` fastSol fs2
+                          o  -> o
+
+makeFastSolution :: Solution -> FastSolution
+makeFastSolution sol = FastSolution { fastSol = sol,
+                                      fastSolHash = hashString $ show sol }
+
 maximumTierNum = 2147483647
 alreadyGeneratedTierNum = maximumTierNum - 1
 deferTierNum = alreadyGeneratedTierNum - 1
@@ -130,5 +178,37 @@ data Promotion = Promotion { -- | The choices that produced this promotion.
                              promotionChoices :: Set Choice,
                              -- | The tier of this promotion.
                              promotionTier :: Tier }
-               deriving(Ord, Eq, Show)
-
+               deriving(Show)
+
+instance Eq Promotion where
+    p1 == p2 =
+        promotionTier p1 == promotionTier p2 &&
+        Set.size (promotionChoices p1) == Set.size (promotionChoices p2) &&
+        promotionChoices p1 == promotionChoices p2
+
+instance Ord Promotion where
+    p1 `compare` p2 =
+        foldr combine EQ [promotionTier p1 `compare` promotionTier p2,
+                          Set.size (promotionChoices p1) `compare` Set.size (promotionChoices p2),
+                          promotionChoices p1 `compare` promotionChoices p2]
+        where combine EQ o2 = o2
+              combine o1 _  = o1
+
+data FastPromotion = FastPromotion { fastPromotion :: Promotion,
+                                     fastPromotionHash :: Int32 }
+                   deriving(Show)
+
+instance Eq FastPromotion where
+    fp1 == fp2 =
+        fastPromotionHash fp1 == fastPromotionHash fp2 &&
+        fastPromotion fp1 == fastPromotion fp2
+
+instance Ord FastPromotion where
+    fp1 `compare` fp2 =
+        case fastPromotionHash fp1 `compare` fastPromotionHash fp2 of
+          EQ -> fastPromotion fp1 `compare` fastPromotion fp2
+          o  -> o
+
+makeFastPromotion :: Promotion -> FastPromotion
+makeFastPromotion p = FastPromotion { fastPromotion = p,
+                                      fastPromotionHash = hashString $ show p }