diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ba2857a7ad..7e1a062a7a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -223,7 +223,7 @@ data SessionLoadingOptions = SessionLoadingOptions -- | Given the project name and a set of command line flags, -- return the path for storing generated GHC artifacts, -- or 'Nothing' to respect the cradle setting - , getCacheDirs :: String -> [String] -> IO CacheDirs + , getCacheDirs :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) } diff --git a/ghcide/session-loader/Development/IDE/Session/Ghc.hs b/ghcide/session-loader/Development/IDE/Session/Ghc.hs index b789797144..3b659a6bee 100644 --- a/ghcide/session-loader/Development/IDE/Session/Ghc.hs +++ b/ghcide/session-loader/Development/IDE/Session/Ghc.hs @@ -58,6 +58,7 @@ import GHC.Types.Error (errMsgDiagnostic, singleMessage) import GHC.Unit.State + #if MIN_VERSION_ghc(9,13,0) import GHC.Driver.Make (checkHomeUnitsClosed) #endif @@ -79,7 +80,18 @@ instance Pretty Log where "New component cache HscEnvEq:" <+> viaShow componentCache LogDLLLoadError errorString -> "Error dynamically loading libm.so.6:" <+> pretty errorString - +-- | Configuration info for a particular home unit. +data HomeUnitConfig = HomeUnitConfig + { + -- | The dynamic flags to compile this specific unit. + homeUnitDynFlags :: DynFlags + -- | All the targets for this unit. + , homeUnitTargets :: [GHC.Target] + -- | Optional hash seed to differentiate home units + -- with same `-this-unit-id`. Used when `-this-unit-id` is "main", + -- which is common when loading a single target. + , homeUnitHash :: Maybe B.ByteString + } -- This is pristine information about a component data RawComponentInfo = RawComponentInfo { rawComponentUnitId :: UnitId @@ -95,6 +107,8 @@ data RawComponentInfo = RawComponentInfo -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file -- to last modification time. See Note [Multi Cradle Dependency Info]. , rawComponentDependencyInfo :: DependencyInfo + -- | An optional hash seed generated in 'setOptions' for the unit id "main". + , rawComponentHash :: Maybe B.ByteString } -- This is processed information about the component, in particular the dynflags will be modified. @@ -209,13 +223,13 @@ setOptions :: GhcMonad m -> ComponentOptions -> DynFlags -> FilePath -- ^ root dir, see Note [Root Directory] - -> m (NonEmpty (DynFlags, [GHC.Target])) + -> m (NonEmpty HomeUnitConfig) setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us Nothing -> do - (df, targets) <- initOne (map unLoc theOpts') + (HomeUnitConfig df targets mHash) <- initOne (map unLoc theOpts') -- A special target for the file which caused this wonderful -- component to be created. In case the cradle doesn't list all the targets for -- the component, in which case things will be horribly broken anyway. @@ -235,7 +249,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = -- we will report it as an error for that file let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp - pure $ (df, special_target : targets) :| [] + pure $ HomeUnitConfig df (special_target : targets) mHash :| [] where initMulti unitArgFiles = forM unitArgFiles $ \f -> do @@ -246,7 +260,7 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args initOne this_opts = do (dflags', targets') <- addCmdOpts this_opts dflags - let dflags'' = + let (dflags'',mHash) = case unitIdString (homeUnitId_ dflags') of -- cabal uses main for the unit id of all executable packages -- This makes multi-component sessions confused about what @@ -255,10 +269,11 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = -- This works because there won't be any dependencies on the -- executable unit. "main" -> - let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack this_opts) + let hashBytes =H.finalize $ H.updates H.init (map B.pack this_opts) + hash = B.unpack $ B16.encode hashBytes hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) - in setHomeUnitId_ hashed_uid dflags' - _ -> dflags' + in (setHomeUnitId_ hashed_uid dflags', Just hashBytes) + _ -> (dflags', Nothing) let targets = makeTargetsAbsolute root targets' root = case workingDirectory dflags'' of @@ -279,14 +294,14 @@ setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory dflags'' - return (dflags''', targets) + return (HomeUnitConfig dflags''' targets mHash) addComponentInfo :: MonadUnliftIO m => Recorder (WithPriority Log) -> - (String -> [String] -> IO CacheDirs) -> + (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) -> DependencyInfo -> - NonEmpty (DynFlags, [GHC.Target]) -> + NonEmpty HomeUnitConfig-> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> Map.Map (Maybe FilePath) [RawComponentInfo] -> m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) @@ -298,7 +313,7 @@ addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - new_deps = fmap (\(df, targets) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info) newDynFlags + new_deps = fmap (\(HomeUnitConfig df targets mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newDynFlags all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps -- Get all the unit-ids for things in this component @@ -306,7 +321,7 @@ addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) let prefix = show rawComponentUnitId -- See Note [Avoiding bad interface files] let cacheDirOpts = componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts + cacheDirs <- liftIO $ getCacheDirs prefix rawComponentHash cacheDirOpts processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded @@ -422,14 +437,28 @@ setCacheDirs recorder CacheDirs{..} dflags = do & maybe id setHieDir hieCacheDir & maybe id setODir oCacheDir -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) +-- | Append the hash to the unit id to create unique cache folders. +-- +-- This function generates a single, unified hash. +-- If an optional base hash (@mFirstHash@) is provided—which +-- is common for a single target with `-this-unit-id` as "main"- +-- we set the prefix to "main", extract the context generated +-- from the @mFirstHash@, and update the @opts@ into the same hash. +-- +-- This guarantees a unique cache folder for different GHC +-- options(avoiding incompatible interface files) while +-- keeping the path short and clean. +getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs +getCacheDirsDefault prefix mFirstHash opts = do + dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix' ++ "-" ++ opts_hash) return $ CacheDirs dir dir dir where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + -- Create a unique folder per set of different GHC options. + prefix' = if isJust mFirstHash then "main" else prefix + basectx = case mFirstHash of + Just h -> H.updates H.init [h] + Nothing -> H.init + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts) setNameCache :: NameCache -> HscEnv -> HscEnv setNameCache nc hsc = hsc { hsc_NC = nc }