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

1 files changed, 12 insertions, 10 deletions

diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 4f19085ac9..108df2b600 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -150,7 +150,7 @@ nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqS
 nativeCodeGen dflags this_mod modLoc h us cmms
  = let config   = initNCGConfig dflags
        platform = ncgPlatform config
-       nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr)
+       nCG' :: ( OutputableP statics, Outputable jumpDest, Instruction instr)
             => NcgImpl statics instr jumpDest -> IO a
        nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms
    in case platformArch platform of
@@ -214,7 +214,7 @@ unwinding table).
 See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
 -}
 
-nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr)
+nativeCodeGen' :: (OutputableP statics, Outputable jumpDest, Instruction instr)
                => DynFlags
                -> NCGConfig
                -> Module -> ModLocation
@@ -293,7 +293,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs
                    (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
                    FormatText
 
-cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr)
+cmmNativeGenStream :: (OutputableP statics, Outputable jumpDest, Instruction instr)
               => DynFlags
               -> NCGConfig
               -> Module -> ModLocation
@@ -332,9 +332,10 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
               -- Link native code information into debug blocks
               -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
+                  platform = targetPlatform dflags
               unless (null ldbgs) $
                 dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
-                  (vcat $ map ppr ldbgs)
+                  (vcat $ map (pdoc platform) ldbgs)
 
               -- Accumulate debug information for emission in finishNativeGen.
               let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
@@ -348,7 +349,7 @@ cmmNativeGenStream dflags config this_mod modLoc ncgImpl h us cmm_stream ngs
 -- | Do native code generation on all these cmms.
 --
 cmmNativeGens :: forall statics instr jumpDest.
-                 (Outputable statics, Outputable jumpDest, Instruction instr)
+                 (OutputableP statics, Outputable jumpDest, Instruction instr)
               => DynFlags
               -> NCGConfig
               -> Module -> ModLocation
@@ -391,7 +392,8 @@ cmmNativeGens dflags config this_mod modLoc ncgImpl h dbgMap = go
           map (pprNatCmmDecl ncgImpl) native
 
         -- force evaluation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()
+        let platform = targetPlatform dflags
+        {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) ()
 
         let !labels' = if ncgDwarfEnabled config
                        then cmmDebugLabels isMetaInstr native else []
@@ -425,7 +427,7 @@ emitNativeCode dflags config h sdoc = do
 --      Dumping the output of each stage along the way.
 --      Global conflict graph and NGC stats
 cmmNativeGen
-    :: forall statics instr jumpDest. (Instruction instr, Outputable statics, Outputable jumpDest)
+    :: forall statics instr jumpDest. (Instruction instr, OutputableP statics, Outputable jumpDest)
     => DynFlags
     -> Module -> ModLocation
     -> NcgImpl statics instr jumpDest
@@ -450,7 +452,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
         let weights  = ncgCfgWeights config
 
         let proc_name = case cmm of
-                (CmmProc _ entry_label _ _) -> ppr entry_label
+                (CmmProc _ entry_label _ _) -> pdoc platform entry_label
                 _                           -> text "DataChunk"
 
         -- rewrite assignments to global regs
@@ -465,10 +467,10 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
-                (pprCmmGroup [opt_cmm])
+                (pprCmmGroup platform [opt_cmm])
 
         let cmmCfg = {-# SCC "getCFG" #-}
-                     getCfgProc weights opt_cmm
+                     getCfgProc platform weights opt_cmm
 
         -- generate native code from cmm
         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =