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, 25 insertions, 24 deletions

diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 2d8ec5f2b3..927003b16f 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -72,19 +72,20 @@ data DebugBlock =
   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
   }
 
-instance Outputable DebugBlock where
-  ppr blk = (if | dblProcedure blk == dblLabel blk
+instance OutputableP DebugBlock where
+  pdoc platform blk =
+            (if | dblProcedure blk == dblLabel blk
                 -> text "proc"
                 | dblHasInfoTbl blk
                 -> text "pp-blk"
                 | otherwise
                 -> text "blk") <+>
-            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
+            ppr (dblLabel blk) <+> parens (pdoc platform (dblCLabel blk)) <+>
             (maybe empty ppr (dblSourceTick blk)) <+>
             (maybe (text "removed") ((text "pos " <>) . ppr)
                    (dblPosition blk)) <+>
-            (ppr (dblUnwind blk)) $+$
-            (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))
+            (pdoc platform (dblUnwind blk)) $+$
+            (if null (dblBlocks blk) then empty else nest 4 (pdoc platform (dblBlocks blk)))
 
 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
@@ -489,12 +490,12 @@ LOC this information will end up in is Y.
 -- | A label associated with an 'UnwindTable'
 data UnwindPoint = UnwindPoint !CLabel !UnwindTable
 
-instance Outputable UnwindPoint where
-  ppr (UnwindPoint lbl uws) =
-      braces $ ppr lbl<>colon
+instance OutputableP UnwindPoint where
+  pdoc platform (UnwindPoint lbl uws) =
+      braces $ pdoc platform lbl <> colon
       <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
     where
-      pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+      pprUw (g, expr) = ppr g <> char '=' <> pdoc platform expr
 
 -- | Maps registers to expressions that yield their "old" values
 -- further up the stack. Most interesting for the stack pointer @Sp@,
@@ -513,19 +514,19 @@ data UnwindExpr = UwConst !Int                  -- ^ literal value
                 | UwTimes UnwindExpr UnwindExpr
                 deriving (Eq)
 
-instance Outputable UnwindExpr where
-  pprPrec _ (UwConst i)     = ppr i
-  pprPrec _ (UwReg g 0)     = ppr g
-  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
-  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e
-  pprPrec _ (UwLabel l)     = pprPrec 3 l
-  pprPrec p (UwPlus e0 e1)  | p <= 0
-                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
-  pprPrec p (UwMinus e0 e1) | p <= 0
-                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
-  pprPrec p (UwTimes e0 e1) | p <= 1
-                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
-  pprPrec _ other           = parens (pprPrec 0 other)
+instance OutputableP UnwindExpr where
+  pdocPrec _ _        (UwConst i)     = ppr i
+  pdocPrec _ _        (UwReg g 0)     = ppr g
+  pdocPrec p platform (UwReg g x)     = pdocPrec p platform (UwPlus (UwReg g 0) (UwConst x))
+  pdocPrec _ platform (UwDeref e)     = char '*' <> pdocPrec 3 platform e
+  pdocPrec _ platform (UwLabel l)     = pdocPrec 3 platform l
+  pdocPrec p platform (UwPlus e0 e1)  | p <= 0
+                                      = pdocPrec 0 platform e0 <> char '+' <> pdocPrec 0 platform e1
+  pdocPrec p platform (UwMinus e0 e1) | p <= 0
+                                      = pdocPrec 1 platform e0 <> char '-' <> pdocPrec 1 platform e1
+  pdocPrec p platform (UwTimes e0 e1) | p <= 1
+                                      = pdocPrec 2 platform e0 <> char '*' <> pdocPrec 2 platform e1
+  pdocPrec _ platform other           = parens (pdocPrec 0 platform other)
 
 -- | Conversion of Cmm expressions to unwind expressions. We check for
 -- unsupported operator usages and simplify the expression as far as
@@ -549,5 +550,5 @@ toUnwindExpr platform e@(CmmMachOp op [e1, e2])   =
     (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2
     _otherwise -> pprPanic "Unsupported operator in unwind expression!"
                            (pprExpr platform e)
-toUnwindExpr _ e
-  = pprPanic "Unsupported unwind expression!" (ppr e)
+toUnwindExpr platform e
+  = pprPanic "Unsupported unwind expression!" (pdoc platform e)