Skip to content

Commit 62ac6a3

Browse files
wz1000wz1000
committed
module graph early cutoff
early cutoff for eval plugin
1 parent 075c8d3 commit 62ac6a3

File tree

5 files changed

+48
-27
lines changed

5 files changed

+48
-27
lines changed

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -169,6 +169,7 @@ import GHC.Unit.Env
169169
import GHC.Unit.Home.ModInfo
170170
#endif
171171
import GHC (mgModSummaries)
172+
import GHC.Fingerprint
172173

173174
data Log
174175
= LogShake Shake.Log
@@ -523,7 +524,7 @@ rawDependencyInformation fs = do
523524

524525
reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules ()
525526
reportImportCyclesRule recorder =
526-
define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do
527+
defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do
527528
DependencyInformation{..} <- useNoFile_ GetModuleGraph
528529
let fileId = pathToId depPathIdMap file
529530
case IntMap.lookup (getFilePathId fileId) depErrorNodes of
@@ -671,15 +672,16 @@ knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorde
671672
pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs)
672673

673674
getModuleGraphRule :: Recorder (WithPriority Log) -> Rules ()
674-
getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
675+
getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do
675676
fs <- toKnownFiles <$> useNoFile_ GetKnownTargets
676677
dependencyInfoForFiles (HashSet.toList fs)
677678

678-
dependencyInfoForFiles :: [NormalizedFilePath] -> Action DependencyInformation
679+
dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation)
679680
dependencyInfoForFiles fs = do
680681
(rawDepInfo, bm) <- rawDependencyInformation fs
681682
let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo
682-
mss <- map (fmap msrModSummary) <$> uses GetModSummaryWithoutTimestamps all_fs
683+
msrs <- uses GetModSummaryWithoutTimestamps all_fs
684+
let mss = map (fmap msrModSummary) msrs
683685
#if MIN_VERSION_ghc(9,3,0)
684686
let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids
685687
nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss
@@ -700,7 +702,7 @@ dependencyInfoForFiles fs = do
700702
#endif
701703
(catMaybes mss)
702704
#endif
703-
pure $ processDependencyInformation rawDepInfo bm mg
705+
pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg)
704706

705707
-- This is factored out so it can be directly called from the GetModIface
706708
-- rule. Directly calling this rule means that on the initial load we can
@@ -793,7 +795,7 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
793795
case mbdeps of
794796
Nothing -> return Nothing
795797
Just deps -> do
796-
when fullModuleGraph $ void $ uses_ ReportImportCycles deps
798+
when fullModuleGraph $ void $ use_ ReportImportCycles file
797799
ms <- msrModSummary <$> if fullModSummary
798800
then use_ GetModSummary file
799801
else use_ GetModSummaryWithoutTimestamps file

‎plugins/hls-eval-plugin/hls-eval-plugin.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,7 @@ library
5555
build-depends:
5656
, aeson
5757
, base >=4.12 && <5
58+
, bytestring
5859
, containers
5960
, data-default
6061
, deepseq

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,7 @@ module Ide.Plugin.Eval.CodeLens (
2525

2626
import Control.Applicative (Alternative ((<|>)))
2727
import Control.Arrow (second, (>>>))
28-
import Control.Exception (try)
28+
import Control.Exception (try, bracket_)
2929
import qualified Control.Exception as E
3030
import Control.Lens (_1, _3, ix, (%~),
3131
(<&>), (^.))
@@ -115,7 +115,7 @@ import Ide.Plugin.Eval.GHC (addImport,
115115
showDynFlags)
116116
import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
117117
import Ide.Plugin.Eval.Parse.Option (parseSetFlags)
118-
import Ide.Plugin.Eval.Rules (queueForEvaluation)
118+
import Ide.Plugin.Eval.Rules (queueForEvaluation, unqueueForEvaluation)
119119
import Ide.Plugin.Eval.Types
120120
import Ide.Plugin.Eval.Util (gStrictTry,
121121
isLiterate,
@@ -215,12 +215,12 @@ runEvalCmd plId st EvalParams{..} =
215215
mdlText <- moduleText _uri
216216

217217
-- enable codegen for the module which we need to evaluate.
218-
liftIO $ queueForEvaluation st nfp
219-
liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval"
220-
-- Setup a session with linkables for all dependencies and GHCi specific options
221-
final_hscEnv <- liftIO $ initialiseSessionForEval
222-
(needsQuickCheck tests)
223-
st nfp
218+
final_hscEnv <- liftIO $ bracket_
219+
(do queueForEvaluation st nfp
220+
setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
221+
(do unqueueForEvaluation st nfp
222+
setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval")
223+
(initialiseSessionForEval (needsQuickCheck tests) st nfp)
224224

225225
evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId
226226

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs

Lines changed: 21 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55

66
-- To avoid warning "Pattern match has inaccessible right hand side"
77
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
8-
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where
8+
module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, unqueueForEvaluation, Log) where
99

1010
import Control.Monad.IO.Class (MonadIO (liftIO))
1111
import Data.HashSet (HashSet)
@@ -24,7 +24,8 @@ import Development.IDE (GetModSummaryWithoutTimes
2424
fromNormalizedFilePath,
2525
msrModSummary,
2626
realSrcSpanToRange,
27-
useWithStale_)
27+
useWithStale_,
28+
use_)
2829
import Development.IDE.Core.PositionMapping (toCurrentRange)
2930
import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags,
3031
needsCompilationRule)
@@ -46,6 +47,8 @@ import GHC.Parser.Annotation
4647
#endif
4748
import Ide.Plugin.Eval.Types
4849

50+
import qualified Data.ByteString as BS
51+
4952
newtype Log = LogShake Shake.Log deriving Show
5053

5154
instance Pretty Log where
@@ -56,6 +59,7 @@ rules :: Recorder (WithPriority Log) -> Rules ()
5659
rules recorder = do
5760
evalParsedModuleRule recorder
5861
redefinedNeedsCompilation recorder
62+
isEvaluatingRule recorder
5963
addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty)
6064

6165
newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath))
@@ -64,7 +68,13 @@ instance IsIdeGlobal EvaluatingVar
6468
queueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
6569
queueForEvaluation ide nfp = do
6670
EvaluatingVar var <- getIdeGlobalState ide
67-
modifyIORef var (Set.insert nfp)
71+
atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ()))
72+
73+
unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO ()
74+
unqueueForEvaluation ide nfp = do
75+
EvaluatingVar var <- getIdeGlobalState ide
76+
-- remove the module from the Evaluating state, so that next time it won't evaluate to True
77+
atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ())
6878

6979
#if MIN_VERSION_ghc(9,2,0)
7080
#if MIN_VERSION_ghc(9,5,0)
@@ -133,26 +143,26 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorde
133143
fingerPrint = fromString $ if nullComments comments then "" else "1"
134144
return (Just fingerPrint, Just comments)
135145

146+
isEvaluatingRule :: Recorder (WithPriority Log) -> Rules ()
147+
isEvaluatingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsEvaluating f -> do
148+
alwaysRerun
149+
EvaluatingVar var <- getIdeGlobalAction
150+
b <- liftIO $ (f `Set.member`) <$> readIORef var
151+
return (Just (if b then BS.singleton 1 else BS.empty), Just b)
152+
136153
-- Redefine the NeedsCompilation rule to set the linkable type to Just _
137154
-- whenever the module is being evaluated
138155
-- This will ensure that the modules are loaded with linkables
139156
-- and the interactive session won't try to compile them on the fly,
140157
-- leading to much better performance of the evaluate code lens
141158
redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules ()
142159
redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do
143-
alwaysRerun
144-
145-
EvaluatingVar var <- getIdeGlobalAction
146-
isEvaluating <- liftIO $ (f `elem`) <$> readIORef var
147-
160+
isEvaluating <- use_ IsEvaluating f
148161

149162
if not isEvaluating then needsCompilationRule f else do
150163
ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f
151164
let df' = ms_hspp_opts ms
152165
linkableType = computeLinkableTypeForDynFlags df'
153166
fp = encodeLinkableType $ Just linkableType
154167

155-
-- remove the module from the Evaluating state
156-
liftIO $ modifyIORef var (Set.delete f)
157-
158168
pure (Just fp, Just (Just linkableType))

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,9 @@ module Ide.Plugin.Eval.Types
2828
unLoc,
2929
Txt,
3030
EvalParams(..),
31-
GetEvalComments(..)
32-
,nullComments)
31+
GetEvalComments(..),
32+
IsEvaluating(..),
33+
nullComments)
3334
where
3435

3536
import Control.DeepSeq (deepseq)
@@ -96,6 +97,13 @@ data Test
9697
| Property {testline :: Txt, testOutput :: [Txt], testRange :: Range}
9798
deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
9899

100+
data IsEvaluating = IsEvaluating
101+
deriving (Eq, Show, Typeable, Generic)
102+
instance Hashable IsEvaluating
103+
instance NFData IsEvaluating
104+
105+
type instance RuleResult IsEvaluating = Bool
106+
99107
data GetEvalComments = GetEvalComments
100108
deriving (Eq, Show, Typeable, Generic)
101109
instance Hashable GetEvalComments

0 commit comments

Comments
 (0)