{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as (a superset of) C--
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
--
-- This is where we walk over CmmNode 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.
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs

module GHC.Cmm.Ppr
  ( module GHC.Cmm.Ppr.Decl
  , module GHC.Cmm.Ppr.Expr
  )
where

import GHC.Prelude hiding (succ)

import GHC.Platform
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Cmm.Ppr.Decl
import GHC.Cmm.Ppr.Expr
import GHC.Utils.Constants (debugIsOn)

import GHC.Types.Basic
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph

-------------------------------------------------
-- Outputable instances
instance OutputableP Platform InfoProvEnt where
  pdoc :: Platform -> InfoProvEnt -> SDoc
pdoc Platform
platform (InfoProvEnt CLabel
clabel ByteOff
_ String
_ Module
_ Maybe (RealSrcSpan, String)
_) = Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
clabel

instance Outputable CmmStackInfo where
    ppr :: CmmStackInfo -> SDoc
ppr = CmmStackInfo -> SDoc
pprStackInfo

instance OutputableP Platform CmmTopInfo where
    pdoc :: Platform -> CmmTopInfo -> SDoc
pdoc = Platform -> CmmTopInfo -> SDoc
pprTopInfo


instance OutputableP Platform (CmmNode e x) where
    pdoc :: Platform -> CmmNode e x -> SDoc
pdoc = Platform -> CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode

instance Outputable Convention where
    ppr :: Convention -> SDoc
ppr = Convention -> SDoc
pprConvention

instance Outputable ForeignConvention where
    ppr :: ForeignConvention -> SDoc
ppr = ForeignConvention -> SDoc
pprForeignConvention

instance OutputableP Platform ForeignTarget where
    pdoc :: Platform -> ForeignTarget -> SDoc
pdoc = Platform -> ForeignTarget -> SDoc
pprForeignTarget

instance Outputable CmmReturnInfo where
    ppr :: CmmReturnInfo -> SDoc
ppr = CmmReturnInfo -> SDoc
pprReturnInfo

instance OutputableP Platform (Block CmmNode C C) where
    pdoc :: Platform -> CmmBlock -> SDoc
pdoc = Platform -> CmmBlock -> IndexedCO C SDoc SDoc
Platform -> CmmBlock -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode C O) where
    pdoc :: Platform -> Block CmmNode C O -> SDoc
pdoc = Platform -> Block CmmNode C O -> IndexedCO C SDoc SDoc
Platform -> Block CmmNode C O -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O C) where
    pdoc :: Platform -> Block CmmNode O C -> SDoc
pdoc = Platform -> Block CmmNode O C -> IndexedCO O SDoc SDoc
Platform -> Block CmmNode O C -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance OutputableP Platform (Block CmmNode O O) where
    pdoc :: Platform -> Block CmmNode O O -> SDoc
pdoc = Platform -> Block CmmNode O O -> IndexedCO O SDoc SDoc
Platform -> Block CmmNode O O -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock

instance OutputableP Platform (Graph CmmNode e x) where
    pdoc :: Platform -> Graph CmmNode e x -> SDoc
pdoc = Platform -> Graph CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph

instance OutputableP Platform CmmGraph where
    pdoc :: Platform -> CmmGraph -> SDoc
pdoc = Platform -> CmmGraph -> SDoc
pprCmmGraph

----------------------------------------------------------
-- Outputting types Cmm contains

pprStackInfo :: CmmStackInfo -> SDoc
pprStackInfo :: CmmStackInfo -> SDoc
pprStackInfo (StackInfo {arg_space :: CmmStackInfo -> ByteOff
arg_space=ByteOff
arg_space}) =
  String -> SDoc
text String
"arg_space: " SDoc -> SDoc -> SDoc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
arg_space

pprTopInfo :: Platform -> CmmTopInfo -> SDoc
pprTopInfo :: Platform -> CmmTopInfo -> SDoc
pprTopInfo Platform
platform (TopInfo {info_tbls :: CmmTopInfo -> LabelMap CmmInfoTable
info_tbls=LabelMap CmmInfoTable
info_tbl, stack_info :: CmmTopInfo -> CmmStackInfo
stack_info=CmmStackInfo
stack_info}) =
  [SDoc] -> SDoc
vcat [String -> SDoc
text String
"info_tbls: " SDoc -> SDoc -> SDoc
<> Platform -> LabelMap CmmInfoTable -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform LabelMap CmmInfoTable
info_tbl,
        String -> SDoc
text String
"stack_info: " SDoc -> SDoc -> SDoc
<> CmmStackInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmStackInfo
stack_info]

----------------------------------------------------------
-- Outputting blocks and graphs

pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock :: forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock Platform
platform Block CmmNode e x
block
    = (CmmNode C O -> SDoc -> SDoc, CmmNode O O -> SDoc -> SDoc,
 CmmNode O C -> SDoc -> SDoc)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block CmmNode e x -> IndexedCO x SDoc SDoc -> IndexedCO e SDoc SDoc
forall (n :: Extensibility -> Extensibility -> *) a b c.
(n C O -> b -> c, n O O -> b -> b, n O C -> a -> b)
-> forall (e :: Extensibility) (x :: Extensibility).
   Block n e x -> IndexedCO x a b -> IndexedCO e c b
foldBlockNodesB3 ( SDoc -> SDoc -> SDoc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode C O -> SDoc) -> CmmNode C O -> SDoc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode C O -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       , SDoc -> SDoc -> SDoc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode O O -> SDoc) -> CmmNode O O -> SDoc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc) -> (CmmNode O O -> SDoc) -> CmmNode O O -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode O O -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       , SDoc -> SDoc -> SDoc
($$) (SDoc -> SDoc -> SDoc)
-> (CmmNode O C -> SDoc) -> CmmNode O C -> SDoc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteOff -> SDoc -> SDoc
nest ByteOff
4) (SDoc -> SDoc) -> (CmmNode O C -> SDoc) -> CmmNode O C -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmNode O C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
                       )
                       Block CmmNode e x
block
                       IndexedCO x SDoc SDoc
SDoc
empty

pprGraph :: Platform -> Graph CmmNode e x -> SDoc
pprGraph :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> Graph CmmNode e x -> SDoc
pprGraph Platform
platform = \case
   Graph CmmNode e x
GNil                  -> SDoc
empty
   GUnit Block CmmNode O O
block           -> Platform -> Block CmmNode O O -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode O O
block
   GMany MaybeO e (Block CmmNode O C)
entry Body' Block CmmNode
body MaybeO x (Block CmmNode C O)
exit ->
         String -> SDoc
text String
"{"
      SDoc -> SDoc -> SDoc
$$ ByteOff -> SDoc -> SDoc
nest ByteOff
2 (MaybeO e (Block CmmNode O C) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO e (Block CmmNode O C)
entry SDoc -> SDoc -> SDoc
$$ ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> SDoc) -> [CmmBlock] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmBlock -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) ([CmmBlock] -> [SDoc]) -> [CmmBlock] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Body' Block CmmNode -> [CmmBlock]
bodyToBlockList Body' Block CmmNode
body) SDoc -> SDoc -> SDoc
$$ MaybeO x (Block CmmNode C O) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO x (Block CmmNode C O)
exit)
      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"}"
      where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
                      => MaybeO ex (Block CmmNode e x) -> SDoc
            pprMaybeO :: forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
OutputableP Platform (Block CmmNode e x) =>
MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO ex (Block CmmNode e x)
NothingO = SDoc
empty
            pprMaybeO (JustO Block CmmNode e x
block) = Platform -> Block CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Block CmmNode e x
block

pprCmmGraph :: Platform -> CmmGraph -> SDoc
pprCmmGraph :: Platform -> CmmGraph -> SDoc
pprCmmGraph Platform
platform CmmGraph
g
   = String -> SDoc
text String
"{" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"offset"
  SDoc -> SDoc -> SDoc
$$ ByteOff -> SDoc -> SDoc
nest ByteOff
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> SDoc) -> [CmmBlock] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmBlock -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CmmBlock]
blocks)
  SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"}"
  where blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
revPostorder CmmGraph
g
    -- revPostorder has the side-effect of discarding unreachable code,
    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
    -- sometimes be confusing.

---------------------------------------------
-- Outputting CmmNode and types which it contains

pprConvention :: Convention -> SDoc
pprConvention :: Convention -> SDoc
pprConvention (NativeNodeCall   {}) = String -> SDoc
text String
"<native-node-call-convention>"
pprConvention (NativeDirectCall {}) = String -> SDoc
text String
"<native-direct-call-convention>"
pprConvention (NativeReturn {})     = String -> SDoc
text String
"<native-ret-convention>"
pprConvention  Convention
Slow                 = String -> SDoc
text String
"<slow-convention>"
pprConvention  Convention
GC                   = String -> SDoc
text String
"<gc-convention>"

pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention :: ForeignConvention -> SDoc
pprForeignConvention (ForeignConvention CCallConv
c [ForeignHint]
args [ForeignHint]
res CmmReturnInfo
ret) =
          SDoc -> SDoc
doubleQuotes (CCallConv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CCallConv
c) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"arg hints: " SDoc -> SDoc -> SDoc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
args SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
" result hints: " SDoc -> SDoc -> SDoc
<+> [ForeignHint] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ForeignHint]
res SDoc -> SDoc -> SDoc
<+> CmmReturnInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReturnInfo
ret

pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo :: CmmReturnInfo -> SDoc
pprReturnInfo CmmReturnInfo
CmmMayReturn = SDoc
empty
pprReturnInfo CmmReturnInfo
CmmNeverReturns = String -> SDoc
text String
"never returns"

pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget :: Platform -> ForeignTarget -> SDoc
pprForeignTarget Platform
platform (ForeignTarget CmmExpr
fn ForeignConvention
c) = ForeignConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr ForeignConvention
c SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
ppr_target CmmExpr
fn
  where
        ppr_target :: CmmExpr -> SDoc
        ppr_target :: CmmExpr -> SDoc
ppr_target t :: CmmExpr
t@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
t
        ppr_target CmmExpr
fn'          = SDoc -> SDoc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fn')

pprForeignTarget Platform
platform (PrimTarget CallishMachOp
op)
 -- HACK: We're just using a ForeignLabel to get this printed, the label
 --       might not really be foreign.
 = Platform -> CmmLit -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform
               (CLabel -> CmmLit
CmmLabel (FastString
-> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel
                         (String -> FastString
mkFastString (CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
op))
                         Maybe ByteOff
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction))

pprNode :: Platform -> CmmNode e x -> SDoc
pprNode :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprNode Platform
platform CmmNode e x
node = SDoc
pp_node SDoc -> SDoc -> SDoc
<+> SDoc
pp_debug
  where
    pp_node :: SDoc
    pp_node :: SDoc
pp_node = case CmmNode e x
node of
      -- label:
      CmmEntry Label
id CmmTickScope
tscope ->
         ((SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressUniques ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
            Bool
True  -> String -> SDoc
text String
"_lbl_"
            Bool
False -> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id
         )
         SDoc -> SDoc -> SDoc
<> SDoc
colon
         SDoc -> SDoc -> SDoc
<+> (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks (String -> SDoc
text String
"//" SDoc -> SDoc -> SDoc
<+> CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
tscope)

      -- // text
      CmmComment FastString
s -> String -> SDoc
text String
"//" SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext FastString
s

      -- //tick bla<...>
      CmmTick CmmTickish
t -> (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTicks
                     (String -> SDoc
text String
"//tick" SDoc -> SDoc -> SDoc
<+> CmmTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickish
t)

      -- unwind reg = expr;
      CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs ->
          String -> SDoc
text String
"unwind "
          SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
commafy (((GlobalReg, Maybe CmmExpr) -> SDoc)
-> [(GlobalReg, Maybe CmmExpr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(GlobalReg
r,Maybe CmmExpr
e) -> GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
r SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'=' SDoc -> SDoc -> SDoc
<+> Platform -> Maybe CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe CmmExpr
e) [(GlobalReg, Maybe CmmExpr)]
regs) SDoc -> SDoc -> SDoc
<> SDoc
semi

      -- reg = expr;
      CmmAssign CmmReg
reg CmmExpr
expr -> CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
<> SDoc
semi

      -- rep[lv] = expr;
      CmmStore CmmExpr
lv CmmExpr
expr AlignmentSpec
align -> SDoc
rep SDoc -> SDoc -> SDoc
<> SDoc
align_mark SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
lv) SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr SDoc -> SDoc -> SDoc
<> SDoc
semi
          where
            align_mark :: SDoc
align_mark = case AlignmentSpec
align of
                           AlignmentSpec
Unaligned -> String -> SDoc
text String
"^"
                           AlignmentSpec
NaturallyAligned -> SDoc
empty
            rep :: SDoc
rep = CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ( Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr )

      -- call "ccall" foo(x, y)[r1, r2];
      -- ToDo ppr volatile
      CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
results [CmmExpr]
args ->
          [SDoc] -> SDoc
hsep [ Bool -> SDoc -> SDoc
ppUnless ([CmmFormal] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CmmFormal]
results) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmFormal -> SDoc) -> [CmmFormal] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
results) SDoc -> SDoc -> SDoc
<+> SDoc
equals,
                 String -> SDoc
text String
"call",
                 Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
target SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CmmExpr]
args) SDoc -> SDoc -> SDoc
<> SDoc
semi]

      -- goto label;
      CmmBranch Label
ident -> String -> SDoc
text String
"goto" SDoc -> SDoc -> SDoc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
ident SDoc -> SDoc -> SDoc
<> SDoc
semi

      -- if (expr) goto t; else goto f;
      CmmCondBranch CmmExpr
expr Label
t Label
f Maybe Bool
l ->
          [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"if"
               , SDoc -> SDoc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
               , case Maybe Bool
l of
                   Maybe Bool
Nothing -> SDoc
empty
                   Just Bool
b -> SDoc -> SDoc
parens (String -> SDoc
text String
"likely:" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
b)
               , String -> SDoc
text String
"goto"
               , Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
t SDoc -> SDoc -> SDoc
<> SDoc
semi
               , String -> SDoc
text String
"else goto"
               , Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
f SDoc -> SDoc -> SDoc
<> SDoc
semi
               ]

      CmmSwitch CmmExpr
expr SwitchTargets
ids ->
          SDoc -> ByteOff -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"switch"
                     , SDoc
range
                     , if CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
expr
                       then Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr
                       else SDoc -> SDoc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
                     , String -> SDoc
text String
"{"
                     ])
             ByteOff
4 ([SDoc] -> SDoc
vcat ((([Integer], Label) -> SDoc) -> [([Integer], Label)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Integer], Label) -> SDoc
forall {a}. Outputable a => ([Integer], a) -> SDoc
ppCase [([Integer], Label)]
cases) SDoc -> SDoc -> SDoc
$$ SDoc
def) SDoc -> SDoc -> SDoc
$$ SDoc
rbrace
          where
            ([([Integer], Label)]
cases, Maybe Label
mbdef) = SwitchTargets -> ([([Integer], Label)], Maybe Label)
switchTargetsFallThrough SwitchTargets
ids
            ppCase :: ([Integer], a) -> SDoc
ppCase ([Integer]
is,a
l) = [SDoc] -> SDoc
hsep
                            [ String -> SDoc
text String
"case"
                            , [SDoc] -> SDoc
commafy ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Integer -> SDoc) -> [Integer] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> SDoc
integer [Integer]
is
                            , String -> SDoc
text String
": goto"
                            , a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
l SDoc -> SDoc -> SDoc
<> SDoc
semi
                            ]
            def :: SDoc
def | Just Label
l <- Maybe Label
mbdef = [SDoc] -> SDoc
hsep
                            [ String -> SDoc
text String
"default:"
                            , SDoc -> SDoc
braces (String -> SDoc
text String
"goto" SDoc -> SDoc -> SDoc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
l SDoc -> SDoc -> SDoc
<> SDoc
semi)
                            ]
                | Bool
otherwise = SDoc
empty

            range :: SDoc
range = SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [Integer -> SDoc
integer Integer
lo, String -> SDoc
text String
"..", Integer -> SDoc
integer Integer
hi]
              where (Integer
lo,Integer
hi) = SwitchTargets -> (Integer, Integer)
switchTargetsRange SwitchTargets
ids

      CmmCall CmmExpr
tgt Maybe Label
k [GlobalReg]
regs ByteOff
out ByteOff
res ByteOff
updfr_off ->
          [SDoc] -> SDoc
hcat [ String -> SDoc
text String
"call", SDoc
space
               , CmmExpr -> SDoc
pprFun CmmExpr
tgt, SDoc -> SDoc
parens ([GlobalReg] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [GlobalReg]
regs), SDoc
space
               , SDoc
returns SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text String
"args: " SDoc -> SDoc -> SDoc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
out SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text String
"res: " SDoc -> SDoc -> SDoc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
res SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
                 String -> SDoc
text String
"upd: " SDoc -> SDoc -> SDoc
<> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
updfr_off
               , SDoc
semi ]
          where pprFun :: CmmExpr -> SDoc
pprFun f :: CmmExpr
f@(CmmLit CmmLit
_) = Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f
                pprFun CmmExpr
f = SDoc -> SDoc
parens (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
f)

                returns :: SDoc
returns
                  | Just Label
r <- Maybe Label
k = String -> SDoc
text String
"returns to" SDoc -> SDoc -> SDoc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
r SDoc -> SDoc -> SDoc
<> SDoc
comma
                  | Bool
otherwise   = SDoc
empty

      CmmForeignCall {tgt :: CmmNode O C -> ForeignTarget
tgt=ForeignTarget
t, res :: CmmNode O C -> [CmmFormal]
res=[CmmFormal]
rs, args :: CmmNode O C -> [CmmExpr]
args=[CmmExpr]
as, succ :: CmmNode O C -> Label
succ=Label
s, ret_args :: CmmNode O C -> ByteOff
ret_args=ByteOff
a, ret_off :: CmmNode O C -> ByteOff
ret_off=ByteOff
u, intrbl :: CmmNode O C -> Bool
intrbl=Bool
i} ->
          [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
i then [String -> SDoc
text String
"interruptible", SDoc
space] else [] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
               [ String -> SDoc
text String
"foreign call", SDoc
space
               , Platform -> ForeignTarget -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
t, String -> SDoc
text String
"(...)", SDoc
space
               , String -> SDoc
text String
"returns to" SDoc -> SDoc -> SDoc
<+> Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
s
                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"args:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Platform -> [CmmExpr] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CmmExpr]
as)
                    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"ress:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens ([CmmFormal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
rs)
               , String -> SDoc
text String
"ret_args:" SDoc -> SDoc -> SDoc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
a
               , String -> SDoc
text String
"ret_off:" SDoc -> SDoc -> SDoc
<+> ByteOff -> SDoc
forall a. Outputable a => a -> SDoc
ppr ByteOff
u
               , SDoc
semi ]

    pp_debug :: SDoc
    pp_debug :: SDoc
pp_debug =
      if Bool -> Bool
not Bool
debugIsOn then SDoc
empty
      else case CmmNode e x
node of
             CmmEntry {}             -> SDoc
empty -- Looks terrible with text "  // CmmEntry"
             CmmComment {}           -> SDoc
empty -- Looks also terrible with text "  // CmmComment"
             CmmTick {}              -> SDoc
empty
             CmmUnwind {}            -> String -> SDoc
text String
"  // CmmUnwind"
             CmmAssign {}            -> String -> SDoc
text String
"  // CmmAssign"
             CmmStore {}             -> String -> SDoc
text String
"  // CmmStore"
             CmmUnsafeForeignCall {} -> String -> SDoc
text String
"  // CmmUnsafeForeignCall"
             CmmBranch {}            -> String -> SDoc
text String
"  // CmmBranch"
             CmmCondBranch {}        -> String -> SDoc
text String
"  // CmmCondBranch"
             CmmSwitch {}            -> String -> SDoc
text String
"  // CmmSwitch"
             CmmCall {}              -> String -> SDoc
text String
"  // CmmCall"
             CmmForeignCall {}       -> String -> SDoc
text String
"  // CmmForeignCall"

    commafy :: [SDoc] -> SDoc
    commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
xs