Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b253013e by Georgios Karachalias at 2025-11-07T17:21:57-05:00 Remove the `CoreBindings` constructor from `LinkablePart` Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings from being passed as input to getLinkDeps (which would previously panic in this case). Fixes #26497 - - - - - 7 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -277,6 +277,7 @@ import Data.Data hiding (Fixity, TyCon) import Data.Functor ((<&>)) import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE +import Data.Traversable (for) import Control.Monad import Data.IORef import System.FilePath as FilePath @@ -850,11 +851,11 @@ hscRecompStatus if | not (backendGeneratesCode (backend lcl_dflags)) -> do -- No need for a linkable, we're good to go msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + return $ HscUpToDate checked_iface emptyRecompLinkables | not (backendGeneratesCodeForHsBoot (backend lcl_dflags)) , IsBoot <- isBootSummary mod_summary -> do msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + return $ HscUpToDate checked_iface emptyRecompLinkables -- Always recompile with the JS backend when TH is enabled until -- #23013 is fixed. @@ -883,7 +884,7 @@ hscRecompStatus let just_o = justObjects <$> obj_linkable bytecode_or_object_code - | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc + | gopt Opt_WriteByteCode lcl_dflags = justBytecode . Left <$> definitely_bc | otherwise = (justBytecode <$> maybe_bc) `choose` just_o @@ -900,13 +901,13 @@ hscRecompStatus definitely_bc = bc_obj_linkable `prefer` bc_in_memory_linkable -- If not -fwrite-byte-code, then we could use core bindings or object code if that's available. - maybe_bc = bc_in_memory_linkable `choose` - bc_obj_linkable `choose` - bc_core_linkable + maybe_bc = (Left <$> bc_in_memory_linkable) `choose` + (Left <$> bc_obj_linkable) `choose` + (Right <$> bc_core_linkable) bc_result = if gopt Opt_WriteByteCode lcl_dflags -- If the byte-code artifact needs to be produced, then we certainly need bytecode. - then definitely_bc + then Left <$> definitely_bc else maybe_bc trace_if (hsc_logger hsc_env) @@ -1021,14 +1022,13 @@ checkByteCodeFromObject hsc_env mod_sum = do -- | Attempt to load bytecode from whole core bindings in the interface if they exist. -- This is a legacy code-path, these days it should be preferred to use the bytecode object linkable. -checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated Linkable) +checkByteCodeFromIfaceCoreBindings :: HscEnv -> ModIface -> ModSummary -> IO (MaybeValidated WholeCoreBindingsLinkable) checkByteCodeFromIfaceCoreBindings _hsc_env iface mod_sum = do let this_mod = ms_mod mod_sum if_date = fromJust $ ms_iface_date mod_sum case iface_core_bindings iface (ms_location mod_sum) of - Just fi -> do - return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi)))) + Just fi -> return $ UpToDateItem (Linkable if_date this_mod fi) _ -> return $ outOfDateItemBecause MissingBytecode Nothing -------------------------------------------------------------- @@ -1142,20 +1142,22 @@ initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> - Linkable -> - IO Linkable -initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do - Linkable utc_time this_mod <$> mapM (go hsc_env) uls + RecompLinkables -> + IO HomeModLinkable +initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do + bc' <- go bc + pure $ HomeModLinkable bc' o where - go hsc_env' = \case - CoreBindings wcb -> do + type_env = md_types details + + go :: RecompBytecodeLinkable -> IO (Maybe Linkable) + go (NormalLinkable l) = pure l + go (WholeCoreBindingsLinkable wcbl) = + fmap Just $ for wcbl $ \wcb -> do add_iface_to_hpt iface details hsc_env bco <- unsafeInterleaveIO $ - compileWholeCoreBindings hsc_env' type_env wcb - pure (DotGBC bco) - l -> pure l - - type_env = md_types details + compileWholeCoreBindings hsc_env type_env wcb + pure $ NE.singleton (DotGBC bco) -- | Hydrate interface Core bindings and compile them to bytecode. -- ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -109,6 +109,7 @@ import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Status import GHC.Unit.Home.ModInfo import GHC.Unit.Home.PackageTable @@ -249,8 +250,8 @@ compileOne' mHscMessage (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline -- See Note [ModDetails and --make mode] details <- initModDetails plugin_hsc_env iface - linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) - return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' }) + linkable' <- initWholeCoreBindings plugin_hsc_env iface details linkable + return $! HomeModInfo iface details linkable' where lcl_dflags = ms_hspp_opts summary location = ms_location summary @@ -759,7 +760,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do $ phaseIfFlag hsc_env flag def action -- | The complete compilation pipeline, from start to finish -fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, RecompLinkables) fullPipeline pipe_env hsc_env pp_fn src_flavour = do (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn let hsc_env' = hscSetFlags dflags hsc_env @@ -768,7 +769,7 @@ fullPipeline pipe_env hsc_env pp_fn src_flavour = do hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) -- | Everything after preprocess -hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) +hscPipeline :: P m => PipeEnv -> (HscEnv, ModSummary, HscRecompStatus) -> m (ModIface, RecompLinkables) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do case hsc_recomp_status of HscUpToDate iface mb_linkable -> return (iface, mb_linkable) @@ -777,7 +778,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, RecompLinkables) hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do @@ -796,15 +797,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = return res else case result of - HscUpdate iface -> return (iface, emptyHomeModInfoLinkable) - HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable + HscUpdate iface -> return (iface, emptyRecompLinkables) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyRecompLinkables hscGenBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction - -> m (ModIface, HomeModLinkable) + -> m (ModIface, RecompLinkables) hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) @@ -812,7 +813,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result) final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file final_linkable <- - case final_fp of + safeCastHomeModLinkable <$> case final_fp of -- No object file produced, bytecode or NoBackend Nothing -> return mlinkable Just o_fp -> do @@ -936,7 +937,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase = as :: P m => Bool -> m (Maybe FilePath) as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn - objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk + objFromLinkable (_, recompLinkables_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk objFromLinkable _ = Nothing fromPhase :: P m => Phase -> m (Maybe FilePath) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Utils.Error import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.WholeCoreBindings import GHC.Unit.Home.ModInfo import GHC.Iface.Errors.Types @@ -206,10 +205,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do DotO file ForeignObject -> pure (DotO file ForeignObject) DotA fp -> panic ("adjust_ul DotA " ++ show fp) DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp) - DotGBC {} -> pure part - CoreBindings WholeCoreBindings {wcb_module} -> - pprPanic "Unhydrated core bindings" (ppr wcb_module) - + DotGBC {} -> pure part {- ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -1,5 +1,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- -- @@ -30,7 +31,9 @@ module GHC.Linker.Types , PkgsLoaded -- * Linkable - , Linkable(..) + , Linkable + , WholeCoreBindingsLinkable + , LinkableWith(..) , mkModuleByteCodeLinkable , LinkablePart(..) , LinkableObjectSort (..) @@ -254,7 +257,7 @@ instance Outputable LoadedPkgInfo where -- | Information we can use to dynamically link modules into the compiler -data Linkable = Linkable +data LinkableWith parts = Linkable { linkableTime :: !UTCTime -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, @@ -263,9 +266,13 @@ data Linkable = Linkable , linkableModule :: !Module -- ^ The linkable module itself - , linkableParts :: NonEmpty LinkablePart + , linkableParts :: parts -- ^ Files and chunks of code to link. - } + } deriving (Functor, Traversable, Foldable) + +type Linkable = LinkableWith (NonEmpty LinkablePart) + +type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings type LinkableSet = ModuleEnv Linkable @@ -282,7 +289,7 @@ unionLinkableSet = plusModuleEnv_C go | linkableTime l1 > linkableTime l2 = l1 | otherwise = l2 -instance Outputable Linkable where +instance Outputable a => Outputable (LinkableWith a) where ppr (Linkable when_made mod parts) = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod) $$ nest 3 (ppr parts) @@ -318,11 +325,6 @@ data LinkablePart | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | CoreBindings WholeCoreBindings - -- ^ Serialised core which we can turn into BCOs (or object files), or - -- used by some other backend See Note [Interface Files with Core - -- Definitions] - | DotGBC ModuleByteCode -- ^ A byte-code object, lives only in memory. @@ -350,7 +352,6 @@ instance Outputable LinkablePart where ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path ppr (DotGBC bco) = text "DotGBC" <+> ppr bco - ppr (CoreBindings {}) = text "CoreBindings" -- | Return true if the linkable only consists of native code (no BCO) linkableIsNativeCodeOnly :: Linkable -> Bool @@ -391,7 +392,6 @@ isNativeCode = \case DotA {} -> True DotDLL {} -> True DotGBC {} -> False - CoreBindings {} -> False -- | Is the part a native library? (.so/.dll) isNativeLib :: LinkablePart -> Bool @@ -400,7 +400,6 @@ isNativeLib = \case DotA {} -> True DotDLL {} -> True DotGBC {} -> False - CoreBindings {} -> False -- | Get the FilePath of linkable part (if applicable) linkablePartPath :: LinkablePart -> Maybe FilePath @@ -408,7 +407,6 @@ linkablePartPath = \case DotO fn _ -> Just fn DotA fn -> Just fn DotDLL fn -> Just fn - CoreBindings {} -> Nothing DotGBC {} -> Nothing -- | Return the paths of all object code files (.o, .a, .so) contained in this @@ -418,7 +416,6 @@ linkablePartNativePaths = \case DotO fn _ -> [fn] DotA fn -> [fn] DotDLL fn -> [fn] - CoreBindings {} -> [] DotGBC {} -> [] -- | Return the paths of all object files (.o) contained in this 'LinkablePart'. @@ -427,7 +424,6 @@ linkablePartObjectPaths = \case DotO fn _ -> [fn] DotA _ -> [] DotDLL _ -> [] - CoreBindings {} -> [] DotGBC bco -> gbc_foreign_files bco -- | Retrieve the compiled byte-code from the linkable part. @@ -444,12 +440,11 @@ linkableFilter f linkable = do Just linkable {linkableParts = new} linkablePartNative :: LinkablePart -> [LinkablePart] -linkablePartNative = \case - u@DotO {} -> [u] - u@DotA {} -> [u] - u@DotDLL {} -> [u] +linkablePartNative u = case u of + DotO {} -> [u] + DotA {} -> [u] + DotDLL {} -> [u] DotGBC bco -> [DotO f ForeignObject | f <- gbc_foreign_files bco] - _ -> [] linkablePartByteCode :: LinkablePart -> [LinkablePart] linkablePartByteCode = \case ===================================== compiler/GHC/Unit/Home/ModInfo.hs ===================================== @@ -3,13 +3,10 @@ module GHC.Unit.Home.ModInfo ( HomeModInfo (..) - , HomeModLinkable(..) + , HomeModLinkable (..) , homeModInfoObject , homeModInfoByteCode , emptyHomeModInfoLinkable - , justBytecode - , justObjects - , bytecodeAndObjects ) where @@ -18,11 +15,9 @@ import GHC.Prelude import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails -import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly ) +import GHC.Linker.Types ( Linkable ) import GHC.Utils.Outputable -import GHC.Utils.Panic - -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo @@ -68,22 +63,6 @@ data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) instance Outputable HomeModLinkable where ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 -justBytecode :: Linkable -> HomeModLinkable -justBytecode lm = - assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) - $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } - -justObjects :: Linkable -> HomeModLinkable -justObjects lm = - assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) - $ emptyHomeModInfoLinkable { homeMod_object = Just lm } - -bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable -bytecodeAndObjects bc o = - assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) - (HomeModLinkable (Just bc) (Just o)) - - {- Note [Home module build products] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Unit/Module/Status.hs ===================================== @@ -1,22 +1,35 @@ +{-# LANGUAGE LambdaCase #-} + module GHC.Unit.Module.Status - ( HscBackendAction(..), HscRecompStatus (..) + ( HscBackendAction(..) + , HscRecompStatus (..) + , RecompLinkables (..) + , RecompBytecodeLinkable (..) + , emptyRecompLinkables + , justBytecode + , justObjects + , bytecodeAndObjects + , safeCastHomeModLinkable ) where import GHC.Prelude import GHC.Unit +import GHC.Unit.Home.ModInfo import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface +import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly ) + import GHC.Utils.Fingerprint import GHC.Utils.Outputable -import GHC.Unit.Home.ModInfo +import GHC.Utils.Panic -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface HomeModLinkable + = HscUpToDate ModIface RecompLinkables -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. @@ -41,6 +54,16 @@ data HscBackendAction -- changed. } +-- | Linkables produced by @hscRecompStatus@. Might contain serialized core +-- which can be turned into BCOs (or object files), or used by some other +-- backend. See Note [Interface Files with Core Definitions]. +data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompBytecodeLinkable + , recompLinkables_object :: !(Maybe Linkable) } + +data RecompBytecodeLinkable + = NormalLinkable !(Maybe Linkable) + | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable + instance Outputable HscRecompStatus where ppr HscUpToDate{} = text "HscUpToDate" ppr HscRecompNeeded{} = text "HscRecompNeeded" @@ -48,3 +71,37 @@ instance Outputable HscRecompStatus where instance Outputable HscBackendAction where ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi)) ppr (HscRecomp _ ml _mi _mf) = text "Recomp:" <+> ppr ml + +instance Outputable RecompLinkables where + ppr (RecompLinkables l1 l2) = ppr l1 $$ ppr l2 + +instance Outputable RecompBytecodeLinkable where + ppr (NormalLinkable lm) = text "NormalLinkable:" <+> ppr lm + ppr (WholeCoreBindingsLinkable lm) = text "WholeCoreBindingsLinkable:" <+> ppr lm + +emptyRecompLinkables :: RecompLinkables +emptyRecompLinkables = RecompLinkables (NormalLinkable Nothing) Nothing + +safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables +safeCastHomeModLinkable (HomeModLinkable bc o) = RecompLinkables (NormalLinkable bc) o + +justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables +justBytecode = \case + Left lm -> + assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) + $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) } + Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm } + +justObjects :: Linkable -> RecompLinkables +justObjects lm = + assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) + $ emptyRecompLinkables { recompLinkables_object = Just lm } + +bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> RecompLinkables +bytecodeAndObjects either_bc o = case either_bc of + Left bc -> + assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) + $ RecompLinkables (NormalLinkable (Just bc)) (Just o) + Right bc -> + assertPpr (linkableIsNativeCodeOnly o) (ppr o) + $ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o) ===================================== compiler/GHC/Unit/Module/WholeCoreBindings.hs ===================================== @@ -130,6 +130,9 @@ data WholeCoreBindings = WholeCoreBindings , wcb_foreign :: IfaceForeign } +instance Outputable WholeCoreBindings where + ppr (WholeCoreBindings {}) = text "WholeCoreBindings" + {- Note [Foreign stubs and TH bytecode linking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b253013ebeea5273a1cc7bb0082ed952... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b253013ebeea5273a1cc7bb0082ed952... You're receiving this email because of your account on gitlab.haskell.org.