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
2 changed files:
Changes:
| ... | ... | @@ -38,6 +38,7 @@ module GHC.Driver.Main |
| 38 | 38 | newHscEnv
|
| 39 | 39 | , newHscEnvWithHUG
|
| 40 | 40 | , initHscEnv
|
| 41 | + , createHomeUnitEnvFromFlags
|
|
| 41 | 42 | |
| 42 | 43 | -- * Compiling complete source files
|
| 43 | 44 | , Messager, batchMsg, batchMultiMsg
|
| ... | ... | @@ -298,6 +299,7 @@ import Data.Bifunctor |
| 298 | 299 | import qualified GHC.Unit.Home.Graph as HUG
|
| 299 | 300 | import GHC.Unit.Home.PackageTable
|
| 300 | 301 | import qualified GHC.ByteCode.Serialize as ByteCode
|
| 302 | +import qualified Data.Set as Set
|
|
| 301 | 303 | |
| 302 | 304 | {- **********************************************************************
|
| 303 | 305 | %* *
|
| ... | ... | @@ -307,19 +309,15 @@ import qualified GHC.ByteCode.Serialize as ByteCode |
| 307 | 309 | |
| 308 | 310 | newHscEnv :: FilePath -> DynFlags -> IO HscEnv
|
| 309 | 311 | newHscEnv top_dir dflags = do
|
| 310 | - hpt <- emptyHomePackageTable
|
|
| 311 | - newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt)
|
|
| 312 | - where
|
|
| 313 | - home_unit_graph hpt =
|
|
| 314 | - HUG.unitEnv_singleton
|
|
| 315 | - (homeUnitId_ dflags)
|
|
| 316 | - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing))
|
|
| 312 | + logger <- initLogger
|
|
| 313 | + -- TODO: doesn't quite work, we call 'initUnits' in 'createHomeUnitEnvFromFlags'
|
|
| 314 | + (home_unit_graph, mainUnitId) <- createHomeUnitEnvFromFlags logger (NE.singleton dflags)
|
|
| 315 | + newHscEnvWithHUG logger top_dir dflags mainUnitId home_unit_graph
|
|
| 317 | 316 | |
| 318 | -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
|
|
| 319 | -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
|
|
| 317 | +newHscEnvWithHUG :: Logger -> FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
|
|
| 318 | +newHscEnvWithHUG logger top_dir top_dynflags cur_unit home_unit_graph = do
|
|
| 320 | 319 | nc_var <- newNameCache
|
| 321 | 320 | fc_var <- initFinderCache
|
| 322 | - logger <- initLogger
|
|
| 323 | 321 | tmpfs <- initTmpFs
|
| 324 | 322 | let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph
|
| 325 | 323 | 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 |
| 339 | 337 | , hsc_llvm_config = llvm_config
|
| 340 | 338 | }
|
| 341 | 339 | |
| 340 | +createHomeUnitEnvFromFlags :: Logger -> NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
|
|
| 341 | +createHomeUnitEnvFromFlags logger unitDflags = do
|
|
| 342 | + let home_units = Set.fromList (NE.toList $ NE.map homeUnitId_ unitDflags)
|
|
| 343 | + |
|
| 344 | + homeUnitEnvs <- forM (NE.toList unitDflags) $ \dflags -> do
|
|
| 345 | + let cached_unit_dbs = Nothing
|
|
| 346 | + hue_flags = dflags
|
|
| 347 | + |
|
| 348 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger hue_flags cached_unit_dbs home_units
|
|
| 349 | + |
|
| 350 | + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
|
|
| 351 | + hpt <- liftIO emptyHomePackageTable
|
|
| 352 | + pure (homeUnitId home_unit, HUG.mkHomeUnitEnv unit_state (Just dbs) updated_dflags hpt home_unit)
|
|
| 353 | + |
|
| 354 | + let activeUnit = homeUnitId_ $ NE.head unitDflags
|
|
| 355 | + let home_unit_graph = HUG.hugFromList homeUnitEnvs
|
|
| 356 | + return (home_unit_graph, activeUnit)
|
|
| 357 | + |
|
| 342 | 358 | -- | Initialize HscEnv from an optional top_dir path
|
| 343 | 359 | initHscEnv :: Maybe FilePath -> IO HscEnv
|
| 344 | 360 | initHscEnv mb_top_dir = do
|
| ... | ... | @@ -17,11 +17,7 @@ import GHC.Driver.Config.Diagnostic |
| 17 | 17 | |
| 18 | 18 | import GHC.Unit.Env
|
| 19 | 19 | import GHC.Unit (UnitId)
|
| 20 | -import GHC.Unit.Home (GenHomeUnit(..))
|
|
| 21 | -import GHC.Unit.Home.PackageTable
|
|
| 22 | 20 | import qualified GHC.Unit.Home.Graph as HUG
|
| 23 | -import GHC.Unit.State ( emptyUnitState )
|
|
| 24 | -import qualified GHC.Unit.State as State
|
|
| 25 | 21 | |
| 26 | 22 | import GHC.Types.SrcLoc
|
| 27 | 23 | import GHC.Types.SourceError
|
| ... | ... | @@ -43,6 +39,7 @@ import GHC.ResponseFile (expandResponse) |
| 43 | 39 | import Data.Bifunctor
|
| 44 | 40 | import GHC.Data.Graph.Directed
|
| 45 | 41 | import qualified Data.List.NonEmpty as NE
|
| 42 | +import GHC.Driver.Main (createHomeUnitEnvFromFlags)
|
|
| 46 | 43 | |
| 47 | 44 | -- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.
|
| 48 | 45 | removeRTS :: [String] -> [String]
|
| ... | ... | @@ -126,24 +123,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do |
| 126 | 123 | |
| 127 | 124 | checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))
|
| 128 | 125 | |
| 129 | - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
|
|
| 130 | - let home_units = HUG.allUnits initial_home_graph
|
|
| 131 | - |
|
| 132 | - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
|
|
| 133 | - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
|
|
| 134 | - hue_flags = homeUnitEnv_dflags homeUnitEnv
|
|
| 135 | - dflags = homeUnitEnv_dflags homeUnitEnv
|
|
| 136 | - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
|
|
| 137 | - |
|
| 138 | - updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
|
|
| 139 | - emptyHpt <- liftIO $ emptyHomePackageTable
|
|
| 140 | - pure $ HomeUnitEnv
|
|
| 141 | - { homeUnitEnv_units = unit_state
|
|
| 142 | - , homeUnitEnv_unit_dbs = Just dbs
|
|
| 143 | - , homeUnitEnv_dflags = updated_dflags
|
|
| 144 | - , homeUnitEnv_hpt = emptyHpt
|
|
| 145 | - , homeUnitEnv_home_unit = home_unit
|
|
| 146 | - }
|
|
| 126 | + (home_unit_graph, mainUnitId) <- liftIO $ createHomeUnitEnvFromFlags logger unitDflags
|
|
| 147 | 127 | |
| 148 | 128 | checkUnitCycles initial_dflags home_unit_graph
|
| 149 | 129 | |
| ... | ... | @@ -233,14 +213,3 @@ offsetDynFlags dflags = |
| 233 | 213 | augment_maybe (Just f) = Just (augment f)
|
| 234 | 214 | augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f
|
| 235 | 215 | | otherwise = f |
| 236 | - |
|
| 237 | - |
|
| 238 | -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)
|
|
| 239 | -createUnitEnvFromFlags unitDflags = do
|
|
| 240 | - unitEnvList <- forM unitDflags $ \dflags -> do
|
|
| 241 | - emptyHpt <- emptyHomePackageTable
|
|
| 242 | - let newInternalUnitEnv =
|
|
| 243 | - HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing)
|
|
| 244 | - return (homeUnitId_ dflags, newInternalUnitEnv)
|
|
| 245 | - let activeUnit = fst $ NE.head unitEnvList
|
|
| 246 | - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) |