compiler/cmm/PprCmm.hs

   1 {-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 ----------------------------------------------------------------------------
   5 --
   6 -- Pretty-printing of Cmm as (a superset of) C--
   7 --
   8 -- (c) The University of Glasgow 2004-2006
   9 --
  10 -----------------------------------------------------------------------------
  11 --
  12 -- This is where we walk over CmmNode emitting an external representation,
  13 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
  14 -- is the "External Core" for the Cmm layer.
  15 --
  16 -- As such, this should be a well-defined syntax: we want it to look nice.
  17 -- Thus, we try wherever possible to use syntax defined in [1],
  18 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
  19 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
  20 -- than C--'s bits8 .. bits64.
  21 --
  22 -- We try to ensure that all information available in the abstract
  23 -- syntax is reproduced, or reproducible, in the concrete syntax.
  24 -- Data that is not in printed out can be reconstructed according to
  25 -- conventions used in the pretty printer. There are at least two such
  26 -- cases:
  27 --      1) if a value has wordRep type, the type is not appended in the
  28 --      output.
  29 --      2) MachOps that operate over wordRep type are printed in a
  30 --      C-style, rather than as their internal MachRep name.
  31 --
  32 -- These conventions produce much more readable Cmm output.
  33 --
  34 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
  35
  36 module PprCmm
  37   ( module PprCmmDecl
  38   , module PprCmmExpr
  39   )
  40 where
  41
  42 import BlockId ()
  43 import CLabel
  44 import Cmm
  45 import CmmUtils
  46 import CmmSwitch
  47 import DynFlags
  48 import FastString
  49 import Outputable
  50 import PprCmmDecl
  51 import PprCmmExpr
  52 import Util
  53 import PprCore ()
  54
  55 import BasicTypes
  56 import Hoopl.Block
  57 import Hoopl.Graph
  58 import Data.List
  59 import Prelude hiding (succ)
  60
  61 -------------------------------------------------
  62 -- Outputable instances
  63
  64 instance Outputable CmmStackInfo where
  65     ppr = pprStackInfo
  66
  67 instance Outputable CmmTopInfo where
  68     ppr = pprTopInfo
  69
  70
  71 instance Outputable (CmmNode e x) where
  72     ppr = pprNode
  73
  74 instance Outputable Convention where
  75     ppr = pprConvention
  76
  77 instance Outputable ForeignConvention where
  78     ppr = pprForeignConvention
  79
  80 instance Outputable ForeignTarget where
  81     ppr = pprForeignTarget
  82
  83 instance Outputable CmmReturnInfo where
  84     ppr = pprReturnInfo
  85
  86 instance Outputable (Block CmmNode C C) where
  87     ppr = pprBlock
  88 instance Outputable (Block CmmNode C O) where
  89     ppr = pprBlock
  90 instance Outputable (Block CmmNode O C) where
  91     ppr = pprBlock
  92 instance Outputable (Block CmmNode O O) where
  93     ppr = pprBlock
  94
  95 instance Outputable (Graph CmmNode e x) where
  96     ppr = pprGraph
  97
  98 instance Outputable CmmGraph where
  99     ppr = pprCmmGraph
 100
 101 ----------------------------------------------------------
 102 -- Outputting types Cmm contains
 103
 104 pprStackInfo :: CmmStackInfo -> SDoc
 105 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
 106   text "arg_space: " <> ppr arg_space <+>
 107   text "updfr_space: " <> ppr updfr_space
 108
 109 pprTopInfo :: CmmTopInfo -> SDoc
 110 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
 111   vcat [text "info_tbl: " <> ppr info_tbl,
 112         text "stack_info: " <> ppr stack_info]
 113
 114 ----------------------------------------------------------
 115 -- Outputting blocks and graphs
 116
 117 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
 118          => Block CmmNode e x -> IndexedCO e SDoc SDoc
 119 pprBlock block
 120     = foldBlockNodesB3 ( ($$) . ppr
 121                        , ($$) . (nest 4) . ppr
 122                        , ($$) . (nest 4) . ppr
 123                        )
 124                        block
 125                        empty
 126
 127 pprGraph :: Graph CmmNode e x -> SDoc
 128 pprGraph GNil = empty
 129 pprGraph (GUnit block) = ppr block
 130 pprGraph (GMany entry body exit)
 131    = text "{"
 132   $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
 133   $$ text "}"
 134   where pprMaybeO :: Outputable (Block CmmNode e x)
 135                   => MaybeO ex (Block CmmNode e x) -> SDoc
 136         pprMaybeO NothingO = empty
 137         pprMaybeO (JustO block) = ppr block
 138
 139 pprCmmGraph :: CmmGraph -> SDoc
 140 pprCmmGraph g
 141    = text "{" <> text "offset"
 142   $$ nest 2 (vcat $ map ppr blocks)
 143   $$ text "}"
 144   where blocks = postorderDfs g
 145     -- postorderDfs has the side-effect of discarding unreachable code,
 146     -- so pretty-printed Cmm will omit any unreachable blocks.  This can
 147     -- sometimes be confusing.
 148
 149 ---------------------------------------------
 150 -- Outputting CmmNode and types which it contains
 151
 152 pprConvention :: Convention -> SDoc
 153 pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
 154 pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
 155 pprConvention (NativeReturn {})     = text "<native-ret-convention>"
 156 pprConvention  Slow                 = text "<slow-convention>"
 157 pprConvention  GC                   = text "<gc-convention>"
 158
 159 pprForeignConvention :: ForeignConvention -> SDoc
 160 pprForeignConvention (ForeignConvention c args res ret) =
 161           doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
 162
 163 pprReturnInfo :: CmmReturnInfo -> SDoc
 164 pprReturnInfo CmmMayReturn = empty
 165 pprReturnInfo CmmNeverReturns = text "never returns"
 166
 167 pprForeignTarget :: ForeignTarget -> SDoc
 168 pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
 169   where
 170         ppr_target :: CmmExpr -> SDoc
 171         ppr_target t@(CmmLit _) = ppr t
 172         ppr_target fn'          = parens (ppr fn')
 173
 174 pprForeignTarget (PrimTarget op)
 175  -- HACK: We're just using a ForeignLabel to get this printed, the label
 176  --       might not really be foreign.
 177  = ppr
 178                (CmmLabel (mkForeignLabel
 179                          (mkFastString (show op))
 180                          Nothing ForeignLabelInThisPackage IsFunction))
 181
 182 pprNode :: CmmNode e x -> SDoc
 183 pprNode node = pp_node <+> pp_debug
 184   where
 185     pp_node :: SDoc
 186     pp_node = sdocWithDynFlags $ \dflags -> case node of
 187       -- label:
 188       CmmEntry id tscope -> ppr id <> colon <+>
 189          (sdocWithDynFlags $ \dflags ->
 190            ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
 191
 192       -- // text
 193       CmmComment s -> text "//" <+> ftext s
 194
 195       -- //tick bla<...>
 196       CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
 197                    text "//tick" <+> ppr t
 198
 199       -- unwind reg = expr;
 200       CmmUnwind regs ->
 201           text "unwind "
 202           <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
 203
 204       -- reg = expr;
 205       CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 206
 207       -- rep[lv] = expr;
 208       CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 209           where
 210             rep = sdocWithDynFlags $ \dflags ->
 211                   ppr ( cmmExprType dflags expr )
 212
 213       -- call "ccall" foo(x, y)[r1, r2];
 214       -- ToDo ppr volatile
 215       CmmUnsafeForeignCall target results args ->
 216           hsep [ ppUnless (null results) $
 217                     parens (commafy $ map ppr results) <+> equals,
 218                  text "call",
 219                  ppr target <> parens (commafy $ map ppr args) <> semi]
 220
 221       -- goto label;
 222       CmmBranch ident -> text "goto" <+> ppr ident <> semi
 223
 224       -- if (expr) goto t; else goto f;
 225       CmmCondBranch expr t f l ->
 226           hsep [ text "if"
 227                , parens(ppr expr)
 228                , case l of
 229                    Nothing -> empty
 230                    Just b -> parens (text "likely:" <+> ppr b)
 231                , text "goto"
 232                , ppr t <> semi
 233                , text "else goto"
 234                , ppr f <> semi
 235                ]
 236
 237       CmmSwitch expr ids ->
 238           hang (hsep [ text "switch"
 239                      , range
 240                      , if isTrivialCmmExpr expr
 241                        then ppr expr
 242                        else parens (ppr expr)
 243                      , text "{"
 244                      ])
 245              4 (vcat (map ppCase cases) $$ def) $$ rbrace
 246           where
 247             (cases, mbdef) = switchTargetsFallThrough ids
 248             ppCase (is,l) = hsep
 249                             [ text "case"
 250                             , commafy $ map integer is
 251                             , text ": goto"
 252                             , ppr l <> semi
 253                             ]
 254             def | Just l <- mbdef = hsep
 255                             [ text "default: goto"
 256                             , ppr l <> semi
 257                             ]
 258                 | otherwise = empty
 259
 260             range = brackets $ hsep [integer lo, text "..", integer hi]
 261               where (lo,hi) = switchTargetsRange ids
 262
 263       CmmCall tgt k regs out res updfr_off ->
 264           hcat [ text "call", space
 265                , pprFun tgt, parens (interpp'SP regs), space
 266                , returns <+>
 267                  text "args: " <> ppr out <> comma <+>
 268                  text "res: " <> ppr res <> comma <+>
 269                  text "upd: " <> ppr updfr_off
 270                , semi ]
 271           where pprFun f@(CmmLit _) = ppr f
 272                 pprFun f = parens (ppr f)
 273
 274                 returns
 275                   | Just r <- k = text "returns to" <+> ppr r <> comma
 276                   | otherwise   = empty
 277
 278       CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
 279           hcat $ if i then [text "interruptible", space] else [] ++
 280                [ text "foreign call", space
 281                , ppr t, text "(...)", space
 282                , text "returns to" <+> ppr s
 283                     <+> text "args:" <+> parens (ppr as)
 284                     <+> text "ress:" <+> parens (ppr rs)
 285                , text "ret_args:" <+> ppr a
 286                , text "ret_off:" <+> ppr u
 287                , semi ]
 288
 289     pp_debug :: SDoc
 290     pp_debug =
 291       if not debugIsOn then empty
 292       else case node of
 293              CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
 294              CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
 295              CmmTick {}              -> empty
 296              CmmUnwind {}            -> text "  // CmmUnwind"
 297              CmmAssign {}            -> text "  // CmmAssign"
 298              CmmStore {}             -> text "  // CmmStore"
 299              CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
 300              CmmBranch {}            -> text "  // CmmBranch"
 301              CmmCondBranch {}        -> text "  // CmmCondBranch"
 302              CmmSwitch {}            -> text "  // CmmSwitch"
 303              CmmCall {}              -> text "  // CmmCall"
 304              CmmForeignCall {}       -> text "  // CmmForeignCall"
 305
 306     commafy :: [SDoc] -> SDoc
 307     commafy xs = hsep $ punctuate comma xs