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.cs.tufts.edu/~nr/c--/index.html. We 19-- differ 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 36module PprCmm 37 ( module PprCmmDecl 38 , module PprCmmExpr 39 ) 40where 41 42import GhcPrelude hiding (succ) 43 44import CLabel 45import Cmm 46import CmmUtils 47import CmmSwitch 48import DynFlags 49import FastString 50import Outputable 51import PprCmmDecl 52import PprCmmExpr 53import Util 54 55import BasicTypes 56import Hoopl.Block 57import Hoopl.Graph 58 59------------------------------------------------- 60-- Outputable instances 61 62instance Outputable CmmStackInfo where 63 ppr = pprStackInfo 64 65instance Outputable CmmTopInfo where 66 ppr = pprTopInfo 67 68 69instance Outputable (CmmNode e x) where 70 ppr = pprNode 71 72instance Outputable Convention where 73 ppr = pprConvention 74 75instance Outputable ForeignConvention where 76 ppr = pprForeignConvention 77 78instance Outputable ForeignTarget where 79 ppr = pprForeignTarget 80 81instance Outputable CmmReturnInfo where 82 ppr = pprReturnInfo 83 84instance Outputable (Block CmmNode C C) where 85 ppr = pprBlock 86instance Outputable (Block CmmNode C O) where 87 ppr = pprBlock 88instance Outputable (Block CmmNode O C) where 89 ppr = pprBlock 90instance Outputable (Block CmmNode O O) where 91 ppr = pprBlock 92 93instance Outputable (Graph CmmNode e x) where 94 ppr = pprGraph 95 96instance Outputable CmmGraph where 97 ppr = pprCmmGraph 98 99---------------------------------------------------------- 100-- Outputting types Cmm contains 101 102pprStackInfo :: CmmStackInfo -> SDoc 103pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = 104 text "arg_space: " <> ppr arg_space <+> 105 text "updfr_space: " <> ppr updfr_space 106 107pprTopInfo :: CmmTopInfo -> SDoc 108pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = 109 vcat [text "info_tbls: " <> ppr info_tbl, 110 text "stack_info: " <> ppr stack_info] 111 112---------------------------------------------------------- 113-- Outputting blocks and graphs 114 115pprBlock :: IndexedCO x SDoc SDoc ~ SDoc 116 => Block CmmNode e x -> IndexedCO e SDoc SDoc 117pprBlock block 118 = foldBlockNodesB3 ( ($$) . ppr 119 , ($$) . (nest 4) . ppr 120 , ($$) . (nest 4) . ppr 121 ) 122 block 123 empty 124 125pprGraph :: Graph CmmNode e x -> SDoc 126pprGraph GNil = empty 127pprGraph (GUnit block) = ppr block 128pprGraph (GMany entry body exit) 129 = text "{" 130 $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) 131 $$ text "}" 132 where pprMaybeO :: Outputable (Block CmmNode e x) 133 => MaybeO ex (Block CmmNode e x) -> SDoc 134 pprMaybeO NothingO = empty 135 pprMaybeO (JustO block) = ppr block 136 137pprCmmGraph :: CmmGraph -> SDoc 138pprCmmGraph g 139 = text "{" <> text "offset" 140 $$ nest 2 (vcat $ map ppr blocks) 141 $$ text "}" 142 where blocks = revPostorder g 143 -- revPostorder has the side-effect of discarding unreachable code, 144 -- so pretty-printed Cmm will omit any unreachable blocks. This can 145 -- sometimes be confusing. 146 147--------------------------------------------- 148-- Outputting CmmNode and types which it contains 149 150pprConvention :: Convention -> SDoc 151pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>" 152pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>" 153pprConvention (NativeReturn {}) = text "<native-ret-convention>" 154pprConvention Slow = text "<slow-convention>" 155pprConvention GC = text "<gc-convention>" 156 157pprForeignConvention :: ForeignConvention -> SDoc 158pprForeignConvention (ForeignConvention c args res ret _ _) = 159 doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret 160 161pprReturnInfo :: CmmReturnInfo -> SDoc 162pprReturnInfo CmmMayReturn = empty 163pprReturnInfo CmmNeverReturns = text "never returns" 164 165pprForeignTarget :: ForeignTarget -> SDoc 166pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn 167 where 168 ppr_target :: CmmExpr -> SDoc 169 ppr_target t@(CmmLit _) = ppr t 170 ppr_target fn' = parens (ppr fn') 171 172pprForeignTarget (PrimTarget op) 173 -- HACK: We're just using a ForeignLabel to get this printed, the label 174 -- might not really be foreign. 175 = ppr 176 (CmmLabel (mkForeignLabel 177 (mkFastString (show op)) 178 Nothing ForeignLabelInThisPackage IsFunction)) 179 180pprNode :: CmmNode e x -> SDoc 181pprNode node = pp_node <+> pp_debug 182 where 183 pp_node :: SDoc 184 pp_node = sdocWithDynFlags $ \dflags -> case node of 185 -- label: 186 CmmEntry id tscope -> lbl <> colon <+> 187 (sdocWithDynFlags $ \dflags -> 188 ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope)) 189 where 190 lbl = if gopt Opt_SuppressUniques dflags 191 then text "_lbl_" 192 else ppr id 193 194 -- // text 195 CmmComment s -> text "//" <+> ftext s 196 197 -- //tick bla<...> 198 CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $ 199 text "//tick" <+> ppr t 200 201 -- unwind reg = expr; 202 CmmUnwind regs -> 203 text "unwind " 204 <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi 205 206 -- reg = expr; 207 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi 208 209 -- rep[lv] = expr; 210 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi 211 where 212 rep = sdocWithDynFlags $ \dflags -> 213 ppr ( cmmExprType dflags expr ) 214 215 -- call "ccall" foo(x, y)[r1, r2]; 216 -- ToDo ppr volatile 217 CmmUnsafeForeignCall target results args -> 218 hsep [ ppUnless (null results) $ 219 parens (commafy $ map ppr results) <+> equals, 220 text "call", 221 ppr target <> parens (commafy $ map ppr args) <> semi] 222 223 -- goto label; 224 CmmBranch ident -> text "goto" <+> ppr ident <> semi 225 226 -- if (expr) goto t; else goto f; 227 CmmCondBranch expr t f l -> 228 hsep [ text "if" 229 , parens(ppr expr) 230 , case l of 231 Nothing -> empty 232 Just b -> parens (text "likely:" <+> ppr b) 233 , text "goto" 234 , ppr t <> semi 235 , text "else goto" 236 , ppr f <> semi 237 ] 238 239 CmmSwitch expr ids -> 240 hang (hsep [ text "switch" 241 , range 242 , if isTrivialCmmExpr expr 243 then ppr expr 244 else parens (ppr expr) 245 , text "{" 246 ]) 247 4 (vcat (map ppCase cases) $$ def) $$ rbrace 248 where 249 (cases, mbdef) = switchTargetsFallThrough ids 250 ppCase (is,l) = hsep 251 [ text "case" 252 , commafy $ map integer is 253 , text ": goto" 254 , ppr l <> semi 255 ] 256 def | Just l <- mbdef = hsep 257 [ text "default:" 258 , braces (text "goto" <+> ppr l <> semi) 259 ] 260 | otherwise = empty 261 262 range = brackets $ hsep [integer lo, text "..", integer hi] 263 where (lo,hi) = switchTargetsRange ids 264 265 CmmCall tgt k regs out res updfr_off -> 266 hcat [ text "call", space 267 , pprFun tgt, parens (interpp'SP regs), space 268 , returns <+> 269 text "args: " <> ppr out <> comma <+> 270 text "res: " <> ppr res <> comma <+> 271 text "upd: " <> ppr updfr_off 272 , semi ] 273 where pprFun f@(CmmLit _) = ppr f 274 pprFun f = parens (ppr f) 275 276 returns 277 | Just r <- k = text "returns to" <+> ppr r <> comma 278 | otherwise = empty 279 280 CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> 281 hcat $ if i then [text "interruptible", space] else [] ++ 282 [ text "foreign call", space 283 , ppr t, text "(...)", space 284 , text "returns to" <+> ppr s 285 <+> text "args:" <+> parens (ppr as) 286 <+> text "ress:" <+> parens (ppr rs) 287 , text "ret_args:" <+> ppr a 288 , text "ret_off:" <+> ppr u 289 , semi ] 290 291 pp_debug :: SDoc 292 pp_debug = 293 if not debugIsOn then empty 294 else case node of 295 CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" 296 CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" 297 CmmTick {} -> empty 298 CmmUnwind {} -> text " // CmmUnwind" 299 CmmAssign {} -> text " // CmmAssign" 300 CmmStore {} -> text " // CmmStore" 301 CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" 302 CmmBranch {} -> text " // CmmBranch" 303 CmmCondBranch {} -> text " // CmmCondBranch" 304 CmmSwitch {} -> text " // CmmSwitch" 305 CmmCall {} -> text " // CmmCall" 306 CmmForeignCall {} -> text " // CmmForeignCall" 307 308 commafy :: [SDoc] -> SDoc 309 commafy xs = hsep $ punctuate comma xs 310