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, 219 insertions, 0 deletions

diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index 841c726b14..117ed9747a 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
@@ -28,6 +29,7 @@ module GHC.Cmm.Node (
 import GHC.Prelude hiding (succ)
 
 import GHC.Platform.Regs
+import GHC.Cmm.CLabel
 import GHC.Cmm.Expr
 import GHC.Cmm.Switch
 import GHC.Data.FastString
@@ -36,7 +38,9 @@ import GHC.Utils.Outputable
 import GHC.Runtime.Heap.Layout
 import GHC.Types.Tickish (CmmTickish)
 import qualified GHC.Types.Unique as U
+import GHC.Types.Basic (FunctionOrData(..))
 
+import GHC.Platform
 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Collections
@@ -44,6 +48,7 @@ import GHC.Cmm.Dataflow.Label
 import Data.Maybe
 import Data.List (tails,sortBy)
 import GHC.Types.Unique (nonDetCmpUnique)
+import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Misc
 
 
@@ -165,6 +170,177 @@ data CmmNode e x where
       intrbl:: Bool             -- whether or not the call is interruptible
   } -> CmmNode O C
 
+instance OutputableP Platform (CmmNode e x) where
+    pdoc = pprNode
+
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
+  where
+    pp_node :: SDoc
+    pp_node = case node of
+      -- label:
+      CmmEntry id tscope ->
+         (sdocOption sdocSuppressUniques $ \case
+            True  -> text "_lbl_"
+            False -> ppr id
+         )
+         <> colon
+         <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
+
+      -- // text
+      CmmComment s -> text "//" <+> ftext s
+
+      -- //tick bla<...>
+      CmmTick t -> ppUnlessOption sdocSuppressTicks
+                     (text "//tick" <+> ppr t)
+
+      -- unwind reg = expr;
+      CmmUnwind regs ->
+          text "unwind "
+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi
+
+      -- reg = expr;
+      CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi
+
+      -- rep[lv] = expr;
+      CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
+          where
+            align_mark = case align of
+                           Unaligned -> text "^"
+                           NaturallyAligned -> empty
+            rep = ppr ( cmmExprType platform expr )
+
+      -- call "ccall" foo(x, y)[r1, r2];
+      -- ToDo ppr volatile
+      CmmUnsafeForeignCall target results args ->
+          hsep [ ppUnless (null results) $
+                    parens (commafy $ map ppr results) <+> equals,
+                 text "call",
+                 pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]
+
+      -- goto label;
+      CmmBranch ident -> text "goto" <+> ppr ident <> semi
+
+      -- if (expr) goto t; else goto f;
+      CmmCondBranch expr t f l ->
+          hsep [ text "if"
+               , parens (pdoc platform expr)
+               , case l of
+                   Nothing -> empty
+                   Just b -> parens (text "likely:" <+> ppr b)
+               , text "goto"
+               , ppr t <> semi
+               , text "else goto"
+               , ppr f <> semi
+               ]
+
+      CmmSwitch expr ids ->
+          hang (hsep [ text "switch"
+                     , range
+                     , if isTrivialCmmExpr expr
+                       then pdoc platform expr
+                       else parens (pdoc platform expr)
+                     , text "{"
+                     ])
+             4 (vcat (map ppCase cases) $$ def) $$ rbrace
+          where
+            (cases, mbdef) = switchTargetsFallThrough ids
+            ppCase (is,l) = hsep
+                            [ text "case"
+                            , commafy $ map integer is
+                            , text ": goto"
+                            , ppr l <> semi
+                            ]
+            def | Just l <- mbdef = hsep
+                            [ text "default:"
+                            , braces (text "goto" <+> ppr l <> semi)
+                            ]
+                | otherwise = empty
+
+            range = brackets $ hsep [integer lo, text "..", integer hi]
+              where (lo,hi) = switchTargetsRange ids
+
+      CmmCall tgt k regs out res updfr_off ->
+          hcat [ text "call", space
+               , pprFun tgt, parens (interpp'SP regs), space
+               , returns <+>
+                 text "args: " <> ppr out <> comma <+>
+                 text "res: " <> ppr res <> comma <+>
+                 text "upd: " <> ppr updfr_off
+               , semi ]
+          where pprFun f@(CmmLit _) = pdoc platform f
+                pprFun f = parens (pdoc platform f)
+
+                returns
+                  | Just r <- k = text "returns to" <+> ppr r <> comma
+                  | otherwise   = empty
+
+      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+          hcat $ if i then [text "interruptible", space] else [] ++
+               [ text "foreign call", space
+               , pdoc platform t, text "(...)", space
+               , text "returns to" <+> ppr s
+                    <+> text "args:" <+> parens (pdoc platform as)
+                    <+> text "ress:" <+> parens (ppr rs)
+               , text "ret_args:" <+> ppr a
+               , text "ret_off:" <+> ppr u
+               , semi ]
+
+    pp_debug :: SDoc
+    pp_debug =
+      if not debugIsOn then empty
+      else case node of
+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
+             CmmTick {}              -> empty
+             CmmUnwind {}            -> text "  // CmmUnwind"
+             CmmAssign {}            -> text "  // CmmAssign"
+             CmmStore {}             -> text "  // CmmStore"
+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
+             CmmBranch {}            -> text "  // CmmBranch"
+             CmmCondBranch {}        -> text "  // CmmCondBranch"
+             CmmSwitch {}            -> text "  // CmmSwitch"
+             CmmCall {}              -> text "  // CmmCall"
+             CmmForeignCall {}       -> text "  // CmmForeignCall"
+
+    commafy :: [SDoc] -> SDoc
+    commafy xs = hsep $ punctuate comma xs
+
+instance OutputableP Platform (Block CmmNode C C) where
+    pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode C O) where
+    pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode O C) where
+    pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode O O) where
+    pdoc = pprBlock
+
+instance OutputableP Platform (Graph CmmNode e x) where
+    pdoc = pprGraph
+
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock platform block
+    = foldBlockNodesB3 ( ($$) . pdoc platform
+                       , ($$) . (nest 4) . pdoc platform
+                       , ($$) . (nest 4) . pdoc platform
+                       )
+                       block
+                       empty
+
+pprGraph :: Platform -> Graph CmmNode e x -> SDoc
+pprGraph platform = \case
+   GNil                  -> empty
+   GUnit block           -> pdoc platform block
+   GMany entry body exit ->
+         text "{"
+      $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)
+      $$ text "}"
+      where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
+                      => MaybeO ex (Block CmmNode e x) -> SDoc
+            pprMaybeO NothingO = empty
+            pprMaybeO (JustO block) = pdoc platform block
+
 {- Note [Foreign calls]
 ~~~~~~~~~~~~~~~~~~~~~~~
 A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
@@ -291,11 +467,25 @@ data ForeignConvention
         CmmReturnInfo
   deriving Eq
 
+instance Outputable ForeignConvention where
+    ppr = pprForeignConvention
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+    doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
 data CmmReturnInfo
   = CmmMayReturn
   | CmmNeverReturns
   deriving ( Eq )
 
+instance Outputable CmmReturnInfo where
+    ppr = pprReturnInfo
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
 data ForeignTarget        -- The target of a foreign call
   = ForeignTarget                -- A foreign procedure
         CmmExpr                  -- Its address
@@ -304,6 +494,35 @@ data ForeignTarget        -- The target of a foreign call
         CallishMachOp            -- Which one
   deriving Eq
 
+instance OutputableP Platform ForeignTarget where
+    pdoc = pprForeignTarget
+
+pprForeignTarget :: Platform -> ForeignTarget -> SDoc
+pprForeignTarget platform (ForeignTarget fn c) =
+    ppr c <+> ppr_target fn
+  where
+    ppr_target :: CmmExpr -> SDoc
+    ppr_target t@(CmmLit _) = pdoc platform t
+    ppr_target fn'          = parens (pdoc platform fn')
+pprForeignTarget platform (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ --       might not really be foreign.
+ = pdoc platform
+               (CmmLabel (mkForeignLabel
+                          (mkFastString (show op))
+                          Nothing ForeignLabelInThisPackage IsFunction))
+
+instance Outputable Convention where
+  ppr = pprConvention
+
+pprConvention :: Convention -> SDoc
+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {})     = text "<native-ret-convention>"
+pprConvention  Slow                 = text "<slow-convention>"
+pprConvention  GC                   = text "<gc-convention>"
+
+
 foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
 foreignTargetHints target
   = ( res_hints ++ repeat NoHint