compiler/cmm/OldPprCmm.hs

   1 ----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing of old-style Cmm as (a superset of) C--
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 --
  10 -- This is where we walk over Cmm emitting an external representation,
  11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
  12 -- is the "External Core" for the Cmm layer.
  13 --
  14 -- As such, this should be a well-defined syntax: we want it to look nice.
  15 -- Thus, we try wherever possible to use syntax defined in [1],
  16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
  17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
  18 -- than C--'s bits8 .. bits64.
  19 --
  20 -- We try to ensure that all information available in the abstract
  21 -- syntax is reproduced, or reproducible, in the concrete syntax.
  22 -- Data that is not in printed out can be reconstructed according to
  23 -- conventions used in the pretty printer. There are at least two such
  24 -- cases:
  25 --      1) if a value has wordRep type, the type is not appended in the
  26 --      output.
  27 --      2) MachOps that operate over wordRep type are printed in a
  28 --      C-style, rather than as their internal MachRep name.
  29 --
  30 -- These conventions produce much more readable Cmm output.
  31 --
  32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
  33 --
  34
  35 module OldPprCmm
  36     ( pprStmt
  37     , module PprCmmDecl
  38     , module PprCmmExpr
  39     )
  40 where
  41
  42 import BlockId
  43 import CLabel
  44 import CmmUtils
  45 import OldCmm
  46 import PprCmmDecl
  47 import PprCmmExpr
  48
  49
  50 import BasicTypes
  51 import ForeignCall
  52 import Outputable
  53 import FastString
  54
  55 import Data.List
  56
  57 -----------------------------------------------------------------------------
  58
  59 instance (Outputable instr) => Outputable (ListGraph instr) where
  60     ppr (ListGraph blocks) = vcat (map ppr blocks)
  61
  62 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
  63     ppr b = pprBBlock b
  64
  65 instance Outputable CmmStmt where
  66     ppr s = pprStmt s
  67
  68 instance Outputable CmmInfo where
  69     ppr e = pprInfo e
  70
  71
  72 -- --------------------------------------------------------------------------
  73 instance Outputable CmmSafety where
  74   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
  75   ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
  76   ppr (CmmSafe srt) = ppr srt
  77
  78 -- --------------------------------------------------------------------------
  79 -- Info tables. The current pretty printer needs refinement
  80 -- but will work for now.
  81 --
  82 -- For ideas on how to refine it, they used to be printed in the
  83 -- style of C--'s 'stackdata' declaration, just inside the proc body,
  84 -- and were labelled with the procedure name ++ "_info".
  85 pprInfo :: CmmInfo -> SDoc
  86 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
  87     vcat [{-ptext (sLit "gc_target: ") <>
  88                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
  89           ptext (sLit "update_frame: ") <>
  90                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
  91 pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) =
  92     vcat [{-ptext (sLit "gc_target: ") <>
  93                 maybe (ptext (sLit "<none>")) ppr gc_target,-}
  94           ptext (sLit "update_frame: ") <>
  95                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
  96           ppr info_table]
  97
  98
  99 -- --------------------------------------------------------------------------
 100 -- Basic blocks look like assembly blocks.
 101 --      lbl: stmt ; stmt ; ..
 102 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 103 pprBBlock (BasicBlock ident stmts) =
 104     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
 105
 106 -- --------------------------------------------------------------------------
 107 -- Statements. C-- usually, exceptions to this should be obvious.
 108 --
 109 pprStmt :: CmmStmt -> SDoc
 110 pprStmt stmt = case stmt of
 111
 112     -- ;
 113     CmmNop -> semi
 114
 115     --  // text
 116     CmmComment s -> text "//" <+> ftext s
 117
 118     -- reg = expr;
 119     CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 120
 121     -- rep[lv] = expr;
 122     CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
 123         where
 124           rep = ppr ( cmmExprType expr )
 125
 126     -- call "ccall" foo(x, y)[r1, r2];
 127     -- ToDo ppr volatile
 128     CmmCall (CmmCallee fn cconv) results args safety ret ->
 129         sep  [ pp_lhs <+> pp_conv
 130              , nest 2 (pprExpr9 fn <>
 131                        parens (commafy (map ppr_ar args)))
 132                <> brackets (ppr safety)
 133              , case ret of CmmMayReturn -> empty
 134                            CmmNeverReturns -> ptext $ sLit (" never returns")
 135              ] <> semi
 136         where
 137           pp_lhs | null results = empty
 138                  | otherwise    = commafy (map ppr_ar results) <+> equals
 139                 -- Don't print the hints on a native C-- call
 140           ppr_ar (CmmHinted ar k) = case cconv of
 141                             CmmCallConv -> ppr ar
 142                             _           -> ppr (ar,k)
 143           pp_conv = case cconv of
 144                       CmmCallConv -> empty
 145                       _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
 146
 147     -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
 148     CmmCall (CmmPrim op) results args safety ret ->
 149         pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
 150                         results args safety ret)
 151         where
 152           -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
 153           --       use one to get the label printed.
 154           lbl = CmmLabel (mkForeignLabel
 155                                 (mkFastString (show op))
 156                                 Nothing ForeignLabelInThisPackage IsFunction)
 157
 158     CmmBranch ident          -> genBranch ident
 159     CmmCondBranch expr ident -> genCondBranch expr ident
 160     CmmJump expr params      -> genJump expr params
 161     CmmReturn params         -> genReturn params
 162     CmmSwitch arg ids        -> genSwitch arg ids
 163
 164 -- Just look like a tuple, since it was a tuple before
 165 -- ... is that a good idea? --Isaac Dupree
 166 instance (Outputable a) => Outputable (CmmHinted a) where
 167   ppr (CmmHinted a k) = ppr (a, k)
 168
 169 pprUpdateFrame :: UpdateFrame -> SDoc
 170 pprUpdateFrame (UpdateFrame expr args) =
 171     hcat [ ptext (sLit "jump")
 172          , space
 173          , if isTrivialCmmExpr expr
 174                 then pprExpr expr
 175                 else case expr of
 176                     CmmLoad (CmmReg _) _ -> pprExpr expr
 177                     _ -> parens (pprExpr expr)
 178          , space
 179          , parens  ( commafy $ map ppr args ) ]
 180
 181
 182 -- --------------------------------------------------------------------------
 183 -- goto local label. [1], section 6.6
 184 --
 185 --     goto lbl;
 186 --
 187 genBranch :: BlockId -> SDoc
 188 genBranch ident =
 189     ptext (sLit "goto") <+> ppr ident <> semi
 190
 191 -- --------------------------------------------------------------------------
 192 -- Conditional. [1], section 6.4
 193 --
 194 --     if (expr) { goto lbl; }
 195 --
 196 genCondBranch :: CmmExpr -> BlockId -> SDoc
 197 genCondBranch expr ident =
 198     hsep [ ptext (sLit "if")
 199          , parens(ppr expr)
 200          , ptext (sLit "goto")
 201          , ppr ident <> semi ]
 202
 203 -- --------------------------------------------------------------------------
 204 -- A tail call. [1], Section 6.9
 205 --
 206 --     jump foo(a, b, c);
 207 --
 208 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
 209 genJump expr args =
 210     hcat [ ptext (sLit "jump")
 211          , space
 212          , if isTrivialCmmExpr expr
 213                 then pprExpr expr
 214                 else case expr of
 215                     CmmLoad (CmmReg _) _ -> pprExpr expr
 216                     _ -> parens (pprExpr expr)
 217          , space
 218          , parens  ( commafy $ map ppr args )
 219          , semi ]
 220
 221
 222 -- --------------------------------------------------------------------------
 223 -- Return from a function. [1], Section 6.8.2 of version 1.128
 224 --
 225 --     return (a, b, c);
 226 --
 227 genReturn :: [CmmHinted CmmExpr] -> SDoc
 228 genReturn args =
 229     hcat [ ptext (sLit "return")
 230          , space
 231          , parens  ( commafy $ map ppr args )
 232          , semi ]
 233
 234 -- --------------------------------------------------------------------------
 235 -- Tabled jump to local label
 236 --
 237 -- The syntax is from [1], section 6.5
 238 --
 239 --      switch [0 .. n] (expr) { case ... ; }
 240 --
 241 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
 242 genSwitch expr maybe_ids
 243
 244     = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
 245
 246       in hang (hcat [ ptext (sLit "switch [0 .. ")
 247                     , int (length maybe_ids - 1)
 248                     , ptext (sLit "] ")
 249                     , if isTrivialCmmExpr expr
 250                         then pprExpr expr
 251                         else parens (pprExpr expr)
 252                     , ptext (sLit " {")
 253                     ])
 254             4 (vcat ( map caseify pairs )) $$ rbrace
 255
 256     where
 257       snds a b = (snd a) == (snd b)
 258
 259       caseify :: [(Int,Maybe BlockId)] -> SDoc
 260       caseify ixs@((_,Nothing):_)
 261         = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
 262                 <> ptext (sLit " */")
 263       caseify as
 264         = let (is,ids) = unzip as
 265           in hsep [ ptext (sLit "case")
 266                   , hcat (punctuate comma (map int is))
 267                   , ptext (sLit ": goto")
 268                   , ppr (head [ id | Just id <- ids]) <> semi ]
 269
 270 -----------------------------------------------------------------------------
 271
 272 commafy :: [SDoc] -> SDoc
 273 commafy xs = fsep $ punctuate comma xs