From a099c1517309e58e19920a9a658845d34bfd308b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 28 Jul 2022 18:35:49 +0100 Subject: [PATCH 1/5] Implement sharing for hls-graph Keys --- ghcide/src/Development/IDE/Core/Shake.hs | 8 +-- ghcide/src/Development/IDE/Types/Shake.hs | 6 +- hls-graph/src/Development/IDE/Graph.hs | 6 +- .../src/Development/IDE/Graph/Database.hs | 2 +- .../Development/IDE/Graph/Internal/Action.hs | 5 +- .../IDE/Graph/Internal/Database.hs | 18 ++--- .../Development/IDE/Graph/Internal/Profile.hs | 10 +-- .../Development/IDE/Graph/Internal/Types.hs | 65 +++++++++++++++---- 8 files changed, 83 insertions(+), 37 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6d43d6e43f..f69f2362c5 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -324,7 +324,7 @@ getPluginConfig plugin = do addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules - void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal) + void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (newKey k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where @@ -399,7 +399,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k - f <- MaybeT $ pure $ HMap.lookup (Key k) pmap + f <- MaybeT $ pure $ HMap.lookup (newKey k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of @@ -1068,7 +1068,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do @@ -1087,7 +1087,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 43298d8a7e..1ebf9e125f 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -26,7 +26,7 @@ import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes (FileVersion) -import Development.IDE.Graph (Key (..), RuleResult) +import Development.IDE.Graph (Key (..), RuleResult, newKey) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location @@ -75,7 +75,7 @@ isBadDependency x | otherwise = False toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key -toKey = (Key.) . curry Q +toKey = (newKey.) . curry Q fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) fromKey (Key k) @@ -91,7 +91,7 @@ fromKeyType (Key k) = case typeOf k of _ -> Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key -toNoFileKey k = Key $ Q (k, emptyFilePath) +toNoFileKey k = newKey $ Q (k, emptyFilePath) newtype Q k = Q (k, NormalizedFilePath) deriving newtype (Eq, Hashable, NFData) diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index ce0711abaa..aa79a6b949 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} module Development.IDE.Graph( - shakeOptions, + shakeOptions, Rules, Action, action, - Key(..), + Key(.., Key), + newKey, actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration ShakeOptions(shakeAllowRedefineRules, shakeExtra), diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 1d5aab3789..b84c39fe2f 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -79,7 +79,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys - return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress + return $ sum $ map (length . getResultDepsDefault mempty . resultDeps) ress -- | Returns an approximation of the database keys, -- annotated with how long ago (in # builds) they were visited diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index 708a414ae5..d711834102 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Foldable (toList) import Data.Functor.Identity +import qualified Data.HashSet as HSet import Data.IORef import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database @@ -39,7 +40,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a) alwaysRerun :: Action () alwaysRerun = do ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>) + liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>) -- No-op for now reschedule :: Double -> Action () @@ -121,7 +122,7 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (ResultDeps (toList is) <>) + liftIO $ modifyIORef ref (ResultDeps (HSet.fromList $ toList is) <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5bb4ed9ff4..af8b6ea1d5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where @@ -87,7 +88,7 @@ build -- build _ st k | traceShow ("build", st, k) False = undefined build db stack keys = do built <- runAIO $ do - built <- builder db stack (fmap Key keys) + built <- builder db stack (fmap newKey keys) case built of Left clean -> return clean Right dirty -> liftIO dirty @@ -145,7 +146,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> do + (Right stack, Just me@Result{resultDeps = ResultDeps (HSet.toList -> deps)}) -> do res <- builder db stack deps let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) case res of @@ -176,7 +177,7 @@ compute db@Database{..} stack key mode result = do actualDeps = if runChanged /= ChangedNothing then deps else previousDeps previousDeps= maybe UnknownDeps resultDeps result let res = Result runValue built' changed built actualDeps execution runStore - case getResultDepsDefault [] actualDeps of + case getResultDepsDefault mempty actualDeps of deps | not(null deps) && runChanged /= ChangedNothing -> do @@ -186,8 +187,8 @@ compute db@Database{..} stack key mode result = do -- on the next build. void $ updateReverseDeps key db - (getResultDepsDefault [] previousDeps) - (HSet.fromList deps) + (getResultDepsDefault mempty previousDeps) + deps _ -> pure () atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues pure res @@ -235,14 +236,13 @@ splitIO act = do updateReverseDeps :: Key -- ^ Id -> Database - -> [Key] -- ^ Previous direct dependencies of Id + -> HashSet Key -- ^ Previous direct dependencies of Id -> HashSet Key -- ^ Current direct dependencies of Id -> IO () -- mask to ensure that all the reverse dependencies are updated updateReverseDeps myId db prev new = do - forM_ prev $ \d -> - unless (d `HSet.member` new) $ - doOne (HSet.delete myId) d + forM_ (HSet.toList $ prev `HSet.difference` new) $ \d -> + doOne (HSet.delete myId) d forM_ (HSet.toList new) $ doOne (HSet.insert myId) where diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 0823070216..4f2a3d4118 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -60,7 +60,7 @@ data ProfileEntry = ProfileEntry -- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value)) resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result resultsOnly mp = Map.map (\r -> - r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r} + r{resultDeps = mapResultDeps (Set.filter (isJust . flip Map.lookup keep)) $ resultDeps r} ) keep where keep = Map.fromList $ mapMaybe (traverse getResult) mp @@ -103,7 +103,7 @@ dependencyOrder shw status = prepareForDependencyOrder :: Database -> IO (HashMap Key Result) prepareForDependencyOrder db = do current <- readTVarIO $ databaseStep db - Map.insert (Key "alwaysRerun") (alwaysRerunResult current) . resultsOnly + Map.insert (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly <$> getDatabaseValues db -- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry @@ -111,7 +111,7 @@ toReport :: Database -> IO ([ProfileEntry], HashMap Key Int) toReport db = do status <- prepareForDependencyOrder db let order = dependencyOrder show - $ map (second (getResultDepsDefault [Key "alwaysRerun"] . resultDeps)) + $ map (second (Set.toList . getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") . resultDeps)) $ Map.toList status ids = Map.fromList $ zip order [0..] @@ -124,14 +124,14 @@ toReport db = do ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ mapMaybe (`Map.lookup` ids) $ getResultDepsDefault [Key "alwaysRerun"] resultDeps + ,prfDepends = map pure $ Map.elems $ Map.intersectionWith const ids $ Set.toMap $ getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps pure ([maybe (error "toReport") (f i) $ Map.lookup i status | i <- order], ids) alwaysRerunResult :: Step -> Result -alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps []) 0 mempty +alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString generateHTML dirtyKeys xs = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 4edcae9ebc..300ec72efe 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -7,6 +7,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Development.IDE.Graph.Internal.Types where @@ -20,6 +23,7 @@ import qualified Data.ByteString as BS import Data.Dynamic import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet, member) +import qualified Data.IntMap as IM import qualified Data.HashSet as Set import Data.IORef import Data.List (intercalate) @@ -32,6 +36,7 @@ import qualified ListT import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) +import System.IO.Unsafe import UnliftIO (MonadUnliftIO) @@ -78,16 +83,54 @@ data ShakeDatabase = ShakeDatabase !Int [Action ()] Database newtype Step = Step Int deriving newtype (Eq,Ord,Hashable) -data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a +--------------------------------------------------------------------- +-- Keys -instance Eq Key where - Key a == Key b = Just a == cast b +data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a -instance Hashable Key where - hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x) +newtype Key = UnsafeMkKey Int + +pattern Key a <- (lookupKeyValue -> KeyValue a) + +data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int + +keyMap :: IORef KeyMap +keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0) + +{-# NOINLINE keyMap #-} +newKey :: (Typeable a, Hashable a, Show a) => a -> Key +newKey k = unsafePerformIO $ do + let !newKey = KeyValue k + atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) -> + let new_key = Map.lookup newKey hm + in case new_key of + Just v -> (km, v) + Nothing -> + let !new_index = UnsafeMkKey n + in (KeyMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) +{-# NOINLINE newKey #-} + +lookupKeyValue :: Key -> KeyValue +lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do + KeyMap _ im _ <- readIORef keyMap + pure $! fromJust (IM.lookup x im) + +{-# NOINLINE lookupKeyValue #-} + +instance Eq Key where + UnsafeMkKey a == UnsafeMkKey b = a == b +instance Hashable Key where + hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x instance Show Key where - show (Key x) = show x + show (Key x) = show x + +instance Eq KeyValue where + KeyValue a == KeyValue b = Just a == cast b +instance Hashable KeyValue where + hashWithSalt i (KeyValue x) = hashWithSalt i (typeOf x, x) +instance Show KeyValue where + show (KeyValue x) = show x newtype Value = Value Dynamic @@ -143,15 +186,15 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key] +data ResultDeps = UnknownDeps | AlwaysRerunDeps !(HashSet Key) | ResultDeps !(HashSet Key) deriving (Eq, Show) -getResultDepsDefault :: [Key] -> ResultDeps -> [Key] +getResultDepsDefault :: (HashSet Key) -> ResultDeps -> (HashSet Key) getResultDepsDefault _ (ResultDeps ids) = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def -mapResultDeps :: ([Key] -> [Key]) -> ResultDeps -> ResultDeps +mapResultDeps :: (HashSet Key -> HashSet Key) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps @@ -159,8 +202,8 @@ mapResultDeps _ UnknownDeps = UnknownDeps instance Semigroup ResultDeps where UnknownDeps <> x = x x <> UnknownDeps = x - AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x) - x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids) + AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault mempty x) + x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault mempty x <> ids) ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids') instance Monoid ResultDeps where From 5c6ffcc6fb2acd00c09ba71f0924d9997822baf5 Mon Sep 17 00:00:00 2001 From: wz1000 Date: Wed, 21 Sep 2022 21:56:05 +0530 Subject: [PATCH 2/5] Update hls-graph/src/Development/IDE/Graph/Internal/Types.hs Co-authored-by: Pepe Iborra --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 300ec72efe..fc007bb517 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -114,7 +114,7 @@ newKey k = unsafePerformIO $ do lookupKeyValue :: Key -> KeyValue lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do KeyMap _ im _ <- readIORef keyMap - pure $! fromJust (IM.lookup x im) + pure $! im IM.! x {-# NOINLINE lookupKeyValue #-} From c1ba14513fecc2484fbc32038695e0b5b2046702 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 28 Sep 2022 15:21:38 +0530 Subject: [PATCH 3/5] hls-graph - avoid duplicating key texts --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- hls-graph/hls-graph.cabal | 1 + hls-graph/src/Development/IDE/Graph.hs | 2 +- .../src/Development/IDE/Graph/Internal/Types.hs | 17 +++++++++++------ 4 files changed, 14 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f69f2362c5..b4c3c53572 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1207,7 +1207,7 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] - update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (T.pack $ show k) new store + update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 10c0cc4b32..77fe7dbb59 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -82,6 +82,7 @@ library , transformers , unliftio , unordered-containers + , text if flag(embed-files) cpp-options: -DFILE_EMBED diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index aa79a6b949..88167f898d 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -4,7 +4,7 @@ module Development.IDE.Graph( Rules, Action, action, Key(.., Key), - newKey, + newKey, renderKey, actionFinally, actionBracket, actionCatch, actionFork, -- * Configuration ShakeOptions(shakeAllowRedefineRules, shakeExtra), diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index fc007bb517..a568281a32 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -25,6 +25,8 @@ import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet, member) import qualified Data.IntMap as IM import qualified Data.HashSet as Set +import qualified Data.Text as T +import Data.Text (Text) import Data.IORef import Data.List (intercalate) import Data.Maybe @@ -86,11 +88,11 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a +data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text newtype Key = UnsafeMkKey Int -pattern Key a <- (lookupKeyValue -> KeyValue a) +pattern Key a <- (lookupKeyValue -> KeyValue a _) data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int @@ -101,7 +103,7 @@ keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0) newKey :: (Typeable a, Hashable a, Show a) => a -> Key newKey k = unsafePerformIO $ do - let !newKey = KeyValue k + let !newKey = KeyValue k (T.pack (show k)) atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) -> let new_key = Map.lookup newKey hm in case new_key of @@ -126,11 +128,14 @@ instance Show Key where show (Key x) = show x instance Eq KeyValue where - KeyValue a == KeyValue b = Just a == cast b + KeyValue a _ == KeyValue b _ = Just a == cast b instance Hashable KeyValue where - hashWithSalt i (KeyValue x) = hashWithSalt i (typeOf x, x) + hashWithSalt i (KeyValue x _) = hashWithSalt i (typeOf x, x) instance Show KeyValue where - show (KeyValue x) = show x + show (KeyValue x t) = T.unpack t + +renderKey :: Key -> Text +renderKey (lookupKeyValue -> KeyValue _ t) = t newtype Value = Value Dynamic From 91da0eb361412cee13ffb2c863bfbc71f73c029b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 28 Sep 2022 16:43:00 +0530 Subject: [PATCH 4/5] Introduce KeyMap and KeySet --- .hlint.yaml | 1 + ghcide/src/Development/IDE/Core/FileStore.hs | 3 +- ghcide/src/Development/IDE/Core/Shake.hs | 28 ++--- hls-graph/hls-graph.cabal | 2 + hls-graph/src/Development/IDE/Graph.hs | 4 + .../src/Development/IDE/Graph/Database.hs | 2 +- .../Development/IDE/Graph/Internal/Action.hs | 3 +- .../IDE/Graph/Internal/Database.hs | 32 +++-- .../Development/IDE/Graph/Internal/Profile.hs | 48 ++++---- .../Development/IDE/Graph/Internal/Types.hs | 116 +++++++++++++++--- hls-graph/src/Development/IDE/Graph/KeyMap.hs | 15 +++ hls-graph/src/Development/IDE/Graph/KeySet.hs | 16 +++ 12 files changed, 189 insertions(+), 81 deletions(-) create mode 100644 hls-graph/src/Development/IDE/Graph/KeyMap.hs create mode 100644 hls-graph/src/Development/IDE/Graph/KeySet.hs diff --git a/.hlint.yaml b/.hlint.yaml index 369bb797f2..a04776b87f 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -59,6 +59,7 @@ - Development.IDE.Graph.Internal.Database - Development.IDE.Graph.Internal.Paths - Development.IDE.Graph.Internal.Profile + - Development.IDE.Graph.Internal.Types - Ide.Types - Test.Hls - Test.Hls.Command diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 93a9c0a90f..860ad11939 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -55,7 +55,6 @@ import qualified Development.IDE.Types.Logger as L import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashSet as HSet import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) @@ -256,7 +255,7 @@ setSomethingModified vfs state keys reason = do atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip HSet.insert) x keys + foldl' (flip insertKeySet) x keys void $ restartShakeSession (shakeExtras state) vfs reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b4c3c53572..5e51fd0fba 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -178,7 +178,7 @@ import System.Time.Extra data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) @@ -197,7 +197,7 @@ instance Pretty Log where vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) - , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) + , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" @@ -279,7 +279,7 @@ data ShakeExtras = ShakeExtras ,clientCapabilities :: ClientCapabilities , withHieDb :: WithHieDb -- ^ Use only to read. , hiedbWriter :: HieDbWriter -- ^ use to write - , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent) + , persistentKeys :: TVar (KeyMap GetStalePersistent) -- ^ Registery for functions that compute/get "stale" results for the rule -- (possibly from disk) , vfsVar :: TVar VFS @@ -290,7 +290,7 @@ data ShakeExtras = ShakeExtras -- We don't need a STM.Map because we never update individual keys ourselves. , defaultConfig :: Config -- ^ Default HLS config, only relevant if the client does not provide any Config - , dirtyKeys :: TVar (HashSet Key) + , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run } @@ -324,7 +324,7 @@ getPluginConfig plugin = do addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules - void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (newKey k) (fmap (fmap (first3 toDyn)) . getVal) + void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) class Typeable a => IsIdeGlobal a where @@ -399,7 +399,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k - f <- MaybeT $ pure $ HMap.lookup (newKey k) pmap + f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of @@ -509,7 +509,7 @@ deleteValue -> STM () deleteValue ShakeExtras{dirtyKeys, state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ HSet.insert (toKey key file) + modifyTVar' dirtyKeys $ insertKeySet (toKey key file) recordDirtyKeys :: Shake.ShakeValue k @@ -518,7 +518,7 @@ recordDirtyKeys -> [NormalizedFilePath] -> STM (IO ()) recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) + modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) @@ -594,7 +594,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty let restartShakeSession = shakeRestart recorder ideState - persistentKeys <- newTVarIO HMap.empty + persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 indexProgressToken <- newVar Nothing @@ -637,7 +637,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer -- monitoring let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras) readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb @@ -797,10 +797,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do workRun restore = withSpan "Shake session" $ \otSpan -> do setTag otSpan "reason" (fromString reason) setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued) - whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) + whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException $ - restore $ shakeRunDatabaseForKeys (HSet.toList <$> allPendingKeys) shakeDb keysActs + restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs return $ do let exception = case res of @@ -890,7 +890,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do = atomicallyNamed "GC" $ do gotIt <- STM.focus (Focus.member <* Focus.delete) k values when gotIt $ - modifyTVar' dk (HSet.insert k) + modifyTVar' dk (insertKeySet k) return $ if gotIt then (counter+1, k:keys) else st | otherwise = pure st @@ -1160,7 +1160,7 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) $ A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (HSet.delete $ toKey key file) + liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 77fe7dbb59..4897ae77b4 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -47,6 +47,8 @@ library Development.IDE.Graph.Classes Development.IDE.Graph.Database Development.IDE.Graph.Rule + Development.IDE.Graph.KeyMap + Development.IDE.Graph.KeySet Development.IDE.Graph.Internal.Action Development.IDE.Graph.Internal.Options Development.IDE.Graph.Internal.Rules diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 88167f898d..98111080a2 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -20,9 +20,13 @@ module Development.IDE.Graph( -- * Actions for inspecting the keys in the database getDirtySet, getKeysAndVisitedAge, + module Development.IDE.Graph.KeyMap, + module Development.IDE.Graph.KeySet, ) where import Development.IDE.Graph.Database +import Development.IDE.Graph.KeyMap +import Development.IDE.Graph.KeySet import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Rules diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index b84c39fe2f..2bed4a2360 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -79,7 +79,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys - return $ sum $ map (length . getResultDepsDefault mempty . resultDeps) ress + return $ sum $ map (lengthKeySet . getResultDepsDefault mempty . resultDeps) ress -- | Returns an approximation of the database keys, -- annotated with how long ago (in # builds) they were visited diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index d711834102..9602f3a10c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -26,7 +26,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Foldable (toList) import Data.Functor.Identity -import qualified Data.HashSet as HSet import Data.IORef import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database @@ -122,7 +121,7 @@ apply ks = do stack <- Action $ asks actionStack (is, vs) <- liftIO $ build db stack ks ref <- Action $ asks actionDeps - liftIO $ modifyIORef ref (ResultDeps (HSet.fromList $ toList is) <>) + liftIO $ modifyIORef ref (ResultDeps (fromListKeySet $ toList is) <>) pure vs -- | Evaluate a list of keys without recording any dependencies. diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index af8b6ea1d5..2ee8212520 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -30,8 +30,6 @@ import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic import Data.Either import Data.Foldable (for_, traverse_) -import Data.HashSet (HashSet) -import qualified Data.HashSet as HSet import Data.IORef.Extra import Data.List.NonEmpty (unzip) import Data.Maybe @@ -61,7 +59,7 @@ incDatabase :: Database -> Maybe [Key] -> IO () incDatabase db (Just kk) = do atomicallyNamed "incDatabase" $ modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 transitiveDirtyKeys <- transitiveDirtySet db kk - for_ transitiveDirtyKeys $ \k -> + for_ (toListKeySet transitiveDirtyKeys) $ \k -> -- Updating all the keys atomically is not necessary -- since we assume that no build is mutating the db. -- Therefore run one transaction per key to minimise contention. @@ -146,7 +144,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps (HSet.toList -> deps)}) -> do + (Right stack, Just me@Result{resultDeps = ResultDeps (toListKeySet -> deps)}) -> do res <- builder db stack deps let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) case res of @@ -178,7 +176,7 @@ compute db@Database{..} stack key mode result = do previousDeps= maybe UnknownDeps resultDeps result let res = Result runValue built' changed built actualDeps execution runStore case getResultDepsDefault mempty actualDeps of - deps | not(null deps) + deps | not(nullKeySet deps) && runChanged /= ChangedNothing -> do -- IMPORTANT: record the reverse deps **before** marking the key Clean. @@ -236,15 +234,15 @@ splitIO act = do updateReverseDeps :: Key -- ^ Id -> Database - -> HashSet Key -- ^ Previous direct dependencies of Id - -> HashSet Key -- ^ Current direct dependencies of Id + -> KeySet -- ^ Previous direct dependencies of Id + -> KeySet -- ^ Current direct dependencies of Id -> IO () -- mask to ensure that all the reverse dependencies are updated updateReverseDeps myId db prev new = do - forM_ (HSet.toList $ prev `HSet.difference` new) $ \d -> - doOne (HSet.delete myId) d - forM_ (HSet.toList new) $ - doOne (HSet.insert myId) + forM_ (toListKeySet $ prev `differenceKeySet` new) $ \d -> + doOne (deleteKeySet myId) d + forM_ (toListKeySet new) $ + doOne (insertKeySet myId) where alterRDeps f = Focus.adjust (onKeyReverseDeps f) @@ -254,18 +252,18 @@ updateReverseDeps myId db prev new = do doOne f id = atomicallyNamed "updateReverseDeps" $ SMap.focus (alterRDeps f) id (databaseValues db) -getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key)) +getReverseDependencies :: Database -> Key -> STM (Maybe KeySet) getReverseDependencies db = (fmap.fmap) keyReverseDeps . flip SMap.lookup (databaseValues db) -transitiveDirtySet :: Foldable t => Database -> t Key -> IO (HashSet Key) -transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop +transitiveDirtySet :: Foldable t => Database -> t Key -> IO KeySet +transitiveDirtySet database = flip State.execStateT mempty . traverse_ loop where loop x = do seen <- State.get - if x `HSet.member` seen then pure () else do - State.put (HSet.insert x seen) + if x `memberKeySet` seen then pure () else do + State.put (insertKeySet x seen) next <- lift $ atomically $ getReverseDependencies database x - traverse_ loop (maybe mempty HSet.toList next) + traverse_ loop (maybe mempty toListKeySet next) -------------------------------------------------------------------------------- -- Asynchronous computations with cancellation diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 4f2a3d4118..d89b8b7a74 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -12,9 +12,7 @@ import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char import Data.Dynamic (toDyn) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map -import qualified Data.HashSet as Set import Data.List (dropWhileEnd, foldl', intercalate, partition, sort, @@ -47,8 +45,8 @@ writeProfile :: FilePath -> Database -> IO () writeProfile out db = do (report, mapping) <- toReport db dirtyKeysMapped <- do - dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db - let dirtyKeysMapped = mapMaybe (`Map.lookup` mapping) . Set.toList $ dirtyIds + dirtyIds <- fromListKeySet . fmap fst <$> getDirtySet db + let dirtyKeysMapped = mapMaybe (`lookupKeyMap` mapping) . toListKeySet $ dirtyIds return $ Just $ sort dirtyKeysMapped rpt <- generateHTML dirtyKeysMapped report LBS.writeFile out rpt @@ -58,17 +56,17 @@ data ProfileEntry = ProfileEntry -- | Eliminate all errors from the database, pretending they don't exist -- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value)) -resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result -resultsOnly mp = Map.map (\r -> - r{resultDeps = mapResultDeps (Set.filter (isJust . flip Map.lookup keep)) $ resultDeps r} +resultsOnly :: [(Key, Status)] -> KeyMap Result +resultsOnly mp = mapKeyMap (\r -> + r{resultDeps = mapResultDeps (filterKeySet (isJust . flip lookupKeyMap keep)) $ resultDeps r} ) keep where - keep = Map.fromList $ mapMaybe (traverse getResult) mp + keep = fromListKeyMap $ mapMaybe (traverse getResult) mp -- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such -- that no item points to an item before itself. -- Raise an error if you end up with a cycle. -dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] +-- dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] -- Algorithm: -- Divide everyone up into those who have no dependencies [Id] -- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])] @@ -78,8 +76,8 @@ dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a] -- k :-> Nothing means the key has already been freed dependencyOrder shw status = f (map fst noDeps) $ - Map.map Just $ - Map.fromListWith (++) + mapKeyMap Just $ + fromListWithKeyMap (++) [(d, [(k,ds)]) | (k,d:ds) <- hasDeps] where (noDeps, hasDeps) = partition (null . snd) status @@ -89,33 +87,33 @@ dependencyOrder shw status = "Internal invariant broken, database seems to be cyclic" : map (" " ++) bad ++ ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow] - where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp] + where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- toListKeyMap mp] f (x:xs) mp = x : f (now++xs) later - where Just free = Map.lookupDefault (Just []) x mp - (now,later) = foldl' g ([], Map.insert x Nothing mp) free + where Just free = lookupDefaultKeyMap (Just []) x mp + (now,later) = foldl' g ([], insertKeyMap x Nothing mp) free g (free, mp) (k, []) = (k:free, mp) - g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of + g (free, mp) (k, d:ds) = case lookupDefaultKeyMap (Just []) d mp of Nothing -> g (free, mp) (k, ds) - Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp) + Just todo -> (free, insertKeyMap d (Just $ (k,ds) : todo) mp) -prepareForDependencyOrder :: Database -> IO (HashMap Key Result) +prepareForDependencyOrder :: Database -> IO (KeyMap Result) prepareForDependencyOrder db = do current <- readTVarIO $ databaseStep db - Map.insert (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly + insertKeyMap (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly <$> getDatabaseValues db -- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry -toReport :: Database -> IO ([ProfileEntry], HashMap Key Int) +toReport :: Database -> IO ([ProfileEntry], KeyMap Int) toReport db = do status <- prepareForDependencyOrder db let order = dependencyOrder show - $ map (second (Set.toList . getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") . resultDeps)) - $ Map.toList status - ids = Map.fromList $ zip order [0..] + $ map (second (toListKeySet . getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") . resultDeps)) + $ toListKeyMap status + ids = fromListKeyMap $ zip order [0..] - steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- Map.elems status] + steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- elemsKeyMap status] in Map.fromList $ zip (sortBy (flip compare) xs) [0..] @@ -124,11 +122,11 @@ toReport db = do ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ Map.elems $ Map.intersectionWith const ids $ Set.toMap $ getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") resultDeps + ,prfDepends = map pure $ elemsKeyMap $ restrictKeysKeyMap ids $ getResultDepsDefault (singletonKeySet $ newKey "alwaysRerun") resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps - pure ([maybe (error "toReport") (f i) $ Map.lookup i status | i <- order], ids) + pure ([maybe (error "toReport") (f i) $ lookupKeyMap i status | i <- order], ids) alwaysRerunResult :: Step -> Result alwaysRerunResult current = Result (Value $ toDyn "") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index a568281a32..c1c4948d97 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -20,11 +20,13 @@ import Control.Monad.Trans.Reader import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (second) import qualified Data.ByteString as BS +import Data.Coerce import Data.Dynamic import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet, member) -import qualified Data.IntMap as IM -import qualified Data.HashSet as Set +import qualified Data.IntMap.Strict as IM +import Data.IntMap (IntMap) +import qualified Data.IntSet as IS +import Data.IntSet (IntSet) import qualified Data.Text as T import Data.Text (Text) import Data.IORef @@ -88,34 +90,34 @@ newtype Step = Step Int --------------------------------------------------------------------- -- Keys -data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a Text +data KeyValue = forall a . (Eq a, Typeable a, Hashable a, Show a) => KeyValue a Text newtype Key = UnsafeMkKey Int pattern Key a <- (lookupKeyValue -> KeyValue a _) -data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int +data GlobalKeyValueMap = GlobalKeyValueMap !(Map.HashMap KeyValue Key) !(IntMap KeyValue) {-# UNPACK #-} !Int -keyMap :: IORef KeyMap -keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0) +keyMap :: IORef GlobalKeyValueMap +keyMap = unsafePerformIO $ newIORef (GlobalKeyValueMap Map.empty IM.empty 0) {-# NOINLINE keyMap #-} -newKey :: (Typeable a, Hashable a, Show a) => a -> Key +newKey :: (Eq a, Typeable a, Hashable a, Show a) => a -> Key newKey k = unsafePerformIO $ do let !newKey = KeyValue k (T.pack (show k)) - atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) -> + atomicModifyIORef' keyMap $ \km@(GlobalKeyValueMap hm im n) -> let new_key = Map.lookup newKey hm in case new_key of Just v -> (km, v) Nothing -> let !new_index = UnsafeMkKey n - in (KeyMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) + in (GlobalKeyValueMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index) {-# NOINLINE newKey #-} lookupKeyValue :: Key -> KeyValue lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do - KeyMap _ im _ <- readIORef keyMap + GlobalKeyValueMap _ im _ <- readIORef keyMap pure $! im IM.! x {-# NOINLINE lookupKeyValue #-} @@ -137,14 +139,88 @@ instance Show KeyValue where renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t +newtype KeySet = KeySet IntSet + deriving (Eq, Ord, Semigroup, Monoid) + +instance Show KeySet where + showsPrec p (KeySet is)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IS.toList is) :: [Key] + +insertKeySet :: Key -> KeySet -> KeySet +insertKeySet = coerce IS.insert + +memberKeySet :: Key -> KeySet -> Bool +memberKeySet = coerce IS.member + +toListKeySet :: KeySet -> [Key] +toListKeySet = coerce IS.toList + +nullKeySet :: KeySet -> Bool +nullKeySet = coerce IS.null + +differenceKeySet :: KeySet -> KeySet -> KeySet +differenceKeySet = coerce IS.difference + +deleteKeySet :: Key -> KeySet -> KeySet +deleteKeySet = coerce IS.delete + +fromListKeySet :: [Key] -> KeySet +fromListKeySet = coerce IS.fromList + +singletonKeySet :: Key -> KeySet +singletonKeySet = coerce IS.singleton + +filterKeySet :: (Key -> Bool) -> KeySet -> KeySet +filterKeySet = coerce IS.filter + +lengthKeySet :: KeySet -> Int +lengthKeySet = coerce IS.size + +newtype KeyMap a = KeyMap (IntMap a) + deriving (Eq, Ord, Semigroup, Monoid) + +instance Show a => Show (KeyMap a) where + showsPrec p (KeyMap im)= showParen (p > 10) $ + showString "fromList " . shows ks + where ks = coerce (IM.toList im) :: [(Key,a)] + +mapKeyMap :: (a -> b) -> KeyMap a -> KeyMap b +mapKeyMap f (KeyMap m) = KeyMap (IM.map f m) + +insertKeyMap :: Key -> a -> KeyMap a -> KeyMap a +insertKeyMap (UnsafeMkKey k) v (KeyMap m) = KeyMap (IM.insert k v m) + +lookupKeyMap :: Key -> KeyMap a -> Maybe a +lookupKeyMap (UnsafeMkKey k) (KeyMap m) = IM.lookup k m + +lookupDefaultKeyMap :: a -> Key -> KeyMap a -> a +lookupDefaultKeyMap a (UnsafeMkKey k) (KeyMap m) = IM.findWithDefault a k m + +fromListKeyMap :: [(Key,a)] -> KeyMap a +fromListKeyMap xs = KeyMap (IM.fromList (coerce xs)) + +fromListWithKeyMap :: (a -> a -> a) -> [(Key,a)] -> KeyMap a +fromListWithKeyMap f xs = KeyMap (IM.fromListWith f (coerce xs)) + +toListKeyMap :: KeyMap a -> [(Key,a)] +toListKeyMap (KeyMap m) = coerce (IM.toList m) + +elemsKeyMap :: KeyMap a -> [a] +elemsKeyMap (KeyMap m) = IM.elems m + +restrictKeysKeyMap :: KeyMap a -> KeySet -> KeyMap a +restrictKeysKeyMap (KeyMap m) (KeySet s) = KeyMap (IM.restrictKeys m s) + + newtype Value = Value Dynamic data KeyDetails = KeyDetails { keyStatus :: !Status, - keyReverseDeps :: !(HashSet Key) + keyReverseDeps :: !KeySet } -onKeyReverseDeps :: (HashSet Key -> HashSet Key) -> KeyDetails -> KeyDetails +onKeyReverseDeps :: (KeySet -> KeySet) -> KeyDetails -> KeyDetails onKeyReverseDeps f it@KeyDetails{..} = it{keyReverseDeps = f keyReverseDeps} @@ -191,15 +267,15 @@ data Result = Result { resultData :: !BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps !(HashSet Key) | ResultDeps !(HashSet Key) +data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps !KeySet deriving (Eq, Show) -getResultDepsDefault :: (HashSet Key) -> ResultDeps -> (HashSet Key) +getResultDepsDefault :: KeySet -> ResultDeps -> KeySet getResultDepsDefault _ (ResultDeps ids) = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def -mapResultDeps :: (HashSet Key -> HashSet Key) -> ResultDeps -> ResultDeps +mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps @@ -273,7 +349,7 @@ fromGraphException x = do --------------------------------------------------------------------- -- CALL STACK -data Stack = Stack [Key] !(HashSet Key) +data Stack = Stack [Key] !KeySet instance Show Stack where show (Stack kk _) = "Stack: " <> intercalate " -> " (map show kk) @@ -288,12 +364,12 @@ instance Exception StackException where addStack :: Key -> Stack -> Either StackException Stack addStack k (Stack ks is) - | k `member` is = Left $ StackException stack2 + | k `memberKeySet` is = Left $ StackException stack2 | otherwise = Right stack2 - where stack2 = Stack (k:ks) (Set.insert k is) + where stack2 = Stack (k:ks) (insertKeySet k is) memberStack :: Key -> Stack -> Bool -memberStack k (Stack _ ks) = k `member` ks +memberStack k (Stack _ ks) = k `memberKeySet` ks emptyStack :: Stack emptyStack = Stack [] mempty diff --git a/hls-graph/src/Development/IDE/Graph/KeyMap.hs b/hls-graph/src/Development/IDE/Graph/KeyMap.hs new file mode 100644 index 0000000000..daa1ae8642 --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/KeyMap.hs @@ -0,0 +1,15 @@ +module Development.IDE.Graph.KeyMap( + Key, + KeyMap, + mapKeyMap, + insertKeyMap, + lookupKeyMap, + lookupDefaultKeyMap, + fromListKeyMap, + fromListWithKeyMap, + toListKeyMap, + elemsKeyMap, + restrictKeysKeyMap, + ) where + +import Development.IDE.Graph.Internal.Types diff --git a/hls-graph/src/Development/IDE/Graph/KeySet.hs b/hls-graph/src/Development/IDE/Graph/KeySet.hs new file mode 100644 index 0000000000..ef8c46e6b5 --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/KeySet.hs @@ -0,0 +1,16 @@ +module Development.IDE.Graph.KeySet( + Key, + KeySet, + insertKeySet, + memberKeySet, + toListKeySet, + nullKeySet, + differenceKeySet, + deleteKeySet, + fromListKeySet, + singletonKeySet, + filterKeySet, + lengthKeySet, + ) where + +import Development.IDE.Graph.Internal.Types From b426e44f41d5aee3698318a17a11976dce788092 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Wed, 19 Oct 2022 18:00:29 +0530 Subject: [PATCH 5/5] Fix testing hls-graph --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 4 ++-- hls-graph/test/ActionSpec.hs | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index c1c4948d97..8451f641a3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -140,7 +140,7 @@ renderKey :: Key -> Text renderKey (lookupKeyValue -> KeyValue _ t) = t newtype KeySet = KeySet IntSet - deriving (Eq, Ord, Semigroup, Monoid) + deriving newtype (Eq, Ord, Semigroup, Monoid) instance Show KeySet where showsPrec p (KeySet is)= showParen (p > 10) $ @@ -178,7 +178,7 @@ lengthKeySet :: KeySet -> Int lengthKeySet = coerce IS.size newtype KeyMap a = KeyMap (IntMap a) - deriving (Eq, Ord, Semigroup, Monoid) + deriving newtype (Eq, Ord, Semigroup, Monoid) instance Show a => Show (KeyMap a) where showsPrec p (KeyMap im)= showParen (p > 10) $ diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index d79e6edb40..171e90214b 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -43,8 +43,8 @@ spec = do pure $ do apply1 theKey res `shouldBe` [True] - Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb - resultDeps res `shouldBe` ResultDeps [Key (Rule @())] + Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb + resultDeps res `shouldBe` ResultDeps (singletonKeySet $ newKey (Rule @())) it "tracks reverse dependencies" $ do db@(ShakeDatabase _ _ Database {..}) <- shakeNewDatabase shakeOptions $ do ruleUnit @@ -54,8 +54,8 @@ spec = do pure $ do apply1 theKey res `shouldBe` [True] - Just KeyDetails {..} <- atomically $ STM.lookup (Key (Rule @())) databaseValues - keyReverseDeps `shouldBe` HashSet.fromList [Key theKey] + Just KeyDetails {..} <- atomically $ STM.lookup (newKey (Rule @())) databaseValues + keyReverseDeps `shouldBe` (singletonKeySet $ newKey theKey) it "rethrows exceptions" $ do db <- shakeNewDatabase shakeOptions $ do addRule $ \(Rule :: Rule ()) old mode -> error "boom" @@ -74,5 +74,5 @@ spec = do pure $ do applyWithoutDependency [theKey] res `shouldBe` [[True]] - Just (Clean res) <- lookup (Key theKey) <$> getDatabaseValues theDb + Just (Clean res) <- lookup (newKey theKey) <$> getDatabaseValues theDb resultDeps res `shouldBe` UnknownDeps