diff options
Diffstat (limited to 'compiler/cmm/PprCmm.hs')
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 83 |
1 files changed, 44 insertions, 39 deletions
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 521ab059b7..d32f129247 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -59,12 +59,12 @@ import Prelude hiding (succ) instance Outputable CmmStackInfo where ppr = pprStackInfo -instance Outputable CmmTopInfo where - ppr = pprTopInfo +instance PlatformOutputable CmmTopInfo where + pprPlatform = pprTopInfo -instance Outputable (CmmNode e x) where - ppr = pprNode +instance PlatformOutputable (CmmNode e x) where + pprPlatform = pprNode instance Outputable Convention where ppr = pprConvention @@ -72,18 +72,18 @@ instance Outputable Convention where instance Outputable ForeignConvention where ppr = pprForeignConvention -instance Outputable ForeignTarget where - ppr = pprForeignTarget +instance PlatformOutputable ForeignTarget where + pprPlatform = pprForeignTarget instance PlatformOutputable (Block CmmNode C C) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode C O) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode O C) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Block CmmNode O O) where - pprPlatform _ = pprBlock + pprPlatform = pprBlock instance PlatformOutputable (Graph CmmNode e x) where pprPlatform = pprGraph @@ -99,22 +99,23 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = ptext (sLit "arg_space: ") <> ppr arg_space <+> ptext (sLit "updfr_space: ") <> ppr updfr_space -pprTopInfo :: CmmTopInfo -> SDoc -pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = - vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> pprPlatform platform info_tbl, ptext (sLit "stack_info: ") <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock block = foldBlockNodesB3 ( ($$) . ppr - , ($$) . (nest 4) . ppr - , ($$) . (nest 4) . ppr - ) - block - empty + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pprPlatform platform + , ($$) . (nest 4) . pprPlatform platform + , ($$) . (nest 4) . pprPlatform platform + ) + block + empty pprGraph :: Platform -> Graph CmmNode e x -> SDoc pprGraph _ GNil = empty @@ -152,23 +153,25 @@ pprConvention (Private {}) = text "<private-convention>" pprForeignConvention :: ForeignConvention -> SDoc pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs -pprForeignTarget :: ForeignTarget -> SDoc -pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn where ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c args res) = doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = ppr t - ppr_target fn' = parens (ppr fn') + ppr_target t@(CmmLit _) = pprPlatform platform t + ppr_target fn' = parens (pprPlatform platform fn') -pprForeignTarget (PrimTarget op) +pprForeignTarget platform (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign. - = ppr (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) -pprNode :: CmmNode e x -> SDoc -pprNode node = pp_node <+> pp_debug + = pprPlatform platform + (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug where pp_node :: SDoc pp_node = case node of @@ -179,10 +182,10 @@ pprNode node = pp_node <+> pp_debug CmmComment s -> text "//" <+> ftext s -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi where rep = ppr ( cmmExprType expr ) @@ -192,7 +195,7 @@ pprNode node = pp_node <+> pp_debug hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, ptext $ sLit "call", - ppr target <> parens (commafy $ map ppr args) <> semi] + pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi] -- goto label; CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi @@ -200,7 +203,7 @@ pprNode node = pp_node <+> pp_debug -- if (expr) goto t; else goto f; CmmCondBranch expr t f -> hsep [ ptext (sLit "if") - , parens(ppr expr) + , parens(pprPlatform platform expr) , ptext (sLit "goto") , ppr t <> semi , ptext (sLit "else goto") @@ -211,7 +214,9 @@ pprNode node = pp_node <+> pp_debug hang (hcat [ ptext (sLit "switch [0 .. ") , int (length maybe_ids - 1) , ptext (sLit "] ") - , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr) + , if isTrivialCmmExpr expr + then pprPlatform platform expr + else parens (pprPlatform platform expr) , ptext (sLit " {") ]) 4 (vcat ( map caseify pairs )) $$ rbrace @@ -232,15 +237,15 @@ pprNode node = pp_node <+> pp_debug <+> parens (ppr res) , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] - where pprFun f@(CmmLit _) = ppr f - pprFun f = parens (ppr f) + where pprFun f@(CmmLit _) = pprPlatform platform f + pprFun f = parens (pprPlatform platform f) CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space - , ppr t, ptext (sLit "(...)"), space + , pprPlatform platform t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s - <+> ptext (sLit "args:") <+> parens (ppr as) + <+> ptext (sLit "args:") <+> parens (pprPlatform platform as) <+> ptext (sLit "ress:") <+> parens (ppr rs) , ptext (sLit " with update frame") <+> ppr u , semi ] |