Skip to content

Commit

Permalink
override NeedsCompilation rule in eval plugin to generate linkables w…
Browse files Browse the repository at this point in the history
…hen Evaluating

In addition, we tune the newness check of the redefined NeedsCompilation rule so that the generated linkables are not thrown away unnecessarily, as described in:

ndmitchell/shake#794
  • Loading branch information
pepeiborra committed Oct 24, 2021
1 parent 9199813 commit 3c8a303
Show file tree
Hide file tree
Showing 10 changed files with 128 additions and 34 deletions.
5 changes: 5 additions & 0 deletions ghcide/src/Development/IDE/Core/RuleTypes.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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+
Expand Down
31 changes: 19 additions & 12 deletions ghcide/src/Development/IDE/Core/Rules.hs
Original file line number Diff line number Diff line change
Expand Up @@ -50,6 +50,7 @@ module Development.IDE.Core.Rules(
getHieAstsRule,
getBindingsRule,
needsCompilationRule,
computeLinkableTypeForDynFlags,
generateCoreRule,
getImportMapRule,
regenerateHiFile,
Expand Down Expand Up @@ -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
Expand All @@ -1012,30 +1014,34 @@ 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
| Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled
| 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) }
Expand Down Expand Up @@ -1074,7 +1080,8 @@ mainRule = do
getClientSettingsRule
getHieAstsRule
getBindingsRule
needsCompilationRule
defineEarlyCutoff $ RuleNoDiagnostics $ \NeedsCompilation file ->
needsCompilationRule file
generateCoreRule
getImportMapRule
getAnnotatedParsedSourceRule
Expand Down
22 changes: 16 additions & 6 deletions ghcide/src/Development/IDE/Core/Shake.hs
Original file line number Diff line number Diff line change
Expand Up @@ -871,17 +871,25 @@ 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
:: IdeRule k v
=> 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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
6 changes: 5 additions & 1 deletion ghcide/src/Development/IDE/Types/Diagnostics.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ module Development.IDE.Types.Diagnostics (
ideErrorWithSource,
showDiagnostics,
showDiagnosticsColored,
) where
IdeResultNoDiagnosticsEarlyCutoff) where

import Control.DeepSeq
import Data.Maybe as Maybe
Expand All @@ -29,6 +29,7 @@ import Language.LSP.Types as LSP (Diagnostic (.
DiagnosticSource,
List (..))

import Data.ByteString (ByteString)
import Development.IDE.Types.Location


Expand All @@ -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)

Expand Down
2 changes: 1 addition & 1 deletion haskell-language-server.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
8 changes: 4 additions & 4 deletions hls-graph/src/Development/IDE/Graph/Internal/Database.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
4 changes: 2 additions & 2 deletions plugins/hls-eval-plugin/hls-eval-plugin.cabal
Original file line number Diff line number Diff line change
@@ -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 <https://github.com/haskell/haskell-language-server#readme>
Expand Down Expand Up @@ -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
Expand Down
8 changes: 8 additions & 0 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ import Development.IDE (Action, GetDependencies (..),
HiFileResult (hirHomeMod, hirModSummary),
HscEnvEq, IdeState,
ModSummaryResult (..),
NeedsCompilation (NeedsCompilation),
evalGhcEnv,
hscEnvWithImportPaths,
prettyPrint, runAction,
Expand Down Expand Up @@ -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


Expand Down Expand Up @@ -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 $
Expand Down
70 changes: 63 additions & 7 deletions plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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))
6 changes: 5 additions & 1 deletion plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE RecordWildCards #-}

module Ide.Plugin.Eval.Types
( locate,
Expand All @@ -28,7 +29,7 @@ module Ide.Plugin.Eval.Types
Txt,
EvalParams(..),
GetEvalComments(..)
)
,nullComments)
where

import Control.DeepSeq (deepseq)
Expand Down Expand Up @@ -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}
Expand Down

0 comments on commit 3c8a303

Please sign in to comment.