Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 13c8c0d1 by fendor at 2026-04-10T14:48:34+02:00 Use proper initialisation instead of hardcoding the unit - - - - - 2 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session/Units.hs Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -38,6 +38,7 @@ module GHC.Driver.Main newHscEnv , newHscEnvWithHUG , initHscEnv + , createHomeUnitEnvFromFlags -- * Compiling complete source files , Messager, batchMsg, batchMultiMsg @@ -298,6 +299,7 @@ import Data.Bifunctor import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.PackageTable import qualified GHC.ByteCode.Serialize as ByteCode +import qualified Data.Set as Set {- ********************************************************************** %* * @@ -307,19 +309,15 @@ import qualified GHC.ByteCode.Serialize as ByteCode newHscEnv :: FilePath -> DynFlags -> IO HscEnv newHscEnv top_dir dflags = do - hpt <- emptyHomePackageTable - newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) - where - home_unit_graph hpt = - HUG.unitEnv_singleton - (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing)) + logger <- initLogger + -- TODO: doesn't quite work, we call 'initUnits' in 'createHomeUnitEnvFromFlags' + (home_unit_graph, mainUnitId) <- createHomeUnitEnvFromFlags logger (NE.singleton dflags) + newHscEnvWithHUG logger top_dir dflags mainUnitId home_unit_graph -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do +newHscEnvWithHUG :: Logger -> FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv +newHscEnvWithHUG logger top_dir top_dynflags cur_unit home_unit_graph = do nc_var <- newNameCache fc_var <- initFinderCache - logger <- initLogger tmpfs <- initTmpFs let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) @@ -339,6 +337,24 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do , hsc_llvm_config = llvm_config } +createHomeUnitEnvFromFlags :: Logger -> NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createHomeUnitEnvFromFlags logger unitDflags = do + let home_units = Set.fromList (NE.toList $ NE.map homeUnitId_ unitDflags) + + homeUnitEnvs <- forM (NE.toList unitDflags) $ \dflags -> do + let cached_unit_dbs = Nothing + hue_flags = dflags + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + hpt <- liftIO emptyHomePackageTable + pure (homeUnitId home_unit, HUG.mkHomeUnitEnv unit_state (Just dbs) updated_dflags hpt home_unit) + + let activeUnit = homeUnitId_ $ NE.head unitDflags + let home_unit_graph = HUG.hugFromList homeUnitEnvs + return (home_unit_graph, activeUnit) + -- | Initialize HscEnv from an optional top_dir path initHscEnv :: Maybe FilePath -> IO HscEnv initHscEnv mb_top_dir = do ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,11 +17,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) -import GHC.Unit.Home (GenHomeUnit(..)) -import GHC.Unit.Home.PackageTable import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.State ( emptyUnitState ) -import qualified GHC.Unit.State as State import GHC.Types.SrcLoc import GHC.Types.SourceError @@ -43,6 +39,7 @@ import GHC.ResponseFile (expandResponse) import Data.Bifunctor import GHC.Data.Graph.Directed import qualified Data.List.NonEmpty as NE +import GHC.Driver.Main (createHomeUnitEnvFromFlags) -- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. removeRTS :: [String] -> [String] @@ -126,24 +123,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags - let home_units = HUG.allUnits initial_home_graph - - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units - - updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable - pure $ HomeUnitEnv - { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs - , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = home_unit - } + (home_unit_graph, mainUnitId) <- liftIO $ createHomeUnitEnvFromFlags logger unitDflags checkUnitCycles initial_dflags home_unit_graph @@ -233,14 +213,3 @@ offsetDynFlags dflags = augment_maybe (Just f) = Just (augment f) augment f | isRelative f, Just offset <- workingDirectory dflags = offset f | otherwise = f - - -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) -createUnitEnvFromFlags unitDflags = do - unitEnvList <- forM unitDflags $ \dflags -> do - emptyHpt <- emptyHomePackageTable - let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing) - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13c8c0d1897458653227a8391a8aad84... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13c8c0d1897458653227a8391a8aad84... You're receiving this email because of your account on gitlab.haskell.org.