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, 48 insertions, 56 deletions

diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index 94216a537b..b65cb9bd0b 100644
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -36,7 +36,7 @@
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module GHC.Cmm.Ppr.Decl
-    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
+    ( pprCmms, pprCmmGroup, pprSection, pprStatic
     )
 where
 
@@ -46,62 +46,54 @@ import GHC.Platform
 import GHC.Cmm.Ppr.Expr
 import GHC.Cmm
 
-import GHC.Driver.Ppr
-import GHC.Driver.Session
 import GHC.Utils.Outputable
 import GHC.Data.FastString
 
 import Data.List
-import System.IO
 
 import qualified Data.ByteString as BS
 
 
-pprCmms :: (Outputable info, Outputable g)
-        => [GenCmmGroup RawCmmStatics info g] -> SDoc
-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+pprCmms :: (OutputableP info, OutputableP g)
+        => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
         where
           separator = space $$ text "-------------------" $$ space
 
-writeCmms :: (Outputable info, Outputable g)
-          => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
-writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
-
 -----------------------------------------------------------------------------
 
-instance (Outputable d, Outputable info, Outputable i)
-      => Outputable (GenCmmDecl d info i) where
-    ppr t = pprTop t
+instance (OutputableP d, OutputableP info, OutputableP i)
+      => OutputableP (GenCmmDecl d info i) where
+    pdoc = pprTop
 
-instance Outputable (GenCmmStatics a) where
-    ppr = pprStatics
+instance OutputableP (GenCmmStatics a) where
+    pdoc = pprStatics
 
-instance Outputable CmmStatic where
-    ppr e = sdocWithDynFlags $ \dflags ->
-            pprStatic (targetPlatform dflags) e
+instance OutputableP CmmStatic where
+    pdoc = pprStatic
 
-instance Outputable CmmInfoTable where
-    ppr = pprInfoTable
+instance OutputableP CmmInfoTable where
+    pdoc = pprInfoTable
 
 
 -----------------------------------------------------------------------------
 
-pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
-            => GenCmmGroup d info g -> SDoc
-pprCmmGroup tops
-    = vcat $ intersperse blankLine $ map pprTop tops
+pprCmmGroup :: (OutputableP d, OutputableP info, OutputableP g)
+            => Platform -> GenCmmGroup d info g -> SDoc
+pprCmmGroup platform tops
+    = vcat $ intersperse blankLine $ map (pprTop platform) tops
 
 -- --------------------------------------------------------------------------
 -- Top level `procedure' blocks.
 --
-pprTop :: (Outputable d, Outputable info, Outputable i)
-       => GenCmmDecl d info i -> SDoc
+pprTop :: (OutputableP d, OutputableP info, OutputableP i)
+       => Platform -> GenCmmDecl d info i -> SDoc
 
-pprTop (CmmProc info lbl live graph)
+pprTop platform (CmmProc info lbl live graph)
 
-  = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
-         , nest 8 $ lbrace <+> ppr info $$ rbrace
-         , nest 4 $ ppr graph
+  = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
+         , nest 8 $ lbrace <+> pdoc platform info $$ rbrace
+         , nest 4 $ pdoc platform graph
          , rbrace ]
 
 -- --------------------------------------------------------------------------
@@ -109,25 +101,25 @@ pprTop (CmmProc info lbl live graph)
 --
 --      section "data" { ... }
 --
-pprTop (CmmData section ds) =
-    (hang (pprSection section <+> lbrace) 4 (ppr ds))
+pprTop platform (CmmData section ds) =
+    (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))
     $$ rbrace
 
 -- --------------------------------------------------------------------------
 -- Info tables.
 
-pprInfoTable :: CmmInfoTable -> SDoc
-pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+pprInfoTable :: Platform -> CmmInfoTable -> SDoc
+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
                            , cit_prof = prof_info
                            , cit_srt = srt })
-  = vcat [ text "label: " <> ppr lbl
+  = vcat [ text "label: " <> pdoc platform lbl
          , text "rep: " <> ppr rep
          , case prof_info of
              NoProfilingInfo -> empty
              ProfilingInfo ct cd ->
                vcat [ text "type: " <> text (show (BS.unpack ct))
                     , text "desc: " <> text (show (BS.unpack cd)) ]
-         , text "srt: " <> ppr srt ]
+         , text "srt: " <> pdoc platform srt ]
 
 instance Outputable ForeignHint where
   ppr NoHint     = empty
@@ -142,10 +134,10 @@ instance Outputable ForeignHint where
 --      following C--
 --
 
-pprStatics :: GenCmmStatics a -> SDoc
-pprStatics (CmmStatics lbl itbl ccs payload) =
-  ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload
-pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+pprStatics :: Platform -> GenCmmStatics a -> SDoc
+pprStatics platform (CmmStatics lbl itbl ccs payload) =
+  pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload
+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)
 
 pprStatic :: Platform -> CmmStatic -> SDoc
 pprStatic platform s = case s of
@@ -157,9 +149,9 @@ pprStatic platform s = case s of
 -- --------------------------------------------------------------------------
 -- data sections
 --
-pprSection :: Section -> SDoc
-pprSection (Section t suffix) =
-  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
+pprSection :: Platform -> Section -> SDoc
+pprSection platform (Section t suffix) =
+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)
   where
     section = text "section"
 
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index 4bb8021541..5b1d01b00a 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -41,7 +41,6 @@ where
 
 import GHC.Prelude
 
-import GHC.Driver.Session (targetPlatform)
 import GHC.Driver.Ppr
 
 import GHC.Platform
@@ -54,16 +53,14 @@ import Numeric ( fromRat )
 
 -----------------------------------------------------------------------------
 
-instance Outputable CmmExpr where
-    ppr e = sdocWithDynFlags $ \dflags ->
-            pprExpr (targetPlatform dflags) e
+instance OutputableP CmmExpr where
+    pdoc = pprExpr
 
 instance Outputable CmmReg where
     ppr e = pprReg e
 
-instance Outputable CmmLit where
-    ppr l = sdocWithDynFlags $ \dflags ->
-            pprLit (targetPlatform dflags) l
+instance OutputableP CmmLit where
+    pdoc = pprLit
 
 instance Outputable LocalReg where
     ppr e = pprLocalReg e
@@ -74,6 +71,9 @@ instance Outputable Area where
 instance Outputable GlobalReg where
     ppr e = pprGlobalReg e
 
+instance OutputableP GlobalReg where
+    pdoc _ = ppr
+
 -- --------------------------------------------------------------------------
 -- Expressions
 --
@@ -147,7 +147,7 @@ pprExpr9 :: Platform -> CmmExpr -> SDoc
 pprExpr9 platform e =
    case e of
         CmmLit    lit       -> pprLit1 platform lit
-        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)
+        CmmLoad   expr rep  -> ppr rep <> brackets (pdoc platform expr)
         CmmReg    reg       -> ppr reg
         CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
         CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
@@ -204,10 +204,10 @@ pprLit platform lit = case lit of
 
     CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]
     CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
-    CmmLabel clbl      -> ppr clbl
-    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
-    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
-                                  <> ppr clbl2 <> ppr_offset i
+    CmmLabel clbl      -> pdoc platform clbl
+    CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i
+    CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'
+                                       <> pdoc platform clbl2 <> ppr_offset i
     CmmBlock id        -> ppr id
     CmmHighStackMark -> text "<highSp>"