From 708a77f60039204b98899562f0c22653ff269dd0 Mon Sep 17 00:00:00 2001 From: Daniel Burrows Date: Sun, 5 Apr 2009 09:42:12 -0700 Subject: 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. --- tools/resolver-visualize/Resolver/Log.hs | 33 +++++++----- tools/resolver-visualize/Resolver/Types.hs | 86 ++++++++++++++++++++++++++++-- 2 files changed, 104 insertions(+), 15 deletions(-) (limited to 'tools') 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 } -- cgit v1.2.3