diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index e1cb3c899e2..e9e99d40d8a 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -49,6 +49,11 @@ data LinkableType = ObjectLinkable | BCOLinkable instance Hashable LinkableType instance NFData LinkableType +encodeLinkableType :: Maybe LinkableType -> ByteString +encodeLinkableType Nothing = "0" +encodeLinkableType (Just BCOLinkable) = "1" +encodeLinkableType (Just ObjectLinkable) = "2" + -- NOTATION -- Foo+ means Foo for the dependencies -- Foo* means Foo for me and Foo+ diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e08606ff583..f8cb18fcdca 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -50,6 +50,7 @@ module Development.IDE.Core.Rules( getHieAstsRule, getBindingsRule, needsCompilationRule, + computeLinkableTypeForDynFlags, generateCoreRule, getImportMapRule, regenerateHiFile, @@ -987,8 +988,9 @@ usePropertyAction kn plId p = do getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f -needsCompilationRule :: Rules () -needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> do +-- needsCompilationRule :: Rules () +needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) +needsCompilationRule file = do graph <- useNoFile GetModuleGraph res <- case graph of -- Treat as False if some reverse dependency header fails to parse @@ -1012,14 +1014,11 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation (uses NeedsCompilation revdeps) pure $ computeLinkableType ms modsums (map join needsComps) - pure (Just $ LBS.toStrict $ B.encode $ hash res, Just res) + pure (Just $ encodeLinkableType res, Just res) where uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags - unboxed_tuples_or_sums (ms_hspp_opts -> d) = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType computeLinkableType this deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we @@ -1027,15 +1026,22 @@ needsCompilationRule = defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile where - -- How should we compile this module? (assuming we do in fact need to compile it) - -- Depends on whether it uses unboxed tuples or sums - this_type + this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this) + +-- | How should we compile this module? +-- (assuming we do in fact need to compile it). +-- Depends on whether it uses unboxed tuples or sums +computeLinkableTypeForDynFlags :: DynFlags -> LinkableType +computeLinkableTypeForDynFlags d #if defined(GHC_PATCHED_UNBOXED_BYTECODE) = BCOLinkable #else - | unboxed_tuples_or_sums this = ObjectLinkable - | otherwise = BCOLinkable + | unboxed_tuples_or_sums = ObjectLinkable + | otherwise = BCOLinkable #endif + where + unboxed_tuples_or_sums = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } @@ -1074,7 +1080,8 @@ mainRule = do getClientSettingsRule getHieAstsRule getBindingsRule - needsCompilationRule + defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file -> + needsCompilationRule file generateCoreRule getImportMapRule getAnnotatedParsedSourceRule diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index cd90999b8d9..3aae69b9989 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -871,7 +871,10 @@ usesWithStale key files = do data RuleBody k v = Rule (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v)) | RuleNoDiagnostics (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v)) - + | RuleWithCustomNewnessCheck + { newnessCheck :: BS.ByteString -> BS.ByteString -> Bool + , build :: k -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe v) + } -- | Define a new Rule with early cutoff defineEarlyCutoff @@ -879,9 +882,14 @@ defineEarlyCutoff => RuleBody k v -> Rules () defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' True key file old mode $ op key file + defineEarlyCutoff' True (==) key file old mode $ op key file defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ do - defineEarlyCutoff' False key file old mode $ second (mempty,) <$> op key file + defineEarlyCutoff' False (==) key file old mode $ second (mempty,) <$> op key file +defineEarlyCutoff RuleWithCustomNewnessCheck{..} = + addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> + otTracedAction key file mode traceA $ + defineEarlyCutoff' False newnessCheck key file old mode $ + second (mempty,) <$> build key file defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () defineNoFile f = defineNoDiagnostics $ \k file -> do @@ -896,13 +904,15 @@ defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> d defineEarlyCutoff' :: IdeRule k v => Bool -- ^ update diagnostics + -- | compare current and previous for freshness + -> (BS.ByteString -> BS.ByteString -> Bool) -> k -> NormalizedFilePath -> Maybe BS.ByteString -> RunMode -> Action (Maybe BS.ByteString, IdeResult v) -> Action (RunResult (A (RuleResult k))) -defineEarlyCutoff' doDiagnostics key file old mode action = do +defineEarlyCutoff' doDiagnostics cmp key file old mode action = do extras@ShakeExtras{state, progress, logger, dirtyKeys} <- getShakeExtras options <- getIdeOptions (if optSkipProgress options key then id else inProgress progress file) $ do @@ -947,8 +957,8 @@ defineEarlyCutoff' doDiagnostics key file old mode action = do then updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags else forM_ diags $ \d -> liftIO $ logWarning logger $ showDiagnosticsColored [d] let eq = case (bs, fmap decodeShakeValue old) of - (ShakeResult a, Just (ShakeResult b)) -> a == b - (ShakeStale a, Just (ShakeStale b)) -> a == b + (ShakeResult a, Just (ShakeResult b)) -> cmp a b + (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result -- or we got ShakeNoCutoff we always return False. _ -> False diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index ce13bc3d3fb..77c8ae5c6fb 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -14,7 +14,7 @@ module Development.IDE.Types.Diagnostics ( ideErrorWithSource, showDiagnostics, showDiagnosticsColored, - ) where + IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq import Data.Maybe as Maybe @@ -29,6 +29,7 @@ import Language.LSP.Types as LSP (Diagnostic (. DiagnosticSource, List (..)) +import Data.ByteString (ByteString) import Development.IDE.Types.Location @@ -44,6 +45,9 @@ import Development.IDE.Types.Location -- not propagate diagnostic errors through multiple phases. type IdeResult v = ([FileDiagnostic], Maybe v) +-- | an IdeResult with a fingerprint +type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) + ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 0002f6932b6..bc123216818 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -212,7 +212,7 @@ common haddockComments common eval if flag(eval) || flag(all-plugins) - build-depends: hls-eval-plugin ^>=1.1.0.0 + build-depends: hls-eval-plugin ^>=1.2.0.0 cpp-options: -Deval common importLens diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index c8acc76de7e..5717831c7b3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -168,9 +168,9 @@ compute db@Database{..} key id 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 actualDeps of - ResultDeps deps | not(null deps) && - runChanged /= ChangedNothing + case getResultDepsDefault [] actualDeps of + deps | not(null deps) + && runChanged /= ChangedNothing -> do void $ forkIO $ updateReverseDeps id db (getResultDepsDefault [] previousDeps) (Set.fromList deps) @@ -284,7 +284,7 @@ mapConcurrentlyAIO_ f [one] = liftIO $ justWait $ fmap f one mapConcurrentlyAIO_ f many = do ref <- AIO ask waits <- liftIO $ uninterruptibleMask $ \restore -> do - waits <- liftIO $ traverse waitOrSpawn (map (fmap (restore . f)) many) + waits <- liftIO $ traverse (waitOrSpawn . fmap (restore . f)) many let asyncs = rights waits liftIO $ atomicModifyIORef'_ ref (asyncs ++) return waits diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 5ef4565219b..9e3cf57a19c 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin -version: 1.1.2.0 +version: 1.2.0.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -85,7 +85,7 @@ library , unordered-containers ghc-options: - -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -fno-ignore-asserts if flag(pedantic) ghc-options: -Werror diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2c1c3a6469b..eb5dd3294b1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -51,6 +51,7 @@ import Development.IDE (Action, GetDependencies (..), HiFileResult (hirHomeMod, hirModSummary), HscEnvEq, IdeState, ModSummaryResult (..), + NeedsCompilation (NeedsCompilation), evalGhcEnv, hscEnvWithImportPaths, prettyPrint, runAction, @@ -109,7 +110,10 @@ import UnliftIO.Temporary (withSystemTempFile) import GHC.Driver.Session (unitDatabases, unitState) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else +import Development.IDE.Core.FileStore (setSomethingModified) +import Development.IDE.Types.Shake (toKey) import DynFlags +import Ide.Plugin.Eval.Rules (queueForEvaluation) #endif @@ -196,6 +200,10 @@ runEvalCmd st EvalParams{..} = let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri + -- enable codegen + liftIO $ queueForEvaluation st nfp + liftIO $ setSomethingModified st [toKey NeedsCompilation nfp] "Eval" + session <- runGetSession st nfp ms <- fmap msrModSummary $ diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 0fadaad71bf..dfca81fabc6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -3,25 +3,54 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules) where +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.IORef import qualified Data.Map.Strict as Map -import Development.IDE (GetParsedModuleWithComments (GetParsedModuleWithComments), - Rules, - defineNoDiagnostics, +import Data.String (fromString) +import Development.IDE (GetModSummaryWithoutTimestamps (GetModSummaryWithoutTimestamps), + GetParsedModuleWithComments (GetParsedModuleWithComments), + IdeState, + NeedsCompilation (NeedsCompilation), + NormalizedFilePath, + RuleBody (RuleNoDiagnostics), + Rules, defineEarlyCutoff, + encodeLinkableType, fromNormalizedFilePath, + msrModSummary, realSrcSpanToRange, useWithStale_) import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.Core.Rules (computeLinkableTypeForDynFlags, + needsCompilationRule) +import Development.IDE.Core.Shake (IsIdeGlobal, + RuleBody (RuleWithCustomNewnessCheck), + addIdeGlobal, + getIdeGlobalAction, + getIdeGlobalState) import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString +import Development.IDE.Graph (alwaysRerun) import Ide.Plugin.Eval.Types rules :: Rules () rules = do evalParsedModuleRule + redefinedNeedsCompilation + addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) + +newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath)) +instance IsIdeGlobal EvaluatingVar + +queueForEvaluation :: IdeState -> NormalizedFilePath -> IO () +queueForEvaluation ide nfp = do + EvaluatingVar var <- getIdeGlobalState ide + modifyIORef var (Set.insert nfp) #if MIN_VERSION_ghc(9,0,0) pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan @@ -37,10 +66,9 @@ pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif evalParsedModuleRule :: Rules () -evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do +evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp - return $ Just $ - foldMap (\case + let comments = foldMap (\case L (RealSrcSpanAlready real) bdy | FastString.unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp @@ -59,3 +87,31 @@ evalParsedModuleRule = defineNoDiagnostics $ \GetEvalComments nfp -> do _ -> mempty ) $ apiAnnComments' pm_annotations + -- we only care about whether the comments are null + -- this is valid because the only dependent is NeedsCompilation + fingerPrint = fromString $ if nullComments comments then "" else "1" + return (Just fingerPrint, Just comments) + +-- Redefine the NeedsCompilation rule to set the linkable type to Just _ +-- whenever the module is being evaluated +-- This will ensure that the modules are loaded with linkables +-- and the interactive session won't try to compile them on the fly, +-- leading to much better performance of the evaluate code lens +redefinedNeedsCompilation :: Rules () +redefinedNeedsCompilation = defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do + alwaysRerun + + EvaluatingVar var <- getIdeGlobalAction + isEvaluating <- liftIO $ (f `elem`) <$> readIORef var + + + if not isEvaluating then needsCompilationRule f else do + ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps f + let df' = ms_hspp_opts ms + linkableType = computeLinkableTypeForDynFlags df' + fp = encodeLinkableType $ Just linkableType + + -- remove the module from the Evaluating state + liftIO $ modifyIORef var (Set.delete f) + + pure (Just fp, Just (Just linkableType)) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 6927c29ce99..26d410e18ab 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Eval.Types ( locate, @@ -28,7 +29,7 @@ module Ide.Plugin.Eval.Types Txt, EvalParams(..), GetEvalComments(..) - ) + ,nullComments) where import Control.DeepSeq (deepseq) @@ -107,6 +108,9 @@ data Comments = Comments } deriving (Show, Eq, Ord, Generic) +nullComments :: Comments -> Bool +nullComments Comments{..} = null lineComments && null blockComments + instance NFData Comments newtype RawBlockComment = RawBlockComment {getRawBlockComment :: String}