compiler/cmm/PprCmm.hs

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