{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
{-# 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 PprCmm
  ( module PprCmmDecl
  , module PprCmmExpr
  )
where

import GhcPrelude hiding (succ)

import CLabel
import Cmm
import CmmUtils
import CmmSwitch
import DynFlags
import FastString
import Outputable
import PprCmmDecl
import PprCmmExpr
import Util

import BasicTypes
import Hoopl.Block
import Hoopl.Graph

-------------------------------------------------
-- Outputable instances

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

instance Outputable CmmTopInfo where
    ppr :: CmmTopInfo -> SDoc
ppr = CmmTopInfo -> SDoc
pprTopInfo


instance Outputable (CmmNode e x) where
    ppr :: CmmNode e x -> SDoc
ppr = CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
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 Outputable ForeignTarget where
    ppr :: ForeignTarget -> SDoc
ppr = ForeignTarget -> SDoc
pprForeignTarget

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

instance Outputable (Block CmmNode C C) where
    ppr :: Block CmmNode C C -> SDoc
ppr = Block CmmNode C C -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance Outputable (Block CmmNode C O) where
    ppr :: Block CmmNode C O -> SDoc
ppr = Block CmmNode C O -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance Outputable (Block CmmNode O C) where
    ppr :: Block CmmNode O C -> SDoc
ppr = Block CmmNode O C -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock
instance Outputable (Block CmmNode O O) where
    ppr :: Block CmmNode O O -> SDoc
ppr = Block CmmNode O O -> SDoc
forall (x :: Extensibility) (e :: Extensibility).
(IndexedCO x SDoc SDoc ~ SDoc) =>
Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock

instance Outputable (Graph CmmNode e x) where
    ppr :: Graph CmmNode e x -> SDoc
ppr = Graph CmmNode e x -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Graph CmmNode e x -> SDoc
pprGraph

instance Outputable CmmGraph where
    ppr :: CmmGraph -> SDoc
ppr = CmmGraph -> SDoc
pprCmmGraph

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

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

pprTopInfo :: CmmTopInfo -> SDoc
pprTopInfo :: CmmTopInfo -> SDoc
pprTopInfo (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
<> LabelMap CmmInfoTable -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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
         => Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock :: Block CmmNode e x -> IndexedCO e SDoc SDoc
pprBlock Block CmmNode e x
block
    = (CmmNode C O -> SDoc -> SDoc, CmmNode O O -> SDoc -> SDoc,
 CmmNode O C -> SDoc -> SDoc)
-> 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
. CmmNode C O -> SDoc
forall a. Outputable a => a -> SDoc
ppr
                       , 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
. CmmNode O O -> SDoc
forall a. Outputable a => a -> SDoc
ppr
                       , 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
. CmmNode O C -> SDoc
forall a. Outputable a => a -> SDoc
ppr
                       )
                       Block CmmNode e x
block
                       IndexedCO x SDoc SDoc
SDoc
empty

pprGraph :: Graph CmmNode e x -> SDoc
pprGraph :: Graph CmmNode e x -> SDoc
pprGraph Graph CmmNode e x
GNil = SDoc
empty
pprGraph (GUnit Block CmmNode O O
block) = Block CmmNode O O -> SDoc
forall a. Outputable a => a -> SDoc
ppr Block CmmNode O O
block
pprGraph (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).
Outputable (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
$ (Block CmmNode C C -> SDoc) -> [Block CmmNode C C] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Block CmmNode C C -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Block CmmNode C C] -> [SDoc]) -> [Block CmmNode C C] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Body' Block CmmNode -> [Block CmmNode C C]
bodyToBlockList Body' Block CmmNode
body) SDoc -> SDoc -> SDoc
$$ MaybeO x (Block CmmNode C O) -> SDoc
forall (e :: Extensibility) (x :: Extensibility)
       (ex :: Extensibility).
Outputable (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 :: Outputable (Block CmmNode e x)
                  => MaybeO ex (Block CmmNode e x) -> SDoc
        pprMaybeO :: MaybeO ex (Block CmmNode e x) -> SDoc
pprMaybeO MaybeO ex (Block CmmNode e x)
NothingO = SDoc
empty
        pprMaybeO (JustO Block CmmNode e x
block) = Block CmmNode e x -> SDoc
forall a. Outputable a => a -> SDoc
ppr Block CmmNode e x
block

pprCmmGraph :: CmmGraph -> SDoc
pprCmmGraph :: CmmGraph -> SDoc
pprCmmGraph 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
$ (Block CmmNode C C -> SDoc) -> [Block CmmNode C C] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Block CmmNode C C -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Block CmmNode C C]
blocks)
  SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"}"
  where blocks :: [Block CmmNode C C]
blocks = CmmGraph -> [Block CmmNode C C]
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 :: ForeignTarget -> SDoc
pprForeignTarget :: ForeignTarget -> SDoc
pprForeignTarget (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
_) = CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
t
        ppr_target CmmExpr
fn'          = SDoc -> SDoc
parens (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
fn')

pprForeignTarget (PrimTarget CallishMachOp
op)
 -- HACK: We're just using a ForeignLabel to get this printed, the label
 --       might not really be foreign.
 = CmmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr
               (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 :: CmmNode e x -> SDoc
pprNode :: CmmNode e x -> SDoc
pprNode CmmNode e x
node = SDoc
pp_node SDoc -> SDoc -> SDoc
<+> SDoc
pp_debug
  where
    pp_node :: SDoc
    pp_node :: SDoc
pp_node = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> case CmmNode e x
node of
      -- label:
      CmmEntry Label
id CmmTickScope
tscope -> SDoc
lbl SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+>
         ((DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
           Bool -> SDoc -> SDoc
ppUnless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTicks DynFlags
dflags) (String -> SDoc
text String
"//" SDoc -> SDoc -> SDoc
<+> CmmTickScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmTickScope
tscope))
          where
            lbl :: SDoc
lbl = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressUniques DynFlags
dflags
                then String -> SDoc
text String
"_lbl_"
                else Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr Label
id

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

      -- //tick bla<...>
      CmmTick CmmTickish
t -> Bool -> SDoc -> SDoc
ppUnless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTicks DynFlags
dflags) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                   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
<+> Maybe CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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
<+> CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
expr SDoc -> SDoc -> SDoc
<> SDoc
semi

      -- rep[lv] = expr;
      CmmStore CmmExpr
lv CmmExpr
expr -> SDoc
rep SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets(CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
lv) SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
expr SDoc -> SDoc -> SDoc
<> SDoc
semi
          where
            rep :: SDoc
rep = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                  CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr ( DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags 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 (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",
                 ForeignTarget -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [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(CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
expr
                       else SDoc -> SDoc
parens (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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
_) = CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
f
                pprFun CmmExpr
f = SDoc -> SDoc
parens (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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
               , ForeignTarget -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 ([CmmExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [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