Skip to content

Commit e99772d

Browse files
wz1000wz1000
committed
Implement sharing for hls-graph Keys
1 parent 43508cd commit e99772d

File tree

8 files changed

+83
-37
lines changed

8 files changed

+83
-37
lines changed

‎ghcide/src/Development/IDE/Core/Shake.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -324,7 +324,7 @@ getPluginConfig plugin = do
324324
addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules ()
325325
addPersistentRule k getVal = do
326326
ShakeExtras{persistentKeys} <- getShakeExtrasRules
327-
void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (Key k) (fmap (fmap (first3 toDyn)) . getVal)
327+
void $ liftIO $ atomically $ modifyTVar' persistentKeys $ HMap.insert (newKey k) (fmap (fmap (first3 toDyn)) . getVal)
328328

329329
class Typeable a => IsIdeGlobal a where
330330

@@ -399,7 +399,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
399399
pmap <- readTVarIO persistentKeys
400400
mv <- runMaybeT $ do
401401
liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k
402-
f <- MaybeT $ pure $ HMap.lookup (Key k) pmap
402+
f <- MaybeT $ pure $ HMap.lookup (newKey k) pmap
403403
(dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file
404404
MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
405405
case mv of
@@ -1068,7 +1068,7 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe
10681068
extras <- getShakeExtras
10691069
let diagnostics ver diags = do
10701070
traceDiagnostics diags
1071-
updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
1071+
updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
10721072
defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file
10731073
defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do
10741074
let diagnostics _ver diags = do
@@ -1087,7 +1087,7 @@ defineEarlyCutoff recorder (RuleWithOldValue op) = addRule $ \(Q (key, file)) (o
10871087
extras <- getShakeExtras
10881088
let diagnostics ver diags = do
10891089
traceDiagnostics diags
1090-
updateFileDiagnostics recorder file ver (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags
1090+
updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags
10911091
defineEarlyCutoff' diagnostics (==) key file old mode $ op key file
10921092

10931093
defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules ()

‎ghcide/src/Development/IDE/Types/Shake.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Data.Typeable (cast)
2626
import Data.Vector (Vector)
2727
import Development.IDE.Core.PositionMapping
2828
import Development.IDE.Core.RuleTypes (FileVersion)
29-
import Development.IDE.Graph (Key (..), RuleResult)
29+
import Development.IDE.Graph (Key (..), RuleResult, newKey)
3030
import qualified Development.IDE.Graph as Shake
3131
import Development.IDE.Types.Diagnostics
3232
import Development.IDE.Types.Location
@@ -75,7 +75,7 @@ isBadDependency x
7575
| otherwise = False
7676

7777
toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key
78-
toKey = (Key.) . curry Q
78+
toKey = (newKey.) . curry Q
7979

8080
fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath)
8181
fromKey (Key k)
@@ -91,7 +91,7 @@ fromKeyType (Key k) = case typeOf k of
9191
_ -> Nothing
9292

9393
toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key
94-
toNoFileKey k = Key $ Q (k, emptyFilePath)
94+
toNoFileKey k = newKey $ Q (k, emptyFilePath)
9595

9696
newtype Q k = Q (k, NormalizedFilePath)
9797
deriving newtype (Eq, Hashable, NFData)

‎hls-graph/src/Development/IDE/Graph.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
1+
{-# LANGUAGE PatternSynonyms #-}
12
module Development.IDE.Graph(
2-
shakeOptions,
3+
shakeOptions,
34
Rules,
45
Action, action,
5-
Key(..),
6+
Key(.., Key),
7+
newKey,
68
actionFinally, actionBracket, actionCatch, actionFork,
79
-- * Configuration
810
ShakeOptions(shakeAllowRedefineRules, shakeExtra),

‎hls-graph/src/Development/IDE/Graph/Database.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ shakeGetBuildEdges :: ShakeDatabase -> IO Int
7979
shakeGetBuildEdges (ShakeDatabase _ _ db) = do
8080
keys <- getDatabaseValues db
8181
let ress = mapMaybe (getResult . snd) keys
82-
return $ sum $ map (length . getResultDepsDefault [] . resultDeps) ress
82+
return $ sum $ map (length . getResultDepsDefault mempty . resultDeps) ress
8383

8484
-- | Returns an approximation of the database keys,
8585
-- annotated with how long ago (in # builds) they were visited

‎hls-graph/src/Development/IDE/Graph/Internal/Action.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Control.Monad.Trans.Class
2626
import Control.Monad.Trans.Reader
2727
import Data.Foldable (toList)
2828
import Data.Functor.Identity
29+
import qualified Data.HashSet as HSet
2930
import Data.IORef
3031
import Development.IDE.Graph.Classes
3132
import Development.IDE.Graph.Internal.Database
@@ -39,7 +40,7 @@ type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
3940
alwaysRerun :: Action ()
4041
alwaysRerun = do
4142
ref <- Action $ asks actionDeps
42-
liftIO $ modifyIORef ref (AlwaysRerunDeps [] <>)
43+
liftIO $ modifyIORef ref (AlwaysRerunDeps mempty <>)
4344

4445
-- No-op for now
4546
reschedule :: Double -> Action ()
@@ -121,7 +122,7 @@ apply ks = do
121122
stack <- Action $ asks actionStack
122123
(is, vs) <- liftIO $ build db stack ks
123124
ref <- Action $ asks actionDeps
124-
liftIO $ modifyIORef ref (ResultDeps (toList is) <>)
125+
liftIO $ modifyIORef ref (ResultDeps (HSet.fromList $ toList is) <>)
125126
pure vs
126127

127128
-- | Evaluate a list of keys without recording any dependencies.

‎hls-graph/src/Development/IDE/Graph/Internal/Database.hs‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99
{-# LANGUAGE ScopedTypeVariables #-}
1010
{-# LANGUAGE TupleSections #-}
1111
{-# LANGUAGE TypeFamilies #-}
12+
{-# LANGUAGE ViewPatterns #-}
1213

1314
module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
1415

@@ -87,7 +88,7 @@ build
8788
-- build _ st k | traceShow ("build", st, k) False = undefined
8889
build db stack keys = do
8990
built <- runAIO $ do
90-
built <- builder db stack (fmap Key keys)
91+
built <- builder db stack (fmap newKey keys)
9192
case built of
9293
Left clean -> return clean
9394
Right dirty -> liftIO dirty
@@ -145,7 +146,7 @@ refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result)
145146
-- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined
146147
refresh db stack key result = case (addStack key stack, result) of
147148
(Left e, _) -> throw e
148-
(Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> do
149+
(Right stack, Just me@Result{resultDeps = ResultDeps (HSet.toList -> deps)}) -> do
149150
res <- builder db stack deps
150151
let isDirty = any (\(_,dep) -> resultBuilt me < resultChanged dep)
151152
case res of
@@ -176,7 +177,7 @@ compute db@Database{..} stack key mode result = do
176177
actualDeps = if runChanged /= ChangedNothing then deps else previousDeps
177178
previousDeps= maybe UnknownDeps resultDeps result
178179
let res = Result runValue built' changed built actualDeps execution runStore
179-
case getResultDepsDefault [] actualDeps of
180+
case getResultDepsDefault mempty actualDeps of
180181
deps | not(null deps)
181182
&& runChanged /= ChangedNothing
182183
-> do
@@ -186,8 +187,8 @@ compute db@Database{..} stack key mode result = do
186187
-- on the next build.
187188
void $
188189
updateReverseDeps key db
189-
(getResultDepsDefault [] previousDeps)
190-
(HSet.fromList deps)
190+
(getResultDepsDefault mempty previousDeps)
191+
deps
191192
_ -> pure ()
192193
atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues
193194
pure res
@@ -235,14 +236,13 @@ splitIO act = do
235236
updateReverseDeps
236237
:: Key -- ^ Id
237238
-> Database
238-
-> [Key] -- ^ Previous direct dependencies of Id
239+
-> HashSet Key -- ^ Previous direct dependencies of Id
239240
-> HashSet Key -- ^ Current direct dependencies of Id
240241
-> IO ()
241242
-- mask to ensure that all the reverse dependencies are updated
242243
updateReverseDeps myId db prev new = do
243-
forM_ prev $ \d ->
244-
unless (d `HSet.member` new) $
245-
doOne (HSet.delete myId) d
244+
forM_ (HSet.toList $ prev `HSet.difference` new) $ \d ->
245+
doOne (HSet.delete myId) d
246246
forM_ (HSet.toList new) $
247247
doOne (HSet.insert myId)
248248
where

‎hls-graph/src/Development/IDE/Graph/Internal/Profile.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,7 @@ data ProfileEntry = ProfileEntry
6060
-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
6161
resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result
6262
resultsOnly mp = Map.map (\r ->
63-
r{resultDeps = mapResultDeps (filter (isJust . flip Map.lookup keep)) $ resultDeps r}
63+
r{resultDeps = mapResultDeps (Set.filter (isJust . flip Map.lookup keep)) $ resultDeps r}
6464
) keep
6565
where
6666
keep = Map.fromList $ mapMaybe (traverse getResult) mp
@@ -103,15 +103,15 @@ dependencyOrder shw status =
103103
prepareForDependencyOrder :: Database -> IO (HashMap Key Result)
104104
prepareForDependencyOrder db = do
105105
current <- readTVarIO $ databaseStep db
106-
Map.insert (Key "alwaysRerun") (alwaysRerunResult current) . resultsOnly
106+
Map.insert (newKey "alwaysRerun") (alwaysRerunResult current) . resultsOnly
107107
<$> getDatabaseValues db
108108

109109
-- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry
110110
toReport :: Database -> IO ([ProfileEntry], HashMap Key Int)
111111
toReport db = do
112112
status <- prepareForDependencyOrder db
113113
let order = dependencyOrder show
114-
$ map (second (getResultDepsDefault [Key "alwaysRerun"] . resultDeps))
114+
$ map (second (Set.toList . getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") . resultDeps))
115115
$ Map.toList status
116116
ids = Map.fromList $ zip order [0..]
117117

@@ -124,14 +124,14 @@ toReport db = do
124124
,prfBuilt = fromStep resultBuilt
125125
,prfVisited = fromStep resultVisited
126126
,prfChanged = fromStep resultChanged
127-
,prfDepends = map pure $ mapMaybe (`Map.lookup` ids) $ getResultDepsDefault [Key "alwaysRerun"] resultDeps
127+
,prfDepends = map pure $ Map.elems $ Map.intersectionWith const ids $ Set.toMap $ getResultDepsDefault (Set.singleton $ newKey "alwaysRerun") resultDeps
128128
,prfExecution = resultExecution
129129
}
130130
where fromStep i = fromJust $ Map.lookup i steps
131131
pure ([maybe (error "toReport") (f i) $ Map.lookup i status | i <- order], ids)
132132

133133
alwaysRerunResult :: Step -> Result
134-
alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps []) 0 mempty
134+
alwaysRerunResult current = Result (Value $ toDyn "<alwaysRerun>") (Step 0) (Step 0) current (ResultDeps mempty) 0 mempty
135135

136136
generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString
137137
generateHTML dirtyKeys xs = do

‎hls-graph/src/Development/IDE/Graph/Internal/Types.hs‎

Lines changed: 54 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,9 @@
77
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
88
{-# LANGUAGE RecordWildCards #-}
99
{-# LANGUAGE ScopedTypeVariables #-}
10+
{-# LANGUAGE PatternSynonyms #-}
11+
{-# LANGUAGE BangPatterns #-}
12+
{-# LANGUAGE ViewPatterns #-}
1013

1114
module Development.IDE.Graph.Internal.Types where
1215

@@ -20,6 +23,7 @@ import qualified Data.ByteString as BS
2023
import Data.Dynamic
2124
import qualified Data.HashMap.Strict as Map
2225
import Data.HashSet (HashSet, member)
26+
import qualified Data.IntMap as IM
2327
import qualified Data.HashSet as Set
2428
import Data.IORef
2529
import Data.List (intercalate)
@@ -32,6 +36,7 @@ import qualified ListT
3236
import qualified StmContainers.Map as SMap
3337
import StmContainers.Map (Map)
3438
import System.Time.Extra (Seconds)
39+
import System.IO.Unsafe
3540
import UnliftIO (MonadUnliftIO)
3641

3742

@@ -78,16 +83,54 @@ data ShakeDatabase = ShakeDatabase !Int [Action ()] Database
7883
newtype Step = Step Int
7984
deriving newtype (Eq,Ord,Hashable)
8085

81-
data Key = forall a . (Typeable a, Eq a, Hashable a, Show a) => Key a
86+
---------------------------------------------------------------------
87+
-- Keys
8288

83-
instance Eq Key where
84-
Key a == Key b = Just a == cast b
89+
data KeyValue = forall a . (Typeable a, Hashable a, Show a) => KeyValue a
8590

86-
instance Hashable Key where
87-
hashWithSalt i (Key x) = hashWithSalt i (typeOf x, x)
91+
newtype Key = UnsafeMkKey Int
92+
93+
pattern Key a <- (lookupKeyValue -> KeyValue a)
94+
95+
data KeyMap = KeyMap !(Map.HashMap KeyValue Key) !(IM.IntMap KeyValue) {-# UNPACK #-} !Int
96+
97+
keyMap :: IORef KeyMap
98+
keyMap = unsafePerformIO $ newIORef (KeyMap Map.empty IM.empty 0)
99+
100+
{-# NOINLINE keyMap #-}
88101

102+
newKey :: (Typeable a, Hashable a, Show a) => a -> Key
103+
newKey k = unsafePerformIO $ do
104+
let !newKey = KeyValue k
105+
atomicModifyIORef' keyMap $ \km@(KeyMap hm im n) ->
106+
let new_key = Map.lookup newKey hm
107+
in case new_key of
108+
Just v -> (km, v)
109+
Nothing ->
110+
let !new_index = UnsafeMkKey n
111+
in (KeyMap (Map.insert newKey new_index hm) (IM.insert n newKey im) (n+1), new_index)
112+
{-# NOINLINE newKey #-}
113+
114+
lookupKeyValue :: Key -> KeyValue
115+
lookupKeyValue (UnsafeMkKey x) = unsafePerformIO $ do
116+
KeyMap _ im _ <- readIORef keyMap
117+
pure $! fromJust (IM.lookup x im)
118+
119+
{-# NOINLINE lookupKeyValue #-}
120+
121+
instance Eq Key where
122+
UnsafeMkKey a == UnsafeMkKey b = a == b
123+
instance Hashable Key where
124+
hashWithSalt i (UnsafeMkKey x) = hashWithSalt i x
89125
instance Show Key where
90-
show (Key x) = show x
126+
show (Key x) = show x
127+
128+
instance Eq KeyValue where
129+
KeyValue a == KeyValue b = Just a == cast b
130+
instance Hashable KeyValue where
131+
hashWithSalt i (KeyValue x) = hashWithSalt i (typeOf x, x)
132+
instance Show KeyValue where
133+
show (KeyValue x) = show x
91134

92135
newtype Value = Value Dynamic
93136

@@ -143,24 +186,24 @@ data Result = Result {
143186
resultData :: !BS.ByteString
144187
}
145188

146-
data ResultDeps = UnknownDeps | AlwaysRerunDeps ![Key] | ResultDeps ![Key]
189+
data ResultDeps = UnknownDeps | AlwaysRerunDeps !(HashSet Key) | ResultDeps !(HashSet Key)
147190
deriving (Eq, Show)
148191

149-
getResultDepsDefault :: [Key] -> ResultDeps -> [Key]
192+
getResultDepsDefault :: (HashSet Key) -> ResultDeps -> (HashSet Key)
150193
getResultDepsDefault _ (ResultDeps ids) = ids
151194
getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
152195
getResultDepsDefault def UnknownDeps = def
153196

154-
mapResultDeps :: ([Key] -> [Key]) -> ResultDeps -> ResultDeps
197+
mapResultDeps :: (HashSet Key -> HashSet Key) -> ResultDeps -> ResultDeps
155198
mapResultDeps f (ResultDeps ids) = ResultDeps $ f ids
156199
mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids
157200
mapResultDeps _ UnknownDeps = UnknownDeps
158201

159202
instance Semigroup ResultDeps where
160203
UnknownDeps <> x = x
161204
x <> UnknownDeps = x
162-
AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault [] x)
163-
x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault [] x <> ids)
205+
AlwaysRerunDeps ids <> x = AlwaysRerunDeps (ids <> getResultDepsDefault mempty x)
206+
x <> AlwaysRerunDeps ids = AlwaysRerunDeps (getResultDepsDefault mempty x <> ids)
164207
ResultDeps ids <> ResultDeps ids' = ResultDeps (ids <> ids')
165208

166209
instance Monoid ResultDeps where

0 commit comments

Comments
 (0)