From ca48076ae866665913b9c81cbc0c76f0afef7a00 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 2 Sep 2020 19:42:01 +0200 Subject: Introduce OutputableP Some types need a Platform value to be pretty-printed: CLabel, Cmm types, instructions, etc. Before this patch they had an Outputable instance and the Platform value was obtained via sdocWithDynFlags. It meant that the *renderer* of the SDoc was responsible of passing the appropriate Platform value (e.g. via the DynFlags given to showSDoc). It put the burden of passing the Platform value on the renderer while the generator of the SDoc knows the Platform it is generating the SDoc for and there is no point passing a different Platform at rendering time. With this patch, we introduce a new OutputableP class: class OutputableP a where pdoc :: Platform -> a -> SDoc With this class we still have some polymorphism as we have with `ppr` (i.e. we can use `pdoc` on a variety of types instead of having a dedicated `pprXXX` function for each XXX type). One step closer removing `sdocWithDynFlags` (#10143) and supporting several platforms (#14335). --- compiler/GHC/Driver/CodeOutput.hs | 13 +++++++------ compiler/GHC/Driver/Main.hs | 18 ++++++++++-------- 2 files changed, 17 insertions(+), 14 deletions(-) (limited to 'compiler/GHC/Driver') diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 841fa79d33..0e43b64c77 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -16,6 +16,7 @@ where #include "HsVersions.h" import GHC.Prelude +import GHC.Platform import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -260,8 +261,8 @@ outputForeignStubs_help fname doc_str header footer -- module; -- | Generate code to initialise cost centres -profilingInitCode :: Module -> CollectedCCs -> SDoc -profilingInitCode this_mod (local_CCs, singleton_CCSs) +profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc +profilingInitCode platform this_mod (local_CCs, singleton_CCSs) = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs @@ -278,22 +279,22 @@ profilingInitCode this_mod (local_CCs, singleton_CCSs) where emit_cc_decl cc = text "extern CostCentre" <+> cc_lbl <> text "[];" - where cc_lbl = ppr (mkCCLabel cc) + where cc_lbl = pdoc platform (mkCCLabel cc) local_cc_list_label = text "local_cc_" <> ppr this_mod emit_cc_list ccs = text "static CostCentre *" <> local_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma + <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi emit_ccs_decl ccs = text "extern CostCentreStack" <+> ccs_lbl <> text "[];" - where ccs_lbl = ppr (mkCCSLabel ccs) + where ccs_lbl = pdoc platform (mkCCSLabel ccs) singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod emit_ccs_list ccs = text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" - <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma + <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 90a07d7490..44babeec18 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1417,10 +1417,10 @@ hscGenHardCode hsc_env cgguts location output_filename = do <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let cost_centre_info = - (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + platform = targetPlatform dflags prof_init - | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info + | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info | otherwise = empty foreign_stubs = foreign_stubs0 `appendStubC` prof_init @@ -1446,7 +1446,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let dump a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a) + dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1494,9 +1494,10 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env home_unit = mkHomeUnitFromFlags dflags + platform = targetPlatform dflags cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1513,7 +1514,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" - FormatCMM (ppr cmmgroup) + FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] @@ -1556,6 +1557,7 @@ doCodeGen :: HscEnv -> Module -> [TyCon] doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds @@ -1575,7 +1577,7 @@ doCodeGen hsc_env this_mod data_tycons let dump1 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" FormatCMM (ppr a) + "Cmm produced by codegen" FormatCMM (pdoc platform a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream @@ -1591,7 +1593,7 @@ doCodeGen hsc_env this_mod data_tycons dump2 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) -- cgit v1.2.1