From d4de4de02c3a886fb56854ba09c7b034a52ea6e9 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Fri, 19 Nov 2021 13:30:20 +0000 Subject: [PATCH 1/2] Fix incomplete pattern match warning in 8.8 --- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 1825688d62..201b5d89f3 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -681,6 +681,9 @@ uniqueCompl candidate unique = importedFrom (provenance -> ImportedFrom m) = m importedFrom (provenance -> DefinedIn m) = m importedFrom (provenance -> Local _) = "local" +#if __GLASGOW_HASKELL__ < 810 + importedFrom _ = "" +#endif -- --------------------------------------------------------------------- -- helper functions for infix backticks From 9082374a81693feb9491758b64c0e50325a30c9a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 15 Nov 2021 00:19:53 +0000 Subject: [PATCH 2/2] lock-less hls-graph --- ghcide/.hlint.yaml | 1 - hls-graph/hls-graph.cabal | 6 +- .../src/Development/IDE/Graph/Database.hs | 14 +- .../Development/IDE/Graph/Internal/Action.hs | 2 +- .../IDE/Graph/Internal/Database.hs | 243 +++++++++--------- .../src/Development/IDE/Graph/Internal/Ids.hs | 160 ------------ .../Development/IDE/Graph/Internal/Intern.hs | 41 --- .../Development/IDE/Graph/Internal/Profile.hs | 45 ++-- .../Development/IDE/Graph/Internal/Types.hs | 73 ++++-- stack-8.10.6.yaml | 2 + stack-8.10.7.yaml | 2 + stack-8.6.5.yaml | 4 + stack-8.8.3.yaml | 4 + stack-8.8.4.yaml | 4 + stack.yaml | 4 + 15 files changed, 221 insertions(+), 384 deletions(-) delete mode 100644 hls-graph/src/Development/IDE/Graph/Internal/Ids.hs delete mode 100644 hls-graph/src/Development/IDE/Graph/Internal/Intern.hs diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 84cd0879a8..5044ebff09 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -77,7 +77,6 @@ - {name: GeneralizedNewtypeDeriving, within: []} - {name: LambdaCase, within: []} - {name: NamedFieldPuns, within: []} - - {name: PackageImports, within: []} - {name: RecordWildCards, within: []} - {name: ScopedTypeVariables, within: []} - {name: StandaloneDeriving, within: []} diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 1fbac6533b..0346368ce7 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -42,8 +42,6 @@ library Development.IDE.Graph.Internal.Options Development.IDE.Graph.Internal.Rules Development.IDE.Graph.Internal.Database - Development.IDE.Graph.Internal.Ids - Development.IDE.Graph.Internal.Intern Development.IDE.Graph.Internal.Paths Development.IDE.Graph.Internal.Profile Development.IDE.Graph.Internal.Types @@ -63,11 +61,15 @@ library , exceptions , extra , filepath + , focus , hashable , js-dgtable , js-flot , js-jquery + , list-t , primitive + , stm + , stm-containers , time , transformers , unordered-containers diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index c3467ae905..1c5a3bc2fc 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -12,13 +12,13 @@ module Development.IDE.Graph.Database( shakeGetDirtySet, shakeGetCleanKeys ,shakeGetBuildEdges) where +import Control.Concurrent.STM (atomically, + readTVarIO) import Data.Dynamic -import Data.IORef (readIORef) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action import Development.IDE.Graph.Internal.Database -import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Options import Development.IDE.Graph.Internal.Profile (writeProfile) import Development.IDE.Graph.Internal.Rules @@ -45,12 +45,12 @@ shakeRunDatabase = shakeRunDatabaseForKeys Nothing -- | Returns the set of dirty keys annotated with their age (in # of builds) shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] shakeGetDirtySet (ShakeDatabase _ _ db) = - fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + Development.IDE.Graph.Internal.Database.getDirtySet db -- | Returns the build number shakeGetBuildStep :: ShakeDatabase -> IO Int shakeGetBuildStep (ShakeDatabase _ _ db) = do - Step s <- readIORef $ databaseStep db + Step s <- readTVarIO $ databaseStep db return s -- Only valid if we never pull on the results, which we don't @@ -64,7 +64,7 @@ shakeRunDatabaseForKeys -> [Action a] -> IO ([a], [IO ()]) shakeRunDatabaseForKeys keysChanged (ShakeDatabase lenAs1 as1 db) as2 = do - incDatabase db keysChanged + atomically $ incDatabase db keysChanged as <- fmap (drop lenAs1) $ runActions db $ map unvoid as1 ++ as2 return (as, []) @@ -75,12 +75,12 @@ shakeProfileDatabase (ShakeDatabase _ _ s) file = writeProfile file s -- | Returns the clean keys in the database shakeGetCleanKeys :: ShakeDatabase -> IO [(Key, Result )] shakeGetCleanKeys (ShakeDatabase _ _ db) = do - keys <- Ids.elems $ databaseValues db + keys <- getDatabaseValues db return [ (k,res) | (k, Clean res) <- keys] -- | Returns the total count of edges in the build graph shakeGetBuildEdges :: ShakeDatabase -> IO Int shakeGetBuildEdges (ShakeDatabase _ _ db) = do - keys <- Ids.elems $ databaseValues db + keys <- getDatabaseValues db let ress = mapMaybe (getResult . snd) keys return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ad895c17c3..5deadb5f98 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -130,7 +130,7 @@ runActions db xs = do getDirtySet :: Action [(Key, Int)] getDirtySet = do db <- getDatabase - liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + liftIO $ Development.IDE.Graph.Internal.Database.getDirtySet db getKeysAndVisitedAge :: Action [(Key, Int)] getKeysAndVisitedAge = do diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 4b8a1d985c..00e9cf8e53 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -15,69 +16,69 @@ module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, import Control.Concurrent.Async import Control.Concurrent.Extra +import Control.Concurrent.STM (STM, atomically, + modifyTVar', newTVarIO, + readTVarIO) import Control.Exception import Control.Monad -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.State.Strict as State import Data.Dynamic import Data.Either -import Data.Foldable (traverse_) +import Data.Foldable (for_, traverse_) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet import Data.IORef.Extra -import Data.IntSet (IntSet) -import qualified Data.IntSet as Set import Data.Maybe +import Data.Traversable (for) import Data.Tuple.Extra import Development.IDE.Graph.Classes -import qualified Development.IDE.Graph.Internal.Ids as Ids -import Development.IDE.Graph.Internal.Intern -import qualified Development.IDE.Graph.Internal.Intern as Intern import Development.IDE.Graph.Internal.Rules import Development.IDE.Graph.Internal.Types +import qualified Focus +import qualified ListT +import qualified StmContainers.Map as SMap import System.IO.Unsafe -import System.Time.Extra (duration) +import System.Time.Extra (duration) newDatabase :: Dynamic -> TheRules -> IO Database newDatabase databaseExtra databaseRules = do - databaseStep <- newIORef $ Step 0 - databaseLock <- newLock - databaseIds <- newIORef Intern.empty - databaseValues <- Ids.empty - databaseReverseDeps <- Ids.empty - databaseReverseDepsLock <- newLock + databaseStep <- newTVarIO $ Step 0 + databaseValues <- atomically SMap.new pure Database{..} -- | Increment the step and mark dirty -incDatabase :: Database -> Maybe [Key] -> IO () --- all keys are dirty -incDatabase db Nothing = do - modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 - withLock (databaseLock db) $ - Ids.forMutate (databaseValues db) $ \_ -> second $ \case - Clean x -> Dirty (Just x) - Dirty x -> Dirty x - Running _ _ x -> Dirty x +incDatabase :: Database -> Maybe [Key] -> STM () -- only some keys are dirty incDatabase db (Just kk) = do - modifyIORef' (databaseStep db) $ \(Step i) -> Step $ i + 1 - intern <- readIORef (databaseIds db) - let dirtyIds = mapMaybe (`Intern.lookup` intern) kk - transitiveDirtyIds <- transitiveDirtySet db dirtyIds - withLock (databaseLock db) $ - Ids.forMutate (databaseValues db) $ \i -> \case - (k, Running _ _ x) -> (k, Dirty x) - (k, Clean x) | i `Set.member` transitiveDirtyIds -> - (k, Dirty (Just x)) - other -> other - + modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 + transitiveDirtyKeys <- transitiveDirtySet db kk + for_ transitiveDirtyKeys $ \k -> + SMap.focus updateDirty k (databaseValues db) +-- all keys are dirty +incDatabase db Nothing = do + modifyTVar' (databaseStep db) $ \(Step i) -> Step $ i + 1 + let list = SMap.listT (databaseValues db) + flip ListT.traverse_ list $ \(k,_) -> do + SMap.focus updateDirty k (databaseValues db) + +updateDirty :: Monad m => Focus.Focus KeyDetails m () +updateDirty = Focus.adjust $ \(KeyDetails status rdeps) -> + let status' + | Running _ _ _ x <- status = Dirty x + | Clean x <- status = Dirty (Just x) + | otherwise = status + in KeyDetails status' rdeps -- | Unwrap and build a list of keys in parallel build :: forall key value . (RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value) - => Database -> [key] -> IO ([Id], [value]) + => Database -> [key] -> IO ([Key], [value]) build db keys = do - (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< builder db (map (Right . Key) keys) + (ids, vs) <- runAIO $ fmap unzip $ either return liftIO =<< + builder db (map Key keys) pure (ids, map (asV . resultValue) vs) where asV :: Value -> value @@ -87,80 +88,67 @@ build db keys = do -- If none of the keys are dirty, we can return the results immediately. -- Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock. builder - :: Database -> [Either Id Key] -> AIO (Either [(Id, Result)] (IO [(Id, Result)])) -builder db@Database{..} keys = do - -- Things that I need to force before my results are ready - toForce <- liftIO $ newIORef [] - - results <- withLockAIO databaseLock $ do - flip traverse keys $ \idKey -> do - -- Resolve the id - id <- case idKey of - Left id -> pure id - Right key -> liftIO $ do - ids <- readIORef databaseIds - case Intern.lookup key ids of - Just v -> pure v - Nothing -> do - (ids, id) <- pure $ Intern.add key ids - writeIORef' databaseIds ids - return id - - -- Spawn the id if needed - status <- liftIO $ Ids.lookup databaseValues id - val <- case fromMaybe (fromRight undefined idKey, Dirty Nothing) status of - (_, Clean r) -> pure r - (_, Running force val _) -> do - liftIO $ modifyIORef toForce (Wait force :) - pure val - (key, Dirty s) -> do - act <- unliftAIO (refresh db key id s) - let (force, val) = splitIO (join act) - liftIO $ Ids.insert databaseValues id (key, Running force val s) - liftIO $ modifyIORef toForce (Spawn force:) - pure val - - pure (id, val) - - toForceList <- liftIO $ readIORef toForce - waitAll <- unliftAIO $ mapConcurrentlyAIO_ id toForceList - case toForceList of - [] -> return $ Left results - _ -> return $ Right $ do - waitAll - pure results + :: Database -> [Key] -> AIO (Either [(Key, Result)] (IO [(Key, Result)])) +builder db@Database{..} keys = withRunInIO $ \(RunInIO run) -> do + -- Things that I need to force before my results are ready + toForce <- liftIO $ newTVarIO [] + current <- liftIO $ readTVarIO databaseStep + results <- liftIO $ atomically $ for keys $ \id -> do + -- Spawn the id if needed + status <- SMap.lookup id databaseValues + val <- case viewDirty current $ maybe (Dirty Nothing) keyStatus status of + Clean r -> pure r + Running _ force val _ -> do + modifyTVar' toForce (Wait force :) + pure val + Dirty s -> do + let act = run (refresh db id s) + (force, val) = splitIO (join act) + SMap.focus (updateStatus $ Running current force val s) id databaseValues + modifyTVar' toForce (Spawn force:) + pure val + + pure (id, val) + + toForceList <- liftIO $ readTVarIO toForce + let waitAll = run $ mapConcurrentlyAIO_ id toForceList + case toForceList of + [] -> return $ Left results + _ -> return $ Right $ do + waitAll + pure results -- | Refresh a key: -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself -refresh :: Database -> Key -> Id -> Maybe Result -> AIO (IO Result) -refresh db key id result@(Just me@Result{resultDeps = ResultDeps deps}) = do - res <- builder db $ map Left deps +refresh :: Database -> Key -> Maybe Result -> AIO (IO Result) +refresh db key result@(Just me@Result{resultDeps = ResultDeps deps}) = do + res <- builder db deps case res of Left res -> if isDirty res - then asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result - else pure $ compute db key id RunDependenciesSame result + then asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result + else pure $ compute db key RunDependenciesSame result Right iores -> asyncWithCleanUp $ liftIO $ do res <- iores let mode = if isDirty res then RunDependenciesChanged else RunDependenciesSame - compute db key id mode result + compute db key mode result where isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep) -refresh db key id result = - asyncWithCleanUp $ liftIO $ compute db key id RunDependenciesChanged result +refresh db key result = + asyncWithCleanUp $ liftIO $ compute db key RunDependenciesChanged result -- | Compute a key. -compute :: Database -> Key -> Id -> RunMode -> Maybe Result -> IO Result -compute db@Database{..} key id mode result = do +compute :: Database -> Key -> RunMode -> Maybe Result -> IO Result +compute db@Database{..} key mode result = do let act = runRule databaseRules key (fmap resultData result) mode deps <- newIORef UnknownDeps (execution, RunResult{..}) <- duration $ runReaderT (fromAction act) $ SAction db deps - built <- readIORef databaseStep + built <- readTVarIO databaseStep deps <- readIORef deps let changed = if runChanged == ChangedRecomputeDiff then built else maybe built resultChanged result built' = if runChanged /= ChangedNothing then built else changed @@ -173,28 +161,34 @@ compute db@Database{..} key id mode result = do && runChanged /= ChangedNothing -> do void $ forkIO $ - updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps) + updateReverseDeps key db + (getResultDepsDefault [] previousDeps) + (HSet.fromList deps) _ -> pure () - withLock databaseLock $ - Ids.insert databaseValues id (key, Clean res) + atomically $ SMap.focus (updateStatus $ Clean res) key databaseValues pure res +updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () +updateStatus res = Focus.alter + (Just . maybe (KeyDetails res mempty) + (\it -> it{keyStatus = res})) + -- | Returns the set of dirty keys annotated with their age (in # of builds) -getDirtySet :: Database -> IO [(Id,(Key, Int))] +getDirtySet :: Database -> IO [(Key, Int)] getDirtySet db = do - Step curr <- readIORef (databaseStep db) - dbContents <- Ids.toList (databaseValues db) + Step curr <- readTVarIO (databaseStep db) + dbContents <- getDatabaseValues db let calcAge Result{resultBuilt = Step x} = curr - x calcAgeStatus (Dirty x)=calcAge <$> x calcAgeStatus _ = Nothing - return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents + return $ mapMaybe (secondM calcAgeStatus) dbContents -- | Returns ann approximation of the database keys, -- annotated with how long ago (in # builds) they were visited getKeysAndVisitAge :: Database -> IO [(Key, Int)] getKeysAndVisitAge db = do - values <- Ids.elems (databaseValues db) - Step curr <- readIORef (databaseStep db) + values <- getDatabaseValues db + Step curr <- readTVarIO (databaseStep db) let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values getAge Result{resultVisited = Step s} = curr - s return keysWithVisitAge @@ -215,34 +209,35 @@ splitIO act = do -- | Update the reverse dependencies of an Id updateReverseDeps - :: Id -- ^ Id + :: Key -- ^ Id -> Database - -> [Id] -- ^ Previous direct dependencies of Id - -> IntSet -- ^ Current direct dependencies of Id + -> [Key] -- ^ Previous direct dependencies of Id + -> HashSet Key -- ^ Current direct dependencies of Id -> IO () -updateReverseDeps myId db prev new = withLock (databaseReverseDepsLock db) $ uninterruptibleMask_ $ do +updateReverseDeps myId db prev new = uninterruptibleMask_ $ atomically $ do forM_ prev $ \d -> - unless (d `Set.member` new) $ - doOne (Set.delete myId) d - forM_ (Set.elems new) $ - doOne (Set.insert myId) + unless (d `HSet.member` new) $ + doOne (HSet.delete myId) d + forM_ (HSet.toList new) $ + doOne (HSet.insert myId) where - doOne f id = do - rdeps <- getReverseDependencies db id - Ids.insert (databaseReverseDeps db) id (f $ fromMaybe mempty rdeps) + alterRDeps f = + Focus.adjust (onKeyReverseDeps f) + doOne f id = + SMap.focus (alterRDeps f) id (databaseValues db) -getReverseDependencies :: Database -> Id -> IO (Maybe (IntSet)) -getReverseDependencies db = Ids.lookup (databaseReverseDeps db) +getReverseDependencies :: Database -> Key -> STM (Maybe (HashSet Key)) +getReverseDependencies db = (fmap.fmap) keyReverseDeps . flip SMap.lookup (databaseValues db) -transitiveDirtySet :: Foldable t => Database -> t Id -> IO IntSet -transitiveDirtySet database = flip State.execStateT Set.empty . traverse_ loop +transitiveDirtySet :: Foldable t => Database -> t Key -> STM (HashSet Key) +transitiveDirtySet database = flip State.execStateT HSet.empty . traverse_ loop where loop x = do seen <- State.get - if x `Set.member` seen then pure () else do - State.put (Set.insert x seen) + if x `HSet.member` seen then pure () else do + State.put (HSet.insert x seen) next <- lift $ getReverseDependencies database x - traverse_ loop (maybe mempty Set.toList next) + traverse_ loop (maybe mempty HSet.toList next) -- | IO extended to track created asyncs to clean them up when the thread is killed, -- generalizing 'withAsync' @@ -263,16 +258,18 @@ asyncWithCleanUp act = do atomicModifyIORef'_ st (void a :) return $ wait a -withLockAIO :: Lock -> AIO a -> AIO a -withLockAIO lock act = do - io <- unliftAIO act - liftIO $ withLock lock io - unliftAIO :: AIO a -> AIO (IO a) unliftAIO act = do st <- AIO ask return $ runReaderT (unAIO act) st +newtype RunInIO = RunInIO (forall a. AIO a -> IO a) + +withRunInIO :: (RunInIO -> AIO b) -> AIO b +withRunInIO k = do + st <- AIO ask + k $ RunInIO (\aio -> runReaderT (unAIO aio) st) + cleanupAsync :: IORef [Async a] -> IO () cleanupAsync ref = uninterruptibleMask_ $ do asyncs <- readIORef ref diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs b/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs deleted file mode 100644 index 4ba216f774..0000000000 --- a/hls-graph/src/Development/IDE/Graph/Internal/Ids.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} - --- Note that argument order is more like IORef than Map, because its mutable -module Development.IDE.Graph.Internal.Ids( - Ids, Id, - empty, insert, lookup, fromList, - null, size, sizeUpperBound, - forWithKeyM_, forCopy, forMutate, - toList, elems, toMap - ) where - -import Control.Exception -import Control.Monad.Extra -import Data.Functor -import qualified Data.HashMap.Strict as Map -import Data.IORef.Extra -import Data.List.Extra (zipFrom) -import Data.Maybe -import Data.Primitive.Array hiding (fromList) -import Development.IDE.Graph.Internal.Intern (Id) -import GHC.Exts (RealWorld) -import GHC.IO (IO (..)) -import Prelude hiding (lookup, null) - - -newtype Ids a = Ids (IORef (S a)) - -data S a = S - {capacity :: {-# UNPACK #-} !Int -- ^ Number of entries in values, initially 0 - ,used :: {-# UNPACK #-} !Int -- ^ Capacity that has been used, assuming no gaps from index 0, initially 0 - ,values :: {-# UNPACK #-} !(MutableArray RealWorld (Maybe a)) - } - - -empty :: IO (Ids a) -empty = do - let capacity = 0 - let used = 0 - values <- newArray capacity Nothing - Ids <$> newIORef S{..} - -fromList :: [a] -> IO (Ids a) -fromList xs = do - let capacity = length xs - let used = capacity - values <- newArray capacity Nothing - forM_ (zipFrom 0 xs) $ \(i, x) -> - writeArray values i $ Just x - Ids <$> newIORef S{..} - -sizeUpperBound :: Ids a -> IO Int -sizeUpperBound (Ids ref) = do - S{..} <- readIORef ref - pure used - - -size :: Ids a -> IO Int -size (Ids ref) = do - S{..} <- readIORef ref - let go !acc i - | i < 0 = pure acc - | otherwise = do - v <- readArray values i - if isJust v then go (acc+1) (i-1) else go acc (i-1) - go 0 (used-1) - - -toMap :: Ids a -> IO (Map.HashMap Id a) -toMap ids = do - mp <- Map.fromList <$> toListUnsafe ids - pure $! mp - -forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO () -forWithKeyM_ (Ids ref) f = do - S{..} <- readIORef ref - let go !i | i >= used = pure () - | otherwise = do - v <- readArray values i - whenJust v $ f $ fromIntegral i - go $ i+1 - go 0 - -forCopy :: Ids a -> (a -> b) -> IO (Ids b) -forCopy (Ids ref) f = do - S{..} <- readIORef ref - values2 <- newArray capacity Nothing - let go !i | i >= used = pure () - | otherwise = do - v <- readArray values i - whenJust v $ \v -> writeArray values2 i $ Just $ f v - go $ i+1 - go 0 - Ids <$> newIORef (S capacity used values2) - - -forMutate :: Ids a -> (Id -> a -> a) -> IO () -forMutate (Ids ref) f = do - S{..} <- readIORef ref - let go !i | i >= used = pure () - | otherwise = do - v <- readArray values i - whenJust v $ \v -> writeArray values i $! Just $! f i v - go $ i+1 - go 0 - - -toListUnsafe :: Ids a -> IO [(Id, a)] -toListUnsafe (Ids ref) = do - S{..} <- readIORef ref - - -- execute in O(1) stack - -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html - let index _ i | i >= used = [] - index r i | IO io <- readArray values i = case io r of - (# r, Nothing #) -> index r (i+1) - (# r, Just v #) -> (fromIntegral i, v) : index r (i+1) - - IO $ \r -> (# r, index r 0 #) - - -toList :: Ids a -> IO [(Id, a)] -toList ids = do - xs <- toListUnsafe ids - let demand (_:xs) = demand xs - demand [] = () - evaluate $ demand xs - pure xs - -elems :: Ids a -> IO [a] -elems ids = map snd <$> toList ids - -null :: Ids a -> IO Bool -null ids = (== 0) <$> sizeUpperBound ids - - -insert :: Ids a -> Id -> a -> IO () -insert (Ids ref) (i) v = do - S{..} <- readIORef ref - let ii = fromIntegral i - if ii < capacity then do - writeArray values ii $ Just v - when (ii >= used) $ writeIORef' ref S{used=ii+1,..} - else do - c2<- pure $ max (capacity * 2) (ii + 10000) - v2 <- newArray c2 Nothing - copyMutableArray v2 0 values 0 capacity - writeArray v2 ii $ Just v - writeIORef' ref $ S c2 (ii+1) v2 - -lookup :: Ids a -> Id -> IO (Maybe a) -lookup (Ids ref) (i) = do - S{..} <- readIORef ref - let ii = fromIntegral i - if ii < used then - readArray values ii - else - pure Nothing diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs b/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs deleted file mode 100644 index 28d998ac45..0000000000 --- a/hls-graph/src/Development/IDE/Graph/Internal/Intern.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Development.IDE.Graph.Internal.Intern( - Intern, Id, - empty, insert, add, lookup, toList, fromList - ) where - -import qualified Data.HashMap.Strict as Map -import Data.List (foldl') -import Development.IDE.Graph.Classes -import Prelude hiding (lookup) - - --- Invariant: The first field is the highest value in the Map -data Intern a = Intern {-# UNPACK #-} !Int !(Map.HashMap a Id) - -type Id = Int - -empty :: Intern a -empty = Intern 0 Map.empty - - -insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a -insert k v (Intern n mp) = Intern (max n v) $ Map.insert k v mp - - -add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id) -add k (Intern v mp) = (Intern v2 $ Map.insert k v2 mp, v2) - where v2 = v + 1 - - -lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id -lookup k (Intern _ mp) = Map.lookup k mp - - -toList :: Intern a -> [(a, Id)] -toList (Intern _ mp) = Map.toList mp - - -fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a -fromList xs = Intern (foldl' max 0 [i | (_, i) <- xs]) (Map.fromList xs) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index e8f5af6a4d..d37f0e9ac7 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -7,15 +7,14 @@ module Development.IDE.Graph.Internal.Profile (writeProfile) where +import Control.Concurrent.STM (readTVarIO) 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 Data.IORef -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as Set +import qualified Data.HashSet as Set import Data.List (dropWhileEnd, foldl', intercalate, partition, sort, @@ -28,7 +27,6 @@ import Data.Time (defaultTimeLocale, iso8601DateFormat) import Development.IDE.Graph.Classes import Development.IDE.Graph.Internal.Database (getDirtySet) -import qualified Development.IDE.Graph.Internal.Ids as Ids import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable as DGTable @@ -50,7 +48,7 @@ writeProfile out db = do (report, mapping) <- toReport db dirtyKeysMapped <- do dirtyIds <- Set.fromList . fmap fst <$> getDirtySet db - let dirtyKeysMapped = mapMaybe (`IntMap.lookup` mapping) . Set.toList $ dirtyIds + let dirtyKeysMapped = mapMaybe (`Map.lookup` mapping) . Set.toList $ dirtyIds return $ Just $ sort dirtyKeysMapped rpt <- generateHTML dirtyKeysMapped report LBS.writeFile out rpt @@ -60,12 +58,12 @@ 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 :: [(Ids.Id, (k, Status))] -> Map.HashMap Ids.Id (k, Result) -resultsOnly mp = Map.map (fmap (\r -> +resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result +resultsOnly mp = Map.map (\r -> r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r} - )) keep + ) keep where - keep = Map.fromList $ mapMaybe ((traverse.traverse) getResult) mp + keep = Map.fromList $ 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. @@ -102,36 +100,35 @@ dependencyOrder shw status = Nothing -> g (free, mp) (k, ds) Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp) -prepareForDependencyOrder :: Database -> IO (Map.HashMap Ids.Id (Key, Result)) +prepareForDependencyOrder :: Database -> IO (HashMap Key Result) prepareForDependencyOrder db = do - current <- readIORef $ databaseStep db - Map.insert (-1) (Key "alwaysRerun", alwaysRerunResult current) . resultsOnly - <$> Ids.toList (databaseValues db) + current <- readTVarIO $ databaseStep db + Map.insert (Key "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], IntMap Int) +toReport :: Database -> IO ([ProfileEntry], HashMap Key Int) toReport db = do status <- prepareForDependencyOrder db - let order = let shw i = maybe "" (show . fst) $ Map.lookup i status - in dependencyOrder shw - $ map (second (getResultDepsDefault [-1] . resultDeps . snd)) + let order = dependencyOrder show + $ map (second (getResultDepsDefault [Key "alwaysRerun"] . resultDeps)) $ Map.toList status - ids = IntMap.fromList $ zip order [0..] + ids = Map.fromList $ zip order [0..] - steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | (_k, Result{..}) <- Map.elems status] + steps = let xs = nubOrd $ concat [[resultChanged, resultBuilt, resultVisited] | Result{..} <- Map.elems status] in Map.fromList $ zip (sortBy (flip compare) xs) [0..] - f (k, Result{..}) = ProfileEntry + f k Result{..} = ProfileEntry {prfName = show k ,prfBuilt = fromStep resultBuilt ,prfVisited = fromStep resultVisited ,prfChanged = fromStep resultChanged - ,prfDepends = map pure $ mapMaybe (`IntMap.lookup` ids) $ getResultDepsDefault [-1] resultDeps + ,prfDepends = map pure $ mapMaybe (`Map.lookup` ids) $ getResultDepsDefault [Key "alwaysRerun"] resultDeps ,prfExecution = resultExecution } where fromStep i = fromJust $ Map.lookup i steps - pure ([maybe (error "toReport") f $ Map.lookup i status | i <- order], ids) + 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 @@ -144,7 +141,7 @@ generateHTML dirtyKeys xs = do f other = error other runTemplate f report -generateJSONBuild :: Maybe [Ids.Id] -> String +generateJSONBuild :: Maybe [Int] -> String generateJSONBuild (Just dirtyKeys) = jsonList [jsonList (map show dirtyKeys)] generateJSONBuild Nothing = jsonList [] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index bd86d6ee70..53841d1ee5 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -6,30 +6,33 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Development.IDE.Graph.Internal.Types where import Control.Applicative -import Control.Concurrent.Extra import Control.Monad.Catch -- Needed in GHC 8.6.5 +import Control.Concurrent.STM (TVar, atomically) import Control.Monad.Fail import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.ByteString as BS +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (second) +import qualified Data.ByteString as BS import Data.Dynamic -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) import Data.IORef -import Data.IntSet (IntSet) import Data.Maybe import Data.Typeable import Development.IDE.Graph.Classes -import Development.IDE.Graph.Internal.Ids -import Development.IDE.Graph.Internal.Intern -import GHC.Generics (Generic) -import System.Time.Extra (Seconds) +import GHC.Generics (Generic) +import qualified ListT +import StmContainers.Map (Map) +import qualified StmContainers.Map as SMap +import System.Time.Extra (Seconds) unwrapDynamic :: forall a . Typeable a => Dynamic -> a @@ -85,27 +88,47 @@ instance Show Key where newtype Value = Value Dynamic +data KeyDetails = KeyDetails { + keyStatus :: !Status, + keyReverseDeps :: !(HashSet Key) + } + +onKeyReverseDeps :: (HashSet Key -> HashSet Key) -> KeyDetails -> KeyDetails +onKeyReverseDeps f it@KeyDetails{..} = + it{keyReverseDeps = f keyReverseDeps} + data Database = Database { - databaseExtra :: Dynamic, - databaseRules :: TheRules, - databaseStep :: !(IORef Step), - -- Hold the lock while mutating Ids/Values - databaseLock :: !Lock, - databaseIds :: !(IORef (Intern Key)), - databaseValues :: !(Ids (Key, Status)), - databaseReverseDeps :: !(Ids IntSet), - databaseReverseDepsLock :: !Lock + databaseExtra :: Dynamic, + databaseRules :: TheRules, + databaseStep :: !(TVar Step), + databaseValues :: !(Map Key KeyDetails) } +getDatabaseValues :: Database -> IO [(Key, Status)] +getDatabaseValues = atomically + . (fmap.fmap) (second keyStatus) + . ListT.toList + . SMap.listT + . databaseValues + data Status = Clean Result | Dirty (Maybe Result) - | Running (IO ()) Result (Maybe Result) + | Running { + runningStep :: !Step, + runningWait :: !(IO ()), + runningResult :: Result, + runningPrev :: !(Maybe Result) + } + +viewDirty :: Step -> Status -> Status +viewDirty currentStep (Running s _ _ re) | currentStep /= s = Dirty re +viewDirty _ other = other getResult :: Status -> Maybe Result -getResult (Clean re) = Just re -getResult (Dirty m_re) = m_re -getResult (Running _ _ m_re) = m_re +getResult (Clean re) = Just re +getResult (Dirty m_re) = m_re +getResult (Running _ _ _ m_re) = m_re -- watch out: this returns the previous result data Result = Result { resultValue :: !Value, @@ -117,14 +140,14 @@ data Result = Result { resultData :: BS.ByteString } -data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Id] | ResultDeps ![Id] +data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key] -getResultDepsDefault :: [Id] -> ResultDeps -> [Id] +getResultDepsDefault :: [Key] -> ResultDeps -> [Key] getResultDepsDefault _ (ResultDeps ids) = ids getResultDepsDefault _ (AlwaysRerunDeps ids) = ids getResultDepsDefault def UnknownDeps = def -mapResultDeps :: ([Id] -> [Id]) -> ResultDeps -> ResultDeps +mapResultDeps :: ([Key] -> [Key]) -> ResultDeps -> ResultDeps mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids mapResultDeps _ UnknownDeps = UnknownDeps diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index fafa2f08b0..93643ace41 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -46,6 +46,8 @@ extra-deps: - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - retrie-1.0.0.0@sha256:82014773115807f649f60fe4a3246911bbccd063a3c846cf5665e71f237bdd2d,4241 - stylish-haskell-0.12.2.0@sha256:38f7fd9ca30c9aad34f176dae4564576899e9c197b6b8557b59c5e8c6a622c74,6108 + - stm-containers-1.2@sha256:a887f2e7692b7cf20e0b081e2d66e21076e2bd4b57016ec59c484edfa2d29397,3244 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 # Enable these when supported by all formatters # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 04e7adf902..4b24f8cf9a 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -46,6 +46,8 @@ extra-deps: - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - retrie-1.0.0.0@sha256:82014773115807f649f60fe4a3246911bbccd063a3c846cf5665e71f237bdd2d,4241 - stylish-haskell-0.12.2.0@sha256:38f7fd9ca30c9aad34f176dae4564576899e9c197b6b8557b59c5e8c6a622c74,6108 + - stm-containers-1.2@sha256:a887f2e7692b7cf20e0b081e2d66e21076e2bd4b57016ec59c484edfa2d29397,3244 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 # Enable these when supported by all formatters # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 9f9532f626..06ddf130ba 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -104,6 +104,10 @@ extra-deps: - lsp-1.2.0.1 - lsp-types-1.3.0.1 - lsp-test-0.14.0.1 + - stm-containers-1.1.0.4 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 + - primitive-extras-0.10.1 + - primitive-unlifted-0.1.3.1 configure-options: ghcide: diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 543bf2edd9..ace2d9ca8c 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -83,6 +83,10 @@ extra-deps: - lsp-1.2.0.1 - lsp-types-1.3.0.1 - lsp-test-0.14.0.1 + - stm-containers-1.1.0.4 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 + - primitive-extras-0.10.1 + - primitive-unlifted-0.1.3.1 configure-options: ghcide: diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 0bc74c05e2..4f1dda9328 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -80,6 +80,10 @@ extra-deps: - lsp-1.2.0.1 - lsp-types-1.3.0.1 - lsp-test-0.14.0.1 + - stm-containers-1.1.0.4 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 + - primitive-extras-0.10.1 + - primitive-unlifted-0.1.3.1 configure-options: ghcide: diff --git a/stack.yaml b/stack.yaml index f38265d1f5..01970b8798 100644 --- a/stack.yaml +++ b/stack.yaml @@ -46,6 +46,10 @@ extra-deps: - refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 - retrie-1.0.0.0@sha256:82014773115807f649f60fe4a3246911bbccd063a3c846cf5665e71f237bdd2d,4241 - stylish-haskell-0.12.2.0@sha256:38f7fd9ca30c9aad34f176dae4564576899e9c197b6b8557b59c5e8c6a622c74,6108 + - stm-containers-1.2@sha256:a887f2e7692b7cf20e0b081e2d66e21076e2bd4b57016ec59c484edfa2d29397,3244 + - stm-hamt-1.2.0.6@sha256:fba86ccb4b45c5706c19b0e1315ba63dcac3b5d71de945ec001ba921fae80061,3972 + + # Enable these when supported by all formatters # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279