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).

2 files changed, 17 insertions, 14 deletions

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)