Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 0fb37893 by Matthew Pickering at 2025-06-23T13:55:10-04:00 Move ModuleGraph into UnitEnv The ModuleGraph is a piece of information associated with the ExternalPackageState and HomeUnitGraph. Therefore we should store it inside the HomeUnitEnv. - - - - - 3bf6720e by soulomoon at 2025-06-23T13:55:52-04:00 Remove hptAllFamInstances usage during upsweep Fixes #26118 This change eliminates the use of hptAllFamInstances during the upsweep phase, as it could access non-below modules from the home package table. The following updates were made: * Updated checkFamInstConsistency to accept an explicit ModuleEnv FamInstEnv parameter and removed the call to hptAllFamInstances. * Adjusted hugInstancesBelow so we can construct ModuleEnv FamInstEnv from its result, * hptAllFamInstances and allFamInstances functions are removed. - - - - - bcd90cf5 by Ben Gamari at 2025-06-23T17:31:13-04:00 configure: Don't force value of OTOOL, etc. if not present Previously if `otool` and `install_name_tool` were not present they would be overridden by `fp_settings.m4`. This logic was introduced in 4ff93292243888545da452ea4d4c1987f2343591 without explanation. - - - - - 4e2069ea by Ben Gamari at 2025-06-23T17:31:13-04:00 ghc-toolchain: Add support for otool, install_name_tool Fixes part of ghc#23675. - - - - - 344d08fe by Ben Gamari at 2025-06-23T17:31:13-04:00 ghc-toolchain: Add support for llc, opt, llvm-as Fixes #23675. - - - - - 8fdbee83 by Rodrigo Mesquita at 2025-06-23T17:31:13-04:00 hadrian: Use settings-use-distro-mingw directly The type `ToolchainSetting` only made sense when we had more settings to fetch from the system config file. Even then "settings-use-distro-mingw" is arguably not a toolchain setting. With the fix for #23675, all toolchain tools were moved to the `ghc-toolchain` `Toolchain` format. Therefore, we can inline `settings-use-distro-mingw` accesses and delete `ToolchainSetting`. - - - - - 0a4d4abf by Rodrigo Mesquita at 2025-06-23T17:31:13-04:00 configure: Check LlvmTarget exists for LlvmAsFlags If LlvmTarget was empty, LlvmAsFlags would be just "--target=". If it is empty now, simply keep LlvmAsFlags empty. ghc-toolchain already does this right. This fix makes the two configurations match up. - - - - - e34b734d by Ben Gamari at 2025-06-23T17:31:14-04:00 rts/linker/LoadArchive: Use bool Improve type precision by using `bool` instead of `int` and `StgBool`. - - - - - f09c2519 by Ben Gamari at 2025-06-23T17:31:14-04:00 rts/linker/LoadArchive: Don't rely on file extensions for identification Previously archive members would be identified via their file extension, as described in #13103. We now instead use a more principled approach, relying on the magic number in the member's header. As well, we refactor treatment of archive format detection to improve code clarity and error handling. Closes #13103. - - - - - 29 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/Home/PackageTable.hs - distrib/configure.ac.in - ghc/GHCi/UI.hs - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/RunTest.hs - m4/fp_settings.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - rts/linker/LoadArchive.c - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -859,6 +859,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -916,6 +917,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit unit_env0 , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -996,7 +998,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -97,10 +97,11 @@ core2core hsc_env guts@(ModGuts { mg_module = mod where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -457,6 +457,7 @@ addUnit u = do (homeUnitId home_unit) (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -2,6 +2,8 @@ module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -130,6 +132,9 @@ hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env + hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG @@ -139,6 +144,9 @@ hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -220,15 +228,15 @@ hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -- | Find all rules in modules that are in the transitive closure of the given -- module. hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase -hugRulesBelow hsc uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> - hugSomeThingsBelowUs (md_rules . hm_details) False hsc uid mn +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn -- | Get annotations from all modules "below" this one (in the dependency -- sense) within the home units. If the module is @Nothing@, returns /all/ -- annotations in the home units. hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv -hugAnnsBelow hsc uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> - hugSomeThingsBelowUs (md_anns . hm_details) False hsc uid mn +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -- | Find all COMPLETE pragmas in modules that are in the transitive closure of the -- given module. @@ -237,7 +245,7 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)]) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts) <- @@ -247,7 +255,7 @@ hugInstancesBelow hsc_env uid mnwib = do -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, md_fam_insts details)]) + else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)])]) True -- Include -hi-boot hsc_env uid @@ -260,7 +268,8 @@ hugInstancesBelow hsc_env uid mnwib = do hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] -- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk -- These things are currently stored in the EPS for home packages. (See #25795 for --- progress in removing these kind of checks) +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) -- See Note [Downsweep and the ModuleGraph] hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -18,7 +18,6 @@ import GHC.Types.Name.Cache import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,10 +64,6 @@ data HscEnv hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - -- See Note [Downsweep and the ModuleGraph] for when this is constructed. - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -113,3 +108,4 @@ data HscEnv , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -332,7 +332,6 @@ newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -190,12 +190,12 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } + setSession (setModuleGraph mod_graph hsc_env) pure (emptyMessages, mod_graph) else do -- We don't have a complete module dependency graph, -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } + setSession (setModuleGraph emptyMG hsc_env) pure (errs, emptyMG) @@ -616,7 +616,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- for any client who might interact with GHC via load'. -- See Note [Timing of plugin initialization] initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + modifySession (setModuleGraph mod_graph) guessOutputFile hsc_env <- getSession ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -768,8 +768,9 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) - , hsc_mod_graph = mg } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -671,7 +671,7 @@ dontLeakTheHUG thing_inside = do -- oneshot mode does not support backpack -- and we want to avoid prodding the hsc_mod_graph thunk | isOneShot (ghcMode (hsc_dflags hsc_env)) = False - | mgHasHoles (hsc_mod_graph hsc_env) = True + | mgHasHoles (ue_module_graph old_unit_env) = True | otherwise = False pruneHomeUnitEnv hme = do -- NB: These are empty HPTs because Iface/Load first consults the HPT @@ -683,19 +683,19 @@ dontLeakTheHUG thing_inside = do | otherwise = do hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } return old_unit_env { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph } in do !unit_env <- unit_env_io -- mg_has_holes will be checked again, but nothing else about the module graph - let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" - , mg_graph = panic "cleanTopEnv: mg_graph" - , mg_has_holes = keepFor20509 } pure $ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = new_mod_graph , hsc_IC = panic "cleanTopEnv: hsc_IC" , hsc_type_env_vars = case maybe_type_vars of Just vars -> vars ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -286,8 +286,8 @@ why we still do redundant checks. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. -checkFamInstConsistency :: [Module] -> TcM () -checkFamInstConsistency directlyImpMods +checkFamInstConsistency :: ModuleEnv FamInstEnv -> [Module] -> TcM () +checkFamInstConsistency hpt_fam_insts directlyImpMods = do { (eps, hug) <- getEpsAndHug ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as @@ -317,7 +317,6 @@ checkFamInstConsistency directlyImpMods -- See Note [Order of type family consistency checks] } - ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods ; traceTc "init_consistent_set" (ppr debug_consistent_set) ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -120,7 +120,7 @@ import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) + , famInstEnvElts, extendFamInstEnvList, normaliseType, emptyFamInstEnv, unionFamInstEnv ) import GHC.Parser.Header ( mkPrelImports ) @@ -467,8 +467,8 @@ tcRnImports hsc_env import_decls = do { (rn_imports, imp_user_spec, rdr_env, imports) <- rnImports import_decls -- Get the default declarations for the classes imported by this module -- and group them by class. - ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) - <$> tcGetClsDefaults (M.keys $ imp_mods imports) + ; tc_defaults <- NE.groupBy ((==) `on` cd_class) . (concatMap defaultList) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv ; let unitId = homeUnitId $ hsc_home_unit hsc_env @@ -480,8 +480,10 @@ tcRnImports hsc_env import_decls -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) <- liftIO $ + ; (home_insts, home_mod_fam_inst_env) <- liftIO $ hugInstancesBelow hsc_env unitId mnwib + ; let home_fam_inst_env = foldl' unionFamInstEnv emptyFamInstEnv $ snd <$> home_mod_fam_inst_env + ; let hpt_fam_insts = mkModuleEnv home_mod_fam_inst_env -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad @@ -507,8 +509,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts + tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -538,7 +539,7 @@ tcRnImports hsc_env import_decls $ imports } ; logger <- getLogger ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) - $ checkFamInstConsistency dir_imp_mods + $ checkFamInstConsistency hpt_fam_insts dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty ; gbl_env <- getGblEnv @@ -2109,7 +2110,7 @@ for the unit portion of the graph, if it's not already been performed. withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a withInteractiveModuleNode hsc_env thing_inside = do mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) - updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside + updTopEnv (setModuleGraph mg) thing_inside runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -23,21 +23,22 @@ -- ┌▽────────────┐ │ │ -- │HomeUnitGraph│ │ │ -- └┬────────────┘ │ │ --- ┌▽─────────────────▽┐ │ --- │UnitEnv │ │ --- └┬──────────────────┘ │ --- ┌▽───────────────────────────────────────▽┐ --- │HscEnv │ --- └─────────────────────────────────────────┘ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ -- @ -- --- The 'UnitEnv' references both the 'HomeUnitGraph' (with all the home unit --- modules) and the 'ExternalPackageState' (information about all --- non-home/external units). The 'HscEnv' references this 'UnitEnv' and the --- 'ModuleGraph' (which describes the relationship between the modules being --- compiled). The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. --- --- TODO: Arguably, the 'ModuleGraph' should be part of 'UnitEnv' rather than being in the 'HscEnv'. +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv @@ -119,6 +120,7 @@ import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings @@ -163,6 +165,10 @@ data UnitEnv = UnitEnv , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -182,6 +188,7 @@ initUnitEnv cur_unit hug namever platform = do return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -43,7 +43,6 @@ module GHC.Unit.Home.Graph -- * Very important queries , allInstances - , allFamInstances , allAnns , allCompleteSigs @@ -110,10 +109,6 @@ allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) (hptAllInstances (homeUnitEnv_hpt hue)) -allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) -allFamInstances hug = foldr go (pure emptyModuleEnv) hug where - go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) - allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) ===================================== compiler/GHC/Unit/Home/PackageTable.hs ===================================== @@ -41,7 +41,6 @@ module GHC.Unit.Home.PackageTable -- * Queries about home modules , hptCompleteSigs , hptAllInstances - , hptAllFamInstances , hptAllAnnotations -- ** More Traversal-based queries @@ -208,14 +207,6 @@ hptAllInstances hpt = do let (insts, famInsts) = unzip hits return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) --- | Find all the family instance declarations from the HPT -hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) -hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) - where - hmiModule = mi_module . hm_iface - hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - -- | All annotations from the HPT hptAllAnnotations :: HomePackageTable -> IO AnnEnv hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) ===================================== distrib/configure.ac.in ===================================== @@ -216,7 +216,7 @@ AC_SUBST([LlvmAsCmd]) dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. -if test -z "$LlvmAsFlags" ; then +if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then LlvmAsFlags="--target=$LlvmTarget" fi AC_SUBST([LlvmAsFlags]) ===================================== ghc/GHCi/UI.hs ===================================== @@ -4680,7 +4680,7 @@ clearHPTs = do let pruneHomeUnitEnv hme = liftIO $ do emptyHpt <- emptyHomePackageTable pure hme{ homeUnitEnv_hpt = emptyHpt } - discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG } + discardMG hsc = setModuleGraph GHC.emptyMG hsc modifySessionM $ \hsc_env -> do hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Nothing , tgtNm = Nm {nmProgram = Program {prgPath = "", prgFlags = []}} , tgtMergeObjs = Just (MergeObjs {mergeObjsProgram = Program {prgPath = "@LD_STAGE0@", prgFlags = ["-r"]}, mergeObjsSupportsResponseFiles = False}) +, tgtLlc = Nothing +, tgtOpt = Nothing +, tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtOtool = Nothing +, tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -38,5 +38,10 @@ Target , tgtRanlib = Just (Ranlib {ranlibProgram = Program {prgPath = "@RanlibCmd@", prgFlags = []}}) , tgtNm = Nm {nmProgram = Program {prgPath = "@NmCmd@", prgFlags = []}} , tgtMergeObjs = @MergeObjsCmdMaybe@ +, tgtLlc = @LlcCmdMaybeProg@ +, tgtOpt = @OptCmdMaybeProg@ +, tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtOtool = @OtoolCmdMaybeProg@ +, tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,13 +79,6 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] - -settings-otool-command = @SettingsOtoolCommand@ -settings-install_name_tool-command = @SettingsInstallNameToolCommand@ -settings-llc-command = @SettingsLlcCommand@ -settings-opt-command = @SettingsOptCommand@ -settings-llvm-as-command = @SettingsLlvmAsCommand@ -settings-llvm-as-flags = @SettingsLlvmAsFlags@ settings-use-distro-mingw = @SettingsUseDistroMINGW@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Builder.hs ===================================== @@ -34,7 +34,6 @@ import Base import Context import Oracles.Flag import Oracles.Setting (setting, Setting(..)) -import Oracles.Setting (settingsFileSetting, ToolchainSetting(..)) import Packages import GHC.IO.Encoding (getFileSystemEncoding) @@ -240,7 +239,7 @@ instance H.Builder Builder where Ghc _ st -> do root <- buildRoot unlitPath <- builderPath Unlit - distro_mingw <- settingsFileSetting ToolchainSetting_DistroMinGW + distro_mingw <- lookupSystemConfig "settings-use-distro-mingw" libffi_adjustors <- useLibffiForAdjustors use_system_ffi <- flag UseSystemFfi ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -2,7 +2,6 @@ module Oracles.Setting ( configFile, -- * Settings Setting (..), setting, getSetting, - ToolchainSetting (..), settingsFileSetting, -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, @@ -75,25 +74,6 @@ data Setting = CursesIncludeDir | BourneShell | EmsdkVersion --- TODO compute solely in Hadrian, removing these variables' definitions --- from aclocal.m4 whenever they can be calculated from other variables --- already fed into Hadrian. - --- | All 'ToolchainSetting's are computed by the ghc-toolchain utility for configuring toolchains. --- This used to be defined by 'FP_SETTINGS' in aclocal.m4. --- --- TODO: We should be able to drop this completely, after moving all the toolchain settings to ghc-toolchain --- Move to ghc-toolchain and to the Target files generated by configure and ghc-toolchain --- * First we will get rid of DistroMinGW when we fix the windows build -data ToolchainSetting - = ToolchainSetting_OtoolCommand - | ToolchainSetting_InstallNameToolCommand - | ToolchainSetting_LlcCommand - | ToolchainSetting_OptCommand - | ToolchainSetting_LlvmAsCommand - | ToolchainSetting_LlvmAsFlags - | ToolchainSetting_DistroMinGW - -- | Look up the value of a 'Setting' in @cfg/system.config@, tracking the -- result. setting :: Setting -> Action String @@ -134,20 +114,6 @@ setting key = lookupSystemConfig $ case key of BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" --- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the --- result. --- See Note [tooldir: How GHC finds mingw on Windows] --- ROMES:TODO: This should be queryTargetTargetConfig -settingsFileSetting :: ToolchainSetting -> Action String -settingsFileSetting key = lookupSystemConfig $ case key of - ToolchainSetting_OtoolCommand -> "settings-otool-command" - ToolchainSetting_InstallNameToolCommand -> "settings-install_name_tool-command" - ToolchainSetting_LlcCommand -> "settings-llc-command" - ToolchainSetting_OptCommand -> "settings-opt-command" - ToolchainSetting_LlvmAsCommand -> "settings-llvm-as-command" - ToolchainSetting_LlvmAsFlags -> "settings-llvm-as-flags" - ToolchainSetting_DistroMinGW -> "settings-use-distro-mingw" -- ROMES:TODO: This option doesn't seem to be in ghc-toolchain yet. It corresponds to EnableDistroToolchain - -- | An expression that looks up the value of a 'Setting' in @cfg/system.config@, -- tracking the result. getSetting :: Setting -> Expr c b String ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,7 +424,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW + , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -508,9 +508,9 @@ generateSettings settingsFile = do , ("ar flags", queryTarget arFlags) , ("ar supports at file", queryTarget arSupportsAtFile') , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", expr $ settingsFileSetting ToolchainSetting_OtoolCommand) - , ("install_name_tool command", expr $ settingsFileSetting ToolchainSetting_InstallNameToolCommand) + , ("ranlib command", queryTarget ranlibPath) + , ("otool command", queryTarget otoolPath) + , ("install_name_tool command", queryTarget installNameToolPath) , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) @@ -525,11 +525,11 @@ generateSettings settingsFile = do , ("target has libm", expr $ lookupSystemConfig "target-has-libm") , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", expr $ settingsFileSetting ToolchainSetting_LlcCommand) - , ("LLVM opt command", expr $ settingsFileSetting ToolchainSetting_OptCommand) - , ("LLVM llvm-as command", expr $ settingsFileSetting ToolchainSetting_LlvmAsCommand) - , ("LLVM llvm-as flags", expr $ settingsFileSetting ToolchainSetting_LlvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ settingsFileSetting ToolchainSetting_DistroMinGW) + , ("LLVM llc command", queryTarget llcPath) + , ("LLVM opt command", queryTarget optPath) + , ("LLVM llvm-as command", queryTarget llvmAsPath) + , ("LLVM llvm-as flags", queryTarget llvmAsFlags) + , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) @@ -571,10 +571,16 @@ generateSettings settingsFile = do linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink + llcPath = maybe "" prgPath . tgtLlc + optPath = maybe "" prgPath . tgtOpt + llvmAsPath = maybe "" prgPath . tgtLlvmAs + llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs arPath = prgPath . arMkArchive . tgtAr arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr arSupportsDashL' = yesNo . arSupportsDashL . tgtAr + otoolPath = maybe "" prgPath . tgtOtool + installNameToolPath = maybe "" prgPath . tgtInstallNameTool ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -127,9 +127,9 @@ inTreeCompilerArgs stg = do platform <- queryTargetTarget targetPlatformTriple wordsize <- show @Int . (*8) <$> queryTargetTarget (wordSize2Bytes . tgtWordSize) - llc_cmd <- settingsFileSetting ToolchainSetting_LlcCommand - llvm_as_cmd <- settingsFileSetting ToolchainSetting_LlvmAsCommand - have_llvm <- liftIO (all isJust <$> mapM findExecutable [llc_cmd, llvm_as_cmd]) + llc_cmd <- queryTargetTarget tgtLlc + llvm_as_cmd <- queryTargetTarget tgtLlvmAs + let have_llvm = all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory ===================================== m4/fp_settings.m4 ===================================== @@ -136,14 +136,7 @@ AC_DEFUN([FP_SETTINGS], fi # Mac-only tools - if test -z "$OtoolCmd"; then - OtoolCmd="otool" - fi SettingsOtoolCommand="$OtoolCmd" - - if test -z "$InstallNameToolCmd"; then - InstallNameToolCmd="install_name_tool" - fi SettingsInstallNameToolCommand="$InstallNameToolCmd" SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -107,6 +107,9 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--llc=$LlcCmd" >> acargs + echo "--opt=$OptCmd" >> acargs + echo "--llvm-as=$LlvmAsCmd" >> acargs if test -n "$USER_LD"; then echo "--ld=$USER_LD" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -10,6 +10,38 @@ # This toolchain will additionally be used to validate the one generated by # ghc-toolchain. See Note [ghc-toolchain consistency checking]. +# PREP_LIST +# ============ +# +# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a +# space-separated list of args +# i.e. +# "arg1 arg2 arg3" +# ==> +# ["arg1","arg2","arg3"] +# +# $1 = list variable to substitute +dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. +AC_DEFUN([PREP_LIST],[ + # shell array + set -- $$1 + $1List="@<:@" + if test "[$]#" -eq 0; then + # no arguments + true + else + $1List="${$1List}\"[$]1\"" + shift # drop first elem + for arg in "[$]@" + do + $1List="${$1List},\"$arg\"" + done + fi + $1List="${$1List}@:>@" + + AC_SUBST([$1List]) +]) + # PREP_MAYBE_SIMPLE_PROGRAM # ========================= # @@ -27,6 +59,25 @@ AC_DEFUN([PREP_MAYBE_SIMPLE_PROGRAM],[ AC_SUBST([$1MaybeProg]) ]) +# PREP_MAYBE_PROGRAM +# ========================= +# +# Introduce a substitution [$1MaybeProg] with +# * Nothing, if $$1 is empty +# * Just (Program {prgPath = "$$1", prgFlags = [elements of $$2]}), otherwise +# +# $1 = optional program path +# $2 = program arguments +AC_DEFUN([PREP_MAYBE_PROGRAM],[ + if test -z "$$1"; then + $1MaybeProg=Nothing + else + PREP_LIST([$2]) + $1MaybeProg="Just (Program {prgPath = \"$$1\", prgFlags = $$2List})" + fi + AC_SUBST([$1MaybeProg]) +]) + # PREP_MAYBE_STRING # ========================= # @@ -86,38 +137,6 @@ AC_DEFUN([PREP_NOT_BOOLEAN],[ AC_SUBST([Not$1Bool]) ]) -# PREP_LIST -# ============ -# -# Issue a substitution with ["list","of","args"] of [$1List] when $1 is a -# space-separated list of args -# i.e. -# "arg1 arg2 arg3" -# ==> -# ["arg1","arg2","arg3"] -# -# $1 = list variable to substitute -dnl In autoconf, '@<:@' stands for '[', and '@:>@' for ']'. -AC_DEFUN([PREP_LIST],[ - # shell array - set -- $$1 - $1List="@<:@" - if test "[$]#" -eq 0; then - # no arguments - true - else - $1List="${$1List}\"[$]1\"" - shift # drop first elem - for arg in "[$]@" - do - $1List="${$1List},\"$arg\"" - done - fi - $1List="${$1List}@:>@" - - AC_SUBST([$1List]) -]) - # Eventually: PREP_BUILD_TARGET_FILE, PREP_HOST_TARGET_FILE, PREP_TARGET_TARGET_FILE # Prepares required substitutions to generate the target file AC_DEFUN([PREP_TARGET_FILE],[ @@ -148,7 +167,12 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_LIST([JavaScriptCPPArgs]) PREP_LIST([CmmCPPArgs]) PREP_LIST([CmmCPPArgs_STAGE0]) + PREP_MAYBE_SIMPLE_PROGRAM([LlcCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) + PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) PREP_MAYBE_STRING([HostVendor_CPP]) PREP_LIST([CONF_CPP_OPTS_STAGE2]) ===================================== rts/linker/LoadArchive.c ===================================== @@ -33,6 +33,7 @@ #define DEBUG_LOG(...) IF_DEBUG(linker, debugBelch("loadArchive: " __VA_ARGS__)) + #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Read 4 bytes and convert to host byte order */ static uint32_t read4Bytes(const char buf[static 4]) @@ -40,7 +41,7 @@ static uint32_t read4Bytes(const char buf[static 4]) return ntohl(*(uint32_t*)buf); } -static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) +static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) { uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; #if defined(i386_HOST_ARCH) @@ -58,8 +59,9 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) #error Unknown Darwin architecture #endif - nfat_arch = read4Bytes(tmp + 4); + nfat_arch = read4Bytes(input + 4); DEBUG_LOG("found a fat archive containing %d architectures\n", nfat_arch); + char tmp[20]; nfat_offset = 0; for (uint32_t i = 0; i < nfat_arch; i++) { /* search for the right arch */ @@ -90,6 +92,7 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } /* Read the header */ + char tmp[20]; n = fread(tmp, 1, 8, f); if (n != 8) { errorBelch("Failed reading header from `%" PATH_FMT "'", path); @@ -107,10 +110,51 @@ static StgBool loadFatArchive(char tmp[static 20], FILE* f, pathchar* path) } #endif -static StgBool readThinArchiveMember(int n, int memberSize, pathchar* path, +enum ObjectFileFormat { + NotObject, + COFFAmd64, + COFFI386, + COFFAArch64, + ELF, + MachO32, + MachO64, +}; + +static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +{ + if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { + return COFFAmd64; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { + return COFFI386; + } + if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { + return COFFAArch64; + } + if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { + return ELF; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { + return MachO32; + } + if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { + return MachO64; + } + return NotObject; +} + +static enum ObjectFileFormat identifyObjectFile(FILE *f) +{ + char buf[32]; + ssize_t sz = fread(buf, 1, 32, f); + CHECK(fseek(f, -sz, SEEK_CUR) == 0); + return identifyObjectFile_(buf, sz); +} + +static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) { - StgBool has_succeeded = false; + bool has_succeeded = false; FILE* member = NULL; pathchar *pathCopy, *dirName, *memberPath, *objFileName; memberPath = NULL; @@ -148,10 +192,9 @@ inner_fail: return has_succeeded; } -static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) +static bool checkFatArchive(char magic[static 4], FILE* f, pathchar* path) { - StgBool success; - success = false; + bool success = false; #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) /* Not a standard archive, look for a fat archive magic number: */ if (read4Bytes(magic) == FAT_MAGIC) @@ -175,7 +218,7 @@ static StgBool checkFatArchive(char magic[static 20], FILE* f, pathchar* path) * be reallocated on return; the old value is now _invalid_. * @param gnuFileIndexSize The size of the index. */ -static StgBool +static bool lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, char* gnuFileIndex, pathchar* path, size_t* thisFileNameSize, size_t* fileNameSize) @@ -241,47 +284,21 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, return true; } -HsInt loadArchive_ (pathchar *path) -{ - char *image = NULL; - HsInt retcode = 0; - int memberSize; - int memberIdx = 0; - FILE *f = NULL; - int n; - size_t thisFileNameSize = (size_t)-1; /* shut up bogus GCC warning */ - char *fileName; - size_t fileNameSize; - int isObject, isGnuIndex, isThin, isImportLib; - char tmp[20]; - char *gnuFileIndex; - int gnuFileIndexSize; - int misalignment = 0; - - DEBUG_LOG("start\n"); - DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); +enum ArchiveFormat { + StandardArchive, + ThinArchive, + FatArchive, +}; - /* Check that we haven't already loaded this archive. - Ignore requests to load multiple times */ - if (isAlreadyLoaded(path)) { - IF_DEBUG(linker, - debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); - return 1; /* success */ +static bool identifyArchiveFormat(FILE *f, pathchar *path, enum ArchiveFormat *out) +{ + char tmp[8]; + size_t n = fread(tmp, 1, 8, f); + if (n != 8) { + errorBelch("loadArchive: Failed reading header from `%" PATH_FMT "'", path); \ + return false; } - gnuFileIndex = NULL; - gnuFileIndexSize = 0; - - fileNameSize = 32; - fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); - - isThin = 0; - isImportLib = 0; - - f = pathopen(path, WSTR("rb")); - if (!f) - FAIL("loadObj: can't read `%" PATH_FMT "'", path); - /* Check if this is an archive by looking for the magic "!<arch>\n" * string. Usually, if this fails, we belch an error and return. On * Darwin however, we may have a fat archive, which contains archives for @@ -300,12 +317,10 @@ HsInt loadArchive_ (pathchar *path) * its magic "!<arch>\n" string and continue processing just as if * we had a single architecture archive. */ - - n = fread ( tmp, 1, 8, f ); - if (n != 8) { - FAIL("Failed reading header from `%" PATH_FMT "'", path); + if (strncmp(tmp, "!<arch>\n", 8) == 0) { + *out = StandardArchive; + return true; } - if (strncmp(tmp, "!<arch>\n", 8) == 0) {} /* Check if this is a thin archive by looking for the magic string "!<thin>\n" * * ar thin libraries have the exact same format as normal archives except they @@ -322,16 +337,59 @@ HsInt loadArchive_ (pathchar *path) * */ else if (strncmp(tmp, "!<thin>\n", 8) == 0) { - isThin = 1; + *out = ThinArchive; + return true; } else { - StgBool success = checkFatArchive(tmp, f, path); - if (!success) - goto fail; + bool success = checkFatArchive(tmp, f, path); + if (!success) { + return false; + } + *out = FatArchive; + return true; } +} + +HsInt loadArchive_ (pathchar *path) +{ + char *image = NULL; + HsInt retcode = 0; + int memberIdx = 0; + FILE *f = NULL; + size_t thisFileNameSize = (size_t) -1; /* shut up bogus GCC warning */ + int misalignment = 0; + + DEBUG_LOG("start\n"); + DEBUG_LOG("Loading archive `%" PATH_FMT "'\n", path); + + /* Check that we haven't already loaded this archive. + Ignore requests to load multiple times */ + if (isAlreadyLoaded(path)) { + IF_DEBUG(linker, + debugBelch("ignoring repeated load of %" PATH_FMT "\n", path)); + return 1; /* success */ + } + + char *gnuFileIndex = NULL; + int gnuFileIndexSize = 0; + + size_t fileNameSize = 32; + char *fileName = stgMallocBytes(fileNameSize, "loadArchive(fileName)"); + + f = pathopen(path, WSTR("rb")); + if (!f) + FAIL("loadObj: can't read `%" PATH_FMT "'", path); + + enum ArchiveFormat archive_fmt; + if (!identifyArchiveFormat(f, path, &archive_fmt)) { + FAIL("failed to identify archive format of %" PATH_FMT ".", path); + } + bool isThin = archive_fmt == ThinArchive; + DEBUG_LOG("loading archive contents\n"); while (1) { + size_t n; DEBUG_LOG("reading at %ld\n", ftell(f)); n = fread ( fileName, 1, 16, f ); if (n != 16) { @@ -351,6 +409,7 @@ HsInt loadArchive_ (pathchar *path) } #endif + char tmp[32]; n = fread ( tmp, 1, 12, f ); if (n != 12) FAIL("Failed reading mod time from `%" PATH_FMT "'", path); @@ -369,9 +428,16 @@ HsInt loadArchive_ (pathchar *path) tmp[10] = '\0'; for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; - memberSize = atoi(tmp); + size_t memberSize; + { + char *end; + memberSize = strtol(tmp, &end, 10); + if (tmp == end) { + FAIL("Failed to decode member size"); + } + } - DEBUG_LOG("size of this archive member is %d\n", memberSize); + DEBUG_LOG("size of this archive member is %zd\n", memberSize); n = fread ( tmp, 1, 2, f ); if (n != 2) FAIL("Failed reading magic from `%" PATH_FMT "'", path); @@ -379,7 +445,7 @@ HsInt loadArchive_ (pathchar *path) FAIL("Failed reading magic from `%" PATH_FMT "' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); - isGnuIndex = 0; + bool isGnuIndex = false; /* Check for BSD-variant large filenames */ if (0 == strncmp(fileName, "#1/", 3)) { size_t n = 0; @@ -419,7 +485,7 @@ HsInt loadArchive_ (pathchar *path) else if (0 == strncmp(fileName, "//", 2)) { fileName[0] = '\0'; thisFileNameSize = 0; - isGnuIndex = 1; + isGnuIndex = true; } /* Check for a file in the GNU file index */ else if (fileName[0] == '/') { @@ -460,12 +526,8 @@ HsInt loadArchive_ (pathchar *path) DEBUG_LOG("Found member file `%s'\n", fileName); - /* TODO: Stop relying on file extensions to determine input formats. - Instead try to match file headers. See #13103. */ - isObject = (thisFileNameSize >= 2 && strncmp(fileName + thisFileNameSize - 2, ".o" , 2) == 0) - || (thisFileNameSize >= 3 && strncmp(fileName + thisFileNameSize - 3, ".lo" , 3) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".p_o", 4) == 0) - || (thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".obj", 4) == 0); + bool is_symbol_table = strcmp("", fileName) == 0; + enum ObjectFileFormat object_fmt = is_symbol_table ? NotObject : identifyObjectFile(f); #if defined(OBJFORMAT_PEi386) /* @@ -479,15 +541,15 @@ HsInt loadArchive_ (pathchar *path) * * Linker members (e.g. filename / are skipped since they are not needed) */ - isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; + bool isImportLib = thisFileNameSize >= 4 && strncmp(fileName + thisFileNameSize - 4, ".dll", 4) == 0; +#else + bool isImportLib = false; #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", isObject); - - if (isObject) { - pathchar *archiveMemberName; + DEBUG_LOG("\tisObject = %d\n", object_fmt); + if ((!is_symbol_table && isThin) || object_fmt != NotObject) { DEBUG_LOG("Member is an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) @@ -505,14 +567,13 @@ HsInt loadArchive_ (pathchar *path) image = stgMallocBytes(memberSize, "loadArchive(image)"); #endif if (isThin) { - if (!readThinArchiveMember(n, memberSize, path, - fileName, image)) { + if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } } else { - n = fread ( image, 1, memberSize, f ); + size_t n = fread ( image, 1, memberSize, f ); if (n != memberSize) { FAIL("error whilst reading `%" PATH_FMT "'", path); } @@ -523,16 +584,18 @@ HsInt loadArchive_ (pathchar *path) // I don't understand why this extra +1 is needed here; pathprintf // should have given us the correct length but in practice it seems // to be one byte short on Win32. - archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); + pathchar *archiveMemberName = stgMallocBytes((size+1+1) * sizeof(pathchar), "loadArchive(file)"); pathprintf(archiveMemberName, size+1, WSTR("%" PATH_FMT "(#%d:%.*s)"), path, memberIdx, (int)thisFileNameSize, fileName); ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); #if defined(OBJFORMAT_MACHO) + ASSERT(object_fmt == MachO32 || object_fmt == MachO64); ocInit_MachO( oc ); #endif #if defined(OBJFORMAT_ELF) + ASSERT(object_fmt == ELF); ocInit_ELF( oc ); #endif @@ -577,7 +640,7 @@ while reading filename from `%" PATH_FMT "'", path); "Skipping...\n"); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } #endif @@ -588,7 +651,7 @@ while reading filename from `%" PATH_FMT "'", path); if (!isThin || thisFileNameSize == 0) { n = fseek(f, memberSize, SEEK_CUR); if (n != 0) - FAIL("error whilst seeking by %d in `%" PATH_FMT "'", + FAIL("error whilst seeking by %zd in `%" PATH_FMT "'", memberSize, path); } } ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -52,7 +52,12 @@ data Opts = Opts , optNm :: ProgOpt , optReadelf :: ProgOpt , optMergeObjs :: ProgOpt + , optLlc :: ProgOpt + , optOpt :: ProgOpt + , optLlvmAs :: ProgOpt , optWindres :: ProgOpt + , optOtool :: ProgOpt + , optInstallNameTool :: ProgOpt -- Note we don't actually configure LD into anything but -- see #23857 and #22550 for the very unfortunate story. , optLd :: ProgOpt @@ -99,8 +104,13 @@ emptyOpts = Opts , optNm = po0 , optReadelf = po0 , optMergeObjs = po0 + , optLlc = po0 + , optOpt = po0 + , optLlvmAs = po0 , optWindres = po0 , optLd = po0 + , optOtool = po0 + , optInstallNameTool = po0 , optUnregisterised = Nothing , optTablesNextToCode = Nothing , optUseLibFFIForAdjustors = Nothing @@ -112,7 +122,8 @@ emptyOpts = Opts po0 = emptyProgOpt _optCc, _optCxx, _optCpp, _optHsCpp, _optJsCpp, _optCmmCpp, _optCcLink, _optAr, - _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optWindres, _optLd + _optRanlib, _optNm, _optReadelf, _optMergeObjs, _optLlc, _optOpt, _optLlvmAs, + _optWindres, _optLd, _optOtool, _optInstallNameTool :: Lens Opts ProgOpt _optCc = Lens optCc (\x o -> o {optCc=x}) _optCxx = Lens optCxx (\x o -> o {optCxx=x}) @@ -126,8 +137,13 @@ _optRanlib = Lens optRanlib (\x o -> o {optRanlib=x}) _optNm = Lens optNm (\x o -> o {optNm=x}) _optReadelf = Lens optReadelf (\x o -> o {optReadelf=x}) _optMergeObjs = Lens optMergeObjs (\x o -> o {optMergeObjs=x}) +_optLlc = Lens optLlc (\x o -> o {optLlc=x}) +_optOpt = Lens optOpt (\x o -> o {optOpt=x}) +_optLlvmAs = Lens optLlvmAs (\x o -> o {optLlvmAs=x}) _optWindres = Lens optWindres (\x o -> o {optWindres=x}) -_optLd = Lens optLd (\x o -> o {optLd= x}) +_optLd = Lens optLd (\x o -> o {optLd=x}) +_optOtool = Lens optOtool (\x o -> o {optOtool=x}) +_optInstallNameTool = Lens optInstallNameTool (\x o -> o {optInstallNameTool=x}) _optTriple :: Lens Opts (Maybe String) _optTriple = Lens optTriple (\x o -> o {optTriple=x}) @@ -183,8 +199,13 @@ options = , progOpts "nm" "nm archiver" _optNm , progOpts "readelf" "readelf utility" _optReadelf , progOpts "merge-objs" "linker for merging objects" _optMergeObjs + , progOpts "llc" "LLVM llc utility" _optLlc + , progOpts "opt" "LLVM opt utility" _optOpt + , progOpts "llvm-as" "Assembler used for LLVM backend (typically clang)" _optLlvmAs , progOpts "windres" "windres utility" _optWindres , progOpts "ld" "linker" _optLd + , progOpts "otool" "otool utility" _optOtool + , progOpts "install-name-tool" "install-name-tool utility" _optInstallNameTool ] where progOpts :: String -> String -> Lens Opts ProgOpt -> [OptDescr (Opts -> Opts)] @@ -436,6 +457,11 @@ mkTarget opts = do when (isNothing mergeObjs && not (arSupportsDashL ar)) $ throwE "Neither a object-merging tool (e.g. ld -r) nor an ar that supports -L is available" + -- LLVM toolchain + llc <- optional $ findProgram "llc" (optLlc opts) ["llc"] + opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] + llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] + -- Windows-specific utilities windres <- case archOS_OS archOs of @@ -444,6 +470,15 @@ mkTarget opts = do return (Just windres) _ -> return Nothing + -- Darwin-specific utilities + (otool, installNameTool) <- + case archOS_OS archOs of + OSDarwin -> do + otool <- findProgram "otool" (optOtool opts) ["otool"] + installNameTool <- findProgram "install_name_tool" (optInstallNameTool opts) ["install_name_tool"] + return (Just otool, Just installNameTool) + _ -> return (Nothing, Nothing) + -- various other properties of the platform tgtWordSize <- checkWordSize cc tgtEndianness <- checkEndianness cc @@ -480,7 +515,12 @@ mkTarget opts = do , tgtRanlib = ranlib , tgtNm = nm , tgtMergeObjs = mergeObjs + , tgtLlc = llc + , tgtOpt = opt + , tgtLlvmAs = llvmAs , tgtWindres = windres + , tgtOtool = otool + , tgtInstallNameTool = installNameTool , tgtWordSize , tgtEndianness , tgtUnregisterised ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -22,15 +22,6 @@ data WordSize = WS4 | WS8 data Endianness = LittleEndian | BigEndian deriving (Show, Read, Eq, Ord) --- TODO(#23674): Move the remaining relevant `settings-xxx` to Target: --- * llc command --- * opt command --- * install_name_tool --- * otool command --- --- Those are all things that are put into GHC's settings, and that might be --- different across targets - -- | A 'Target' consists of: -- -- * a target architecture and operating system @@ -72,8 +63,18 @@ data Target = Target , tgtMergeObjs :: Maybe MergeObjs -- ^ We don't need a merge objects tool if we @Ar@ supports @-L@ + -- LLVM backend toolchain + , tgtLlc :: Maybe Program + , tgtOpt :: Maybe Program + , tgtLlvmAs :: Maybe Program + -- ^ assembler used to assemble LLVM backend output; typically @clang@ + -- Windows-specific tools , tgtWindres :: Maybe Program + + -- Darwin-specific tools + , tgtOtool :: Maybe Program + , tgtInstallNameTool :: Maybe Program } deriving (Read, Eq, Ord) @@ -121,6 +122,11 @@ instance Show Target where , ", tgtRanlib = " ++ show tgtRanlib , ", tgtNm = " ++ show tgtNm , ", tgtMergeObjs = " ++ show tgtMergeObjs + , ", tgtLlc = " ++ show tgtLlc + , ", tgtOpt = " ++ show tgtOpt + , ", tgtLlvmAs = " ++ show tgtLlvmAs , ", tgtWindres = " ++ show tgtWindres + , ", tgtOtool = " ++ show tgtOtool + , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ce82af2d765f2e6662f55f2f1190ce... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ce82af2d765f2e6662f55f2f1190ce... You're receiving this email because of your account on gitlab.haskell.org.