Skip to content

Commit fa28306

Browse files
soulomoonsoulomoon
committed
initial attempt
1 parent d923d82 commit fa28306

File tree

2 files changed

+150
-41
lines changed

2 files changed

+150
-41
lines changed

‎cabal.project

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,8 @@ packages:
66
./ghcide
77
./hls-plugin-api
88
./hls-test-utils
9+
../hie-bios
10+
911

1012

1113
index-state: 2024-10-21T00:00:00Z
@@ -46,3 +48,11 @@ constraints:
4648
if impl(ghc >= 9.9)
4749
-- https://github.com/haskell/haskell-language-server/issues/4324
4850
benchmarks: False
51+
52+
-- add github bois repo
53+
-- use the batch load branch
54+
55+
-- source-repository-package
56+
-- type: git
57+
-- location: https://github.com/soulomoon/hie-bios.git
58+
-- tag: a6d789d9c852f33e5e0ba89613dcd12532e48907

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 140 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,7 @@ import Development.IDE.Types.Options
6868
import GHC.ResponseFile
6969
import qualified HIE.Bios as HieBios
7070
import HIE.Bios.Environment hiding (getCacheDir)
71+
import qualified HIE.Bios.Flags as HieBios
7172
import HIE.Bios.Types hiding (Log)
7273
import qualified HIE.Bios.Types as HieBios
7374
import Ide.Logger (Pretty (pretty),
@@ -119,12 +120,19 @@ import qualified System.Random as Random
119120
import System.Random (RandomGen)
120121
import Text.ParserCombinators.ReadP (readP_to_S)
121122

123+
import Control.Exception.Extra (errorIO)
124+
import qualified Data.HashMap.Strict as HashMap
125+
import qualified Data.Tuple as Tuple
126+
import Development.IDE.Core.OfInterest (OfInterestVar (OfInterestVar),
127+
getFilesOfInterest,
128+
getFilesOfInterestUntracked)
122129
import GHC.Data.Bag
123130
import GHC.Driver.Env (hsc_all_home_unit_ids)
124131
import GHC.Driver.Errors.Types
125132
import GHC.Types.Error (errMsgDiagnostic,
126133
singleMessage)
127134
import GHC.Unit.State
135+
import qualified HIE.Bios.Cradle as HieBios
128136

129137
data Log
130138
= LogSettingInitialDynFlags
@@ -139,15 +147,18 @@ data Log
139147
| LogMakingNewHscEnv ![UnitId]
140148
| LogDLLLoadError !String
141149
| LogCradlePath !FilePath
150+
| LogCradlePaths ![FilePath]
142151
| LogCradleNotFound !FilePath
143152
| LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String))
144153
| LogCradle !(Cradle Void)
145154
| LogNoneCradleFound FilePath
146155
| LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
147156
| LogHieBios HieBios.Log
157+
148158
| LogSessionLoadingChanged
149159
deriving instance Show Log
150160

161+
151162
instance Pretty Log where
152163
pretty = \case
153164
LogNoneCradleFound path ->
@@ -204,6 +215,8 @@ instance Pretty Log where
204215
"Error dynamically loading libm.so.6:" <+> pretty errorString
205216
LogCradlePath path ->
206217
"Cradle path:" <+> pretty path
218+
LogCradlePaths path ->
219+
"Cradle paths:" <+> pretty path
207220
LogCradleNotFound path ->
208221
vcat
209222
[ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "."
@@ -446,15 +459,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
446459
-- e.g. see https://github.com/haskell/ghcide/issues/126
447460
let res' = toAbsolutePath <$> res
448461
return $ normalise <$> res'
449-
462+
-- loadCradle in batch
463+
let cradleLocs :: [FilePath] -> IO [(Maybe FilePath)]
464+
cradleLocs = mapM cradleLoc
450465
return $ do
451466
clientConfig <- getClientConfigAction
452467
extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
453468
} <- getShakeExtras
454469
let invalidateShakeCache = do
455470
void $ modifyVar' version succ
456471
return $ toNoFileKey GhcSessionIO
457-
472+
OfInterestVar filesOfInterVar <- getIdeGlobalAction
458473
IdeOptions{ optTesting = IdeTesting optTesting
459474
, optCheckProject = getCheckProject
460475
, optExtensions
@@ -582,6 +597,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
582597
void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
583598
-- The VFS doesn't change on cradle edits, re-use the old one.
584599
-- Invalidate all the existing GhcSession build nodes by restarting the Shake session
600+
-- todo result only when batch cradle loading is done
585601
keys2 <- invalidateShakeCache
586602
restartShakeSession VFSUnmodified "new component" [] $ do
587603
keys1 <- extendKnownTargets all_targets
@@ -602,28 +618,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
602618

603619
return $ second Map.keys this_options
604620

605-
let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
606-
consultCradle hieYaml cfp = do
607-
let lfpLog = makeRelative rootDir cfp
608-
logWith recorder Info $ LogCradlePath lfpLog
609-
when (isNothing hieYaml) $
610-
logWith recorder Warning $ LogCradleNotFound lfpLog
611-
cradle <- loadCradle recorder hieYaml rootDir
612-
when optTesting $ mRunLspT lspEnv $
613-
sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
614-
615-
-- Display a user friendly progress message here: They probably don't know what a cradle is
616-
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
617-
<> " (for " <> T.pack lfpLog <> ")"
618-
eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $
619-
withTrace "Load cradle" $ \addTag -> do
620-
addTag "file" lfpLog
621-
old_files <- readIORef cradle_files
622-
res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files
623-
addTag "result" (show res)
624-
return res
625-
626-
logWith recorder Debug $ LogSessionLoadingResult eopts
621+
let eoptsHscEnv (hieYaml, cfp, cradle, eopts) =
627622
case eopts of
628623
-- The cradle gave us some options so get to work turning them
629624
-- into and HscEnv.
@@ -646,6 +641,42 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
646641
void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
647642
return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
648643

644+
let consultCradles :: [(Maybe FilePath, FilePath)] -> IO [(IdeResult HscEnvEq, [FilePath])]
645+
consultCradles hyCfpList = do
646+
let cfps = map snd hyCfpList
647+
let lfpLogs = map (makeRelative rootDir . snd) hyCfpList
648+
logWith recorder Info $ LogCradlePaths lfpLogs
649+
cradles <- mapM (\(hieYaml, _) -> loadCradle recorder hieYaml rootDir) hyCfpList
650+
when optTesting $ mRunLspT lspEnv $ mapM_ (\(_, cfp) -> sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)) hyCfpList
651+
let progMsg = "Setting up " <> T.pack (show (takeBaseName . cradleRootDir <$> cradles))
652+
<> " (for " <> T.pack (show lfpLogs) <> ")"
653+
eoptsList <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $
654+
do old_files <- readIORef cradle_files
655+
res <- cradleToOptsAndLibDirs recorder (sessionLoading clientConfig) (zip cradles cfps) old_files
656+
return res
657+
mapM eoptsHscEnv (zipWith (\((hieYaml, fp), cr) eopts -> (hieYaml, fp, cr, eopts) ) (zip hyCfpList cradles) eoptsList)
658+
659+
let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
660+
consultCradle hieYaml cfp = do
661+
let lfpLog = makeRelative rootDir cfp
662+
logWith recorder Info $ LogCradlePath lfpLog
663+
when (isNothing hieYaml) $
664+
logWith recorder Warning $ LogCradleNotFound lfpLog
665+
cradle <- loadCradle recorder hieYaml rootDir
666+
when optTesting $ mRunLspT lspEnv $
667+
sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
668+
-- Display a user friendly progress message here: They probably don't know what a cradle is
669+
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
670+
<> " (for " <> T.pack lfpLog <> ")"
671+
eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $
672+
withTrace "Load cradle" $ \addTag -> do
673+
addTag "file" lfpLog
674+
old_files <- readIORef cradle_files
675+
res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files
676+
addTag "result" (show res)
677+
return res
678+
logWith recorder Debug $ LogSessionLoadingResult eopts
679+
eoptsHscEnv (hieYaml, cfp, cradle, eopts)
649680
let
650681
-- | We allow users to specify a loading strategy.
651682
-- Check whether this config was changed since the last time we have loaded
@@ -666,8 +697,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
666697

667698
-- This caches the mapping from hie.yaml + Mod.hs -> [String]
668699
-- Returns the Ghc session and the cradle dependencies
669-
let sessionOpts :: (Maybe FilePath, FilePath)
670-
-> IO (IdeResult HscEnvEq, [FilePath])
700+
let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq, [FilePath])
671701
sessionOpts (hieYaml, file) = do
672702
Extra.whenM didSessionLoadingPreferenceConfigChange $ do
673703
logWith recorder Info LogSessionLoadingChanged
@@ -695,6 +725,44 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
695725
else return (opts, Map.keys old_di)
696726
Nothing -> consultCradle hieYaml cfp
697727

728+
let readSessionOptsFromCache (hieYaml, file) = do
729+
v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags
730+
let cfp = toAbsolutePath file
731+
case HM.lookup (toNormalizedFilePath' cfp) v of
732+
Just (opts, old_di) -> do
733+
deps_ok <- checkDependencyInfo old_di
734+
if not deps_ok
735+
then do
736+
-- If the dependencies are out of date then clear both caches and start
737+
-- again.
738+
modifyVar_ fileToFlags (const (return Map.empty))
739+
modifyVar_ filesMap (const (return HM.empty))
740+
-- Keep the same name cache
741+
modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )
742+
return $ Left (hieYaml, file)
743+
else return $ Right (file, (opts, Map.keys old_di))
744+
Nothing -> return $ Left (hieYaml, file)
745+
746+
let sessionOptsList :: [(Maybe FilePath, FilePath)] -> IO (Map.Map FilePath (IdeResult HscEnvEq, [FilePath]))
747+
sessionOptsList yamlFiles = do
748+
cached <- mapM readSessionOptsFromCache yamlFiles
749+
let (toConsults, cachedResults) = partitionEithers cached
750+
results <- consultCradles toConsults
751+
let consultMap = Map.fromList $ zip (map snd toConsults) results
752+
let cachedMap = Map.fromList cachedResults
753+
return $ consultMap <> cachedMap
754+
755+
756+
let getOptionsList :: [FilePath] -> IO (Map.Map FilePath (IdeResult HscEnvEq, [FilePath]))
757+
getOptionsList files = do
758+
let ncfps = toNormalizedFilePath' . toAbsolutePath <$> files
759+
cachedHieYamlLocations <- mapM (\ncfp -> HM.lookup ncfp <$> readVar filesMap) ncfps
760+
hieYamls <- cradleLocs files
761+
let yamlFiles = zip (zipWith (\x y -> join x <|> y) cachedHieYamlLocations hieYamls) files
762+
sessionOptsList yamlFiles
763+
764+
765+
698766
-- The main function which gets options for a file. We only want one of these running
699767
-- at a time. Therefore the IORef contains the currently running cradle, if we try
700768
-- to get some more options then we wait for the currently running action to finish
@@ -707,21 +775,40 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
707775
sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
708776
return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
709777

778+
let getOptionsBatch :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
779+
getOptionsBatch file' = do
780+
let file = toAbsolutePath file'
781+
hieYaml <- cradleLoc file
782+
filesOfInterest <- HashMap.keys <$> readVar filesOfInterVar
783+
logWith recorder Debug LogSettingInitialDynFlags
784+
results <- getOptionsList (Set.toList $ Set.fromList $ toAbsolutePath file : map fromNormalizedFilePath filesOfInterest)
785+
return (results Map.! file) `Safe.catch` \e ->
786+
return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
787+
710788
returnWithVersion $ \file -> do
711789
-- see Note [Serializing runs in separate thread]
712-
awaitRunInThread que $ getOptions file
713-
714-
-- | Run the specific cradle on a specific FilePath via hie-bios.
715-
-- This then builds dependencies or whatever based on the cradle, gets the
716-
-- GHC options/dynflags needed for the session and the GHC library directory
717-
cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]
718-
-> IO (Either [CradleError] (ComponentOptions, FilePath, String))
719-
cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
720-
-- let noneCradleFoundMessage :: FilePath -> T.Text
721-
-- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"
722-
-- Start off by getting the session options
723-
logWith recorder Debug $ LogCradle cradle
724-
cradleRes <- HieBios.getCompilerOptions file loadStyle cradle
790+
awaitRunInThread que $ getOptionsBatch file
791+
792+
-- cradleToType :: Cradle Void -> IO ()
793+
-- cradleToType c = do
794+
-- case c of
795+
-- Cradle { cradleOptsProg = Just (GHC.GhcVersion _), cradleOptsProg = Just (GHC.GhcVersion _) } -> return ()
796+
-- _ ->
797+
-- return ()
798+
799+
-- how we do batch loading of cradles depends on the the type of cradle we are using
800+
cradleToOptsAndLibDirs :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> [(Cradle Void, FilePath)] -> [FilePath]
801+
-> IO [Either [CradleError] (ComponentOptions, FilePath, String)]
802+
cradleToOptsAndLibDirs recorder loadConfig cradleFiles old_fps = do
803+
-- let result :: [([FilePath], CradleLoadResult ComponentOptions)]
804+
results <- HieBios.getCompilerOptionsInBatch (LoadWithContext old_fps) cradleFiles
805+
let resultMap :: Map.Map FilePath (CradleLoadResult ComponentOptions)
806+
resultMap = Map.fromList $ [ (fp, r) | (fps, r) <- results, fp <- fps ]
807+
mapM (\(cr, fp) -> collectBiosResult recorder cr fp (resultMap Map.! fp)) cradleFiles
808+
809+
810+
collectBiosResult :: Recorder (WithPriority Log) -> Cradle a1 -> FilePath -> CradleLoadResult a2 -> IO (Either [CradleError] (a2, FilePath, String))
811+
collectBiosResult recorder cradle file cradleRes =
725812
case cradleRes of
726813
CradleSuccess r -> do
727814
-- Now get the GHC lib dir
@@ -734,12 +821,23 @@ cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
734821
CradleNone -> do
735822
logWith recorder Info $ LogNoneCradleFound file
736823
return (Left [])
737-
738824
CradleFail err -> return (Left [err])
739825
CradleNone -> do
740826
logWith recorder Info $ LogNoneCradleFound file
741827
return (Left [])
742828

829+
-- | Run the specific cradle on a specific FilePath via hie-bios.
830+
-- This then builds dependencies or whatever based on the cradle, gets the
831+
-- GHC options/dynflags needed for the session and the GHC library directory
832+
cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]
833+
-> IO (Either [CradleError] (ComponentOptions, FilePath, String))
834+
cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
835+
-- let noneCradleFoundMessage :: FilePath -> T.Text
836+
-- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"
837+
-- Start off by getting the session options
838+
logWith recorder Debug $ LogCradle cradle
839+
cradleRes <- HieBios.getCompilerOptions file loadStyle cradle
840+
collectBiosResult recorder cradle file cradleRes
743841
where
744842
loadStyle = case loadConfig of
745843
PreferSingleComponentLoading -> LoadFile
@@ -1212,7 +1310,8 @@ instance Exception PackageSetupException
12121310

12131311
showPackageSetupException :: PackageSetupException -> String
12141312
showPackageSetupException GhcVersionMismatch{..} = unwords
1215-
["ghcide compiled against GHC"
1313+
[
1314+
"ghcide compiled against GHC"
12161315
,showVersion compileTime
12171316
,"but currently using"
12181317
,showVersion runTime

0 commit comments

Comments
 (0)