Matthew Pickering pushed to branch wip/gbc-files at Glasgow Haskell Compiler / GHC Commits: 4fc9edc1 by Matthew Pickering at 2025-09-30T11:54:11+01:00 Fix progress messages - - - - - 4 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Messager.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -575,7 +575,7 @@ mkBackpackMsg = do showMsg msg reason = backpackProgressMsg level logger $ pprWithUnitState state $ showModuleIndex mod_index <> - msg <> showModMsg dflags (recompileRequired recomp) node + msg <> showModMsg dflags node <> reason in case node of InstantiationNode _ _ -> ===================================== compiler/GHC/Driver/Messager.hs ===================================== @@ -48,7 +48,7 @@ batchMsgWith extra hsc_env_start mod_index recomp node = showMsg msg reason = compilationProgressMsg logger $ (showModuleIndex mod_index <> - msg <+> showModMsg dflags (recompileRequired recomp) node) + msg <+> showModMsg dflags node) <> extra hsc_env mod_index recomp node <> reason ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1304,11 +1304,7 @@ showModule mni = do let mod = moduleNodeInfoModule mni withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env - interpreted <- liftIO $ - HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case - Nothing -> panic "missing linkable" - Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) - return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) + return (showSDoc dflags $ showModMsg dflags (ModuleNode [] mni)) moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $ ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -785,8 +785,8 @@ summaryNodeSummary = node_payload -- * Misc utilities -------------------------------------------------------------------------------- -showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc -showModMsg dflags _ (LinkNode {}) = +showModMsg :: DynFlags -> ModuleGraphNode -> SDoc +showModMsg dflags (LinkNode {}) = let staticLink = case ghcLink dflags of LinkStaticLib -> True _ -> False @@ -795,35 +795,36 @@ showModMsg dflags _ (LinkNode {}) = arch_os = platformArchOS platform exe_file = exeFileName arch_os staticLink (outputFile_ dflags) in text exe_file -showModMsg _ _ (UnitNode _deps uid) = ppr uid -showModMsg _ _ (InstantiationNode _uid indef_unit) = +showModMsg _ (UnitNode _deps uid) = ppr uid +showModMsg _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit -showModMsg dflags recomp (ModuleNode _ mni) = +showModMsg dflags (ModuleNode _ mni) = if gopt Opt_HideSourcePaths dflags then text mod_str else hsep $ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') , char '(' , text (moduleNodeInfoSource mni) <> char ',' - , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ] + , moduleNodeInfoExtraMessage mni, char ')' ] where mod_str = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++ moduleNodeInfoBootString mni -- | Extra information about a 'ModuleNodeInfo' to display in the progress message. -moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc -moduleNodeInfoExtraMessage dflags _recomp (ModuleNodeCompile mod_summary) = +moduleNodeInfoExtraMessage :: ModuleNodeInfo -> SDoc +moduleNodeInfoExtraMessage (ModuleNodeCompile mod_summary) = let dyn_file = normalise $ msDynObjFilePath mod_summary obj_file = normalise $ msObjFilePath mod_summary bc_file = normalise $ msBytecodeFilePath mod_summary + dflags = ms_hspp_opts mod_summary bc_message = if gopt Opt_WriteByteCode dflags then bc_file else "interpreted" files = [ obj_file | backendWritesFiles (backend dflags) ] ++ [ dyn_file | backendWritesFiles (backend dflags) && gopt Opt_BuildDynamicToo dflags ] ++ [ bc_message | (backendWritesFiles (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags) || backendWritesBytecodeFiles (backend dflags) ] in case files of [] -> text "nothing" - _ -> sep $ punctuate comma (map text files) -moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed" + _ -> hsep $ punctuate comma (map text files) +moduleNodeInfoExtraMessage (ModuleNodeFixed {}) = text "fixed" -- | The source location of the module node to show to the user. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4fc9edc116373ce5df7e543aa99c837c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4fc9edc116373ce5df7e543aa99c837c... You're receiving this email because of your account on gitlab.haskell.org.