cmm: Eliminate orphan Outputable instances

Here we reorganize `GHC.Cmm` to eliminate the orphan `Outputable` and
`OutputableP` instances for the Cmm AST. This makes it significantly
easier to use the Cmm pretty-printers in tracing output without
incurring module import cycles.

1 files changed, 177 insertions, 2 deletions

diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index 4f8bdbd77a..797940c5a2 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -6,13 +6,13 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-
+{-# LANGUAGE FlexibleContexts #-}
 
 module GHC.Cmm (
      -- * Cmm top-level datatypes
      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
      CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
-     CmmGraph, GenCmmGraph(..),
+     CmmGraph, GenCmmGraph(..), toBlockMap, revPostorder,
      CmmBlock, RawCmmDecl,
      Section(..), SectionType(..),
      GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
@@ -30,10 +30,14 @@ module GHC.Cmm (
      -- * Statements, expressions and types
      module GHC.Cmm.Node,
      module GHC.Cmm.Expr,
+
+     -- * Pretty-printing
+     pprCmms, pprCmmGroup, pprSection, pprStatic
   ) where
 
 import GHC.Prelude
 
+import GHC.Platform
 import GHC.Types.Id
 import GHC.Types.CostCentre
 import GHC.Cmm.CLabel
@@ -46,7 +50,10 @@ import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 import GHC.Utils.Outputable
+
+import Data.List (intersperse)
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
 
 -----------------------------------------------------------------------------
 --  Cmm, GenCmm
@@ -102,6 +109,10 @@ data GenCmmDecl d h g
 
   deriving (Functor)
 
+instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
+      => OutputableP Platform (GenCmmDecl d info i) where
+    pdoc = pprTop
+
 type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph
 type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
 
@@ -119,6 +130,26 @@ type CmmGraph = GenCmmGraph CmmNode
 data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
 type CmmBlock = Block CmmNode C C
 
+instance OutputableP Platform CmmGraph where
+    pdoc = pprCmmGraph
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+
+pprCmmGraph :: Platform -> CmmGraph -> SDoc
+pprCmmGraph platform g
+   = text "{" <> text "offset"
+  $$ nest 2 (vcat $ map (pdoc platform) blocks)
+  $$ text "}"
+  where blocks = revPostorder g
+    -- revPostorder has the side-effect of discarding unreachable code,
+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
+    -- sometimes be confusing.
+
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+    revPostorderFrom (toBlockMap g) (g_entry g)
+
 -----------------------------------------------------------------------------
 --     Info Tables
 -----------------------------------------------------------------------------
@@ -128,6 +159,14 @@ type CmmBlock = Block CmmNode C C
 data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable
                             , stack_info :: CmmStackInfo }
 
+instance OutputableP Platform CmmTopInfo where
+    pdoc = pprTopInfo
+
+pprTopInfo :: Platform -> CmmTopInfo -> SDoc
+pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+  vcat [text "info_tbls: " <> pdoc platform info_tbl,
+        text "stack_info: " <> ppr stack_info]
+
 topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
 topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
 topInfoTable _                     = Nothing
@@ -145,6 +184,13 @@ data CmmStackInfo
                -- we want to do the stack manipulation manually.
   }
 
+instance Outputable CmmStackInfo where
+    ppr = pprStackInfo
+
+pprStackInfo :: CmmStackInfo -> SDoc
+pprStackInfo (StackInfo {arg_space=arg_space}) =
+  text "arg_space: " <> ppr arg_space
+
 -- | Info table as a haskell data type
 data CmmInfoTable
   = CmmInfoTable {
@@ -169,6 +215,10 @@ data CmmInfoTable
         -- GHC.Cmm.Info.Build.doSRTs.
     } deriving Eq
 
+instance OutputableP Platform CmmInfoTable where
+    pdoc = pprInfoTable
+
+
 data ProfilingInfo
   = NoProfilingInfo
   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
@@ -233,6 +283,9 @@ data CmmStatic
   | CmmFileEmbed FilePath
         -- ^ an embedded binary file
 
+instance OutputableP Platform CmmStatic where
+    pdoc = pprStatic
+
 instance Outputable CmmStatic where
   ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit
   ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n
@@ -254,6 +307,9 @@ data GenCmmStatics (rawOnly :: Bool) where
       -> [CmmStatic]  -- The static data itself
       -> GenCmmStatics a
 
+instance OutputableP Platform (GenCmmStatics a) where
+    pdoc = pprStatics
+
 type CmmStatics    = GenCmmStatics 'False
 type RawCmmStatics = GenCmmStatics 'True
 
@@ -293,3 +349,122 @@ instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where
 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 pprBBlock (BasicBlock ident stmts) =
     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
+
+-- --------------------------------------------------------------------------
+-- Pretty-printing Cmm
+-- --------------------------------------------------------------------------
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+
+pprCmms :: (OutputableP Platform info, OutputableP Platform g)
+        => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
+        where
+          separator = space $$ text "-------------------" $$ space
+
+pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)
+            => Platform -> GenCmmGroup d info g -> SDoc
+pprCmmGroup platform tops
+    = vcat $ intersperse blankLine $ map (pprTop platform) tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+
+pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
+       => Platform -> GenCmmDecl d info i -> SDoc
+
+pprTop platform (CmmProc info lbl live graph)
+
+  = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
+         , nest 8 $ lbrace <+> pdoc platform info $$ rbrace
+         , nest 4 $ pdoc platform graph
+         , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+--      section "data" { ... }
+--
+
+pprTop platform (CmmData section ds) =
+    (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))
+    $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Pretty-printing info tables
+-- --------------------------------------------------------------------------
+
+pprInfoTable :: Platform -> CmmInfoTable -> SDoc
+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+                           , cit_prof = prof_info
+                           , cit_srt = srt })
+  = 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: " <> pdoc platform srt ]
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+
+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
+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pdoc platform lit <> semi
+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
+    CmmFileEmbed path  -> nest 4 $ text "incbin " <+> text (show path)
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Platform -> Section -> SDoc
+pprSection platform (Section t suffix) =
+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)
+  where
+    section = text "section"
+
+pprSectionType :: SectionType -> SDoc
+pprSectionType s = doubleQuotes $ case s of
+  Text                    -> text "text"
+  Data                    -> text "data"
+  ReadOnlyData            -> text "readonly"
+  ReadOnlyData16          -> text "readonly16"
+  RelocatableReadOnlyData -> text "relreadonly"
+  UninitialisedData       -> text "uninitialised"
+  InitArray               -> text "initarray"
+  FiniArray               -> text "finiarray"
+  CString                 -> text "cstring"
+  OtherSection s'         -> text s'