Be more selective in which conditionals we invert
[ghc.git] / compiler / cmm / PprCmm.hs
index d32f129..6a93ea8 100644 (file)
@@ -1,3 +1,6 @@
+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 ----------------------------------------------------------------------------
 --
 -- Pretty-printing of Cmm as (a superset of) C--
@@ -12,8 +15,8 @@
 --
 -- As such, this should be a well-defined syntax: we want it to look nice.
 -- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
 -- than C--'s bits8 .. bits64.
 --
 -- We try to ensure that all information available in the abstract
 --
 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
 
-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}
 module PprCmm
   ( module PprCmmDecl
   , module PprCmmExpr
   )
 where
 
+import GhcPrelude hiding (succ)
+
 import BlockId ()
 import CLabel
 import Cmm
 import CmmUtils
+import CmmSwitch
+import DynFlags
 import FastString
 import Outputable
 import PprCmmDecl
 import PprCmmExpr
 import Util
+import PprCore ()
 
 import BasicTypes
-import Platform
-import Compiler.Hoopl
-import Data.List
-import Prelude hiding (succ)
+import Hoopl.Block
+import Hoopl.Graph
 
 -------------------------------------------------
 -- Outputable instances
@@ -59,12 +64,12 @@ import Prelude hiding (succ)
 instance Outputable CmmStackInfo where
     ppr = pprStackInfo
 
-instance PlatformOutputable CmmTopInfo where
-    pprPlatform = pprTopInfo
+instance Outputable CmmTopInfo where
+    ppr = pprTopInfo
 
 
-instance PlatformOutputable (CmmNode e x) where
-    pprPlatform = pprNode
+instance Outputable (CmmNode e x) where
+    ppr = pprNode
 
 instance Outputable Convention where
     ppr = pprConvention
@@ -72,69 +77,74 @@ instance Outputable Convention where
 instance Outputable ForeignConvention where
     ppr = pprForeignConvention
 
-instance PlatformOutputable ForeignTarget where
-    pprPlatform = pprForeignTarget
+instance Outputable ForeignTarget where
+    ppr = pprForeignTarget
 
+instance Outputable CmmReturnInfo where
+    ppr = pprReturnInfo
 
-instance PlatformOutputable (Block CmmNode C C) where
-    pprPlatform = pprBlock
-instance PlatformOutputable (Block CmmNode C O) where
-    pprPlatform = pprBlock
-instance PlatformOutputable (Block CmmNode O C) where
-    pprPlatform = pprBlock
-instance PlatformOutputable (Block CmmNode O O) where
-    pprPlatform = pprBlock
+instance Outputable (Block CmmNode C C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode C O) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O O) where
+    ppr = pprBlock
 
-instance PlatformOutputable (Graph CmmNode e x) where
-    pprPlatform = pprGraph
+instance Outputable (Graph CmmNode e x) where
+    ppr = pprGraph
 
-instance PlatformOutputable CmmGraph where
-    pprPlatform platform = pprCmmGraph platform
+instance Outputable CmmGraph where
+    ppr = pprCmmGraph
 
 ----------------------------------------------------------
 -- Outputting types Cmm contains
 
 pprStackInfo :: CmmStackInfo -> SDoc
 pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
-  ptext (sLit "arg_space: ") <> ppr arg_space <+>
-  ptext (sLit "updfr_space: ") <> ppr updfr_space
+  text "arg_space: " <> ppr arg_space <+>
+  text "updfr_space: " <> ppr updfr_space
 
-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]
+pprTopInfo :: CmmTopInfo -> SDoc
+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+  vcat [text "info_tbl: " <> ppr info_tbl,
+        text "stack_info: " <> ppr stack_info]
 
 ----------------------------------------------------------
 -- Outputting blocks and graphs
 
 pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
-         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
-pprBlock platform block
-    = foldBlockNodesB3 ( ($$) . pprPlatform platform
-                       , ($$) . (nest 4) . pprPlatform platform
-                       , ($$) . (nest 4) . pprPlatform platform
+         => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock block
+    = foldBlockNodesB3 ( ($$) . ppr
+                       , ($$) . (nest 4) . ppr
+                       , ($$) . (nest 4) . ppr
                        )
                        block
                        empty
 
-pprGraph :: Platform -> Graph CmmNode e x -> SDoc
-pprGraph GNil = empty
-pprGraph platform (GUnit block) = pprPlatform platform block
-pprGraph platform (GMany entry body exit)
+pprGraph :: Graph CmmNode e x -> SDoc
+pprGraph GNil = empty
+pprGraph (GUnit block) = ppr block
+pprGraph (GMany entry body exit)
    = text "{"
-  $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit)
+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
   $$ text "}"
-  where pprMaybeO :: PlatformOutputable (Block CmmNode e x)
+  where pprMaybeO :: Outputable (Block CmmNode e x)
                   => MaybeO ex (Block CmmNode e x) -> SDoc
         pprMaybeO NothingO = empty
-        pprMaybeO (JustO block) = pprPlatform platform block
+        pprMaybeO (JustO block) = ppr block
 
-pprCmmGraph :: Platform -> CmmGraph -> SDoc
-pprCmmGraph platform g
+pprCmmGraph :: CmmGraph -> SDoc
+pprCmmGraph g
    = text "{" <> text "offset"
-  $$ nest 2 (vcat $ map (pprPlatform platform) blocks)
+  $$ nest 2 (vcat $ map ppr blocks)
   $$ text "}"
   where blocks = postorderDfs g
+    -- postorderDfs has the side-effect of discarding unreachable code,
+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
+    -- sometimes be confusing.
 
 ---------------------------------------------
 -- Outputting CmmNode and types which it contains
@@ -145,109 +155,135 @@ pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
 pprConvention (NativeReturn {})     = text "<native-ret-convention>"
 pprConvention  Slow                 = text "<slow-convention>"
 pprConvention  GC                   = text "<gc-convention>"
-pprConvention  PrimOpCall           = text "<primop-call-convention>"
-pprConvention  PrimOpReturn         = text "<primop-ret-convention>"
-pprConvention (Foreign c)           = ppr c
-pprConvention (Private {})          = text "<private-convention>"
 
 pprForeignConvention :: ForeignConvention -> SDoc
-pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
+pprForeignConvention (ForeignConvention c args res ret) =
+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
 
-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
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
+pprForeignTarget :: ForeignTarget -> SDoc
+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+  where
         ppr_target :: CmmExpr -> SDoc
-        ppr_target t@(CmmLit _) = pprPlatform platform t
-        ppr_target fn'          = parens (pprPlatform platform fn')
+        ppr_target t@(CmmLit _) = ppr t
+        ppr_target fn'          = parens (ppr fn')
 
-pprForeignTarget platform (PrimTarget op)
+pprForeignTarget (PrimTarget op)
  -- HACK: We're just using a ForeignLabel to get this printed, the label
  --       might not really be foreign.
- = pprPlatform platform
+ = ppr
                (CmmLabel (mkForeignLabel
                          (mkFastString (show op))
                          Nothing ForeignLabelInThisPackage IsFunction))
 
-pprNode :: Platform -> CmmNode e x -> SDoc
-pprNode platform node = pp_node <+> pp_debug
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
   where
     pp_node :: SDoc
-    pp_node = case node of
+    pp_node = sdocWithDynFlags $ \dflags -> case node of
       -- label:
-      CmmEntry id -> ppr id <> colon
+      CmmEntry id tscope -> ppr id <> colon <+>
+         (sdocWithDynFlags $ \dflags ->
+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
 
       -- // text
       CmmComment s -> text "//" <+> ftext s
 
+      -- //tick bla<...>
+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
+                   text "//tick" <+> ppr t
+
+      -- unwind reg = expr;
+      CmmUnwind regs ->
+          text "unwind "
+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+
       -- reg = expr;
-      CmmAssign reg expr -> ppr reg <+> equals <+> pprPlatform platform expr <> semi
+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
 
       -- rep[lv] = expr;
-      CmmStore lv expr -> rep <> brackets(pprPlatform platform lv) <+> equals <+> pprPlatform platform expr <> semi
+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
           where
-            rep = ppr ( cmmExprType expr )
+            rep = sdocWithDynFlags $ \dflags ->
+                  ppr ( cmmExprType dflags expr )
 
       -- call "ccall" foo(x, y)[r1, r2];
       -- ToDo ppr volatile
       CmmUnsafeForeignCall target results args ->
           hsep [ ppUnless (null results) $
                     parens (commafy $ map ppr results) <+> equals,
-                 ptext $ sLit "call",
-                 pprPlatform platform target <> parens (commafy $ map (pprPlatform platform) args) <> semi]
+                 text "call",
+                 ppr target <> parens (commafy $ map ppr args) <> semi]
 
       -- goto label;
-      CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
+      CmmBranch ident -> text "goto" <+> ppr ident <> semi
 
       -- if (expr) goto t; else goto f;
-      CmmCondBranch expr t f ->
-          hsep [ ptext (sLit "if")
-               , parens(pprPlatform platform expr)
-               , ptext (sLit "goto")
+      CmmCondBranch expr t f l ->
+          hsep [ text "if"
+               , parens(ppr expr)
+               , case l of
+                   Nothing -> empty
+                   Just b -> parens (text "likely:" <+> ppr b)
+               , text "goto"
                , ppr t <> semi
-               , ptext (sLit "else goto")
+               , text "else goto"
                , ppr f <> semi
                ]
 
-      CmmSwitch expr maybe_ids ->
-          hang (hcat [ ptext (sLit "switch [0 .. ")
-                     , int (length maybe_ids - 1)
-                     , ptext (sLit "] ")
+      CmmSwitch expr ids ->
+          hang (hsep [ text "switch"
+                     , range
                      , if isTrivialCmmExpr expr
-                       then pprPlatform platform expr
-                       else parens (pprPlatform platform expr)
-                     , ptext (sLit " {")
+                       then ppr expr
+                       else parens (ppr expr)
+                     , text "{"
                      ])
-             4 (vcat ( map caseify pairs )) $$ rbrace
-          where pairs = groupBy snds (zip [0 .. ] maybe_ids )
-                snds a b = (snd a) == (snd b)
-                caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
-                                              <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
-                caseify as = let (is,ids) = unzip as
-                             in hsep [ ptext (sLit "case")
-                                     , hcat (punctuate comma (map int is))
-                                     , ptext (sLit ": goto")
-                                     , ppr (head [ id | Just id <- ids]) <> semi ]
-
-      CmmCall tgt k out res updfr_off ->
-          hcat [ ptext (sLit "call"), space
-               , pprFun tgt, ptext (sLit "(...)"), space
-               , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
-                                                     <+> parens (ppr res)
-               , ptext (sLit " with update frame") <+> ppr updfr_off
+             4 (vcat (map ppCase cases) $$ def) $$ rbrace
+          where
+            (cases, mbdef) = switchTargetsFallThrough ids
+            ppCase (is,l) = hsep
+                            [ text "case"
+                            , commafy $ map integer is
+                            , text ": goto"
+                            , ppr l <> semi
+                            ]
+            def | Just l <- mbdef = hsep
+                            [ text "default:"
+                            , braces (text "goto" <+> ppr l <> semi)
+                            ]
+                | otherwise = empty
+
+            range = brackets $ hsep [integer lo, text "..", integer hi]
+              where (lo,hi) = switchTargetsRange ids
+
+      CmmCall tgt k regs out res updfr_off ->
+          hcat [ text "call", space
+               , pprFun tgt, parens (interpp'SP regs), space
+               , returns <+>
+                 text "args: " <> ppr out <> comma <+>
+                 text "res: " <> ppr res <> comma <+>
+                 text "upd: " <> ppr updfr_off
                , semi ]
-          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
-               , pprPlatform platform t, ptext (sLit "(...)"), space
-               , ptext (sLit "returns to") <+> ppr s
-                    <+> ptext (sLit "args:") <+> parens (pprPlatform platform as)
-                    <+> ptext (sLit "ress:") <+> parens (ppr rs)
-               , ptext (sLit " with update frame") <+> ppr u
+          where pprFun f@(CmmLit _) = ppr f
+                pprFun f = parens (ppr f)
+
+                returns
+                  | Just r <- k = text "returns to" <+> ppr r <> comma
+                  | otherwise   = empty
+
+      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+          hcat $ if i then [text "interruptible", space] else [] ++
+               [ text "foreign call", space
+               , ppr t, text "(...)", space
+               , text "returns to" <+> ppr s
+                    <+> text "args:" <+> parens (ppr as)
+                    <+> text "ress:" <+> parens (ppr rs)
+               , text "ret_args:" <+> ppr a
+               , text "ret_off:" <+> ppr u
                , semi ]
 
     pp_debug :: SDoc
@@ -256,6 +292,8 @@ pprNode platform node = pp_node <+> pp_debug
       else case node of
              CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
              CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
+             CmmTick {}              -> empty
+             CmmUnwind {}            -> text "  // CmmUnwind"
              CmmAssign {}            -> text "  // CmmAssign"
              CmmStore {}             -> text "  // CmmStore"
              CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"