compiler/cmm/PprCmmZ.hs

   1
   2 module PprCmmZ
   3     ( pprCmmGraph
   4     )
   5 where
   6
   7 #include "HsVersions.h"
   8
   9 import Cmm
  10 import CmmExpr
  11 import PprCmm()
  12 import Outputable
  13 import qualified ZipCfgCmm as G
  14 import qualified ZipCfg as Z
  15 import qualified ZipDataflow as DF
  16 import CmmZipUtil
  17
  18 import UniqSet
  19 import FastString
  20
  21 ----------------------------------------------------------------
  22 instance DF.DebugNodes G.Middle G.Last
  23
  24
  25 instance Outputable G.CmmGraph where
  26     ppr = pprCmmGraph
  27
  28 pprCmmGraph :: G.CmmGraph -> SDoc
  29 pprCmmGraph g = vcat (swallow blocks)
  30     where blocks = Z.postorder_dfs g
  31           swallow :: [G.CmmBlock] -> [SDoc]
  32           swallow [] = []
  33           swallow (Z.Block id t : rest) = tail id [] t rest
  34           tail id prev' (Z.ZTail m t)            rest = tail id (mid m : prev') t rest
  35           tail id prev' (Z.ZLast Z.LastExit)     rest = exit id prev' rest
  36           tail id prev' (Z.ZLast (Z.LastOther l))rest = last id prev' l rest
  37           mid (G.CopyIn _ [] _) = text "// proc point (no parameters)"
  38           mid m@(G.CopyIn {}) = ppr m <+> text "(proc point)"
  39           mid m = ppr m
  40           block' id prev'
  41               | id == Z.gr_entry g, entry_has_no_pred =
  42                             vcat (text "<entry>" : reverse prev')
  43               | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
  44           last id prev' l n =
  45               let endblock stmt = block' id (stmt : prev') : swallow n in
  46               case l of
  47                 G.LastBranch tgt [] ->
  48                     case n of
  49                       Z.Block id' t : bs
  50                           | tgt == id', unique_pred id'
  51                           -> tail id prev' t bs  -- optimize out redundant labels
  52                       _ -> endblock (ppr $ CmmBranch tgt)
  53                 l@(G.LastBranch {}) -> endblock (ppr l)
  54                 l@(G.LastCondBranch expr tid fid) ->
  55                   let ft id = text "// fall through to " <> ppr id in
  56                   case n of
  57                     Z.Block id' t : bs
  58                       | id' == fid, False ->
  59                           tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') t bs
  60                       | id' == tid, Just e' <- maybeInvertCmmExpr expr, False ->
  61                           tail id (ft tid : ppr (CmmCondBranch e'   fid) : prev') t bs
  62                     _ -> endblock (ppr l)
  63                 l@(G.LastJump   {}) -> endblock $ ppr l
  64                 l@(G.LastReturn {}) -> endblock $ ppr l
  65                 l@(G.LastSwitch {}) -> endblock $ ppr l
  66                 l@(G.LastCall _ _ Nothing) -> endblock $ ppr l
  67                 l@(G.LastCall tgt args (Just k))
  68                    | Z.Block id' (Z.ZTail (G.CopyIn _ ress srt) t) : bs <- n,
  69                      id' == k ->
  70                          let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
  71                              ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
  72                          in if unique_pred k then
  73                                 tail id (ppcall : prev') t bs
  74                             else
  75                                 endblock (ppcall)
  76                    | Z.Block id' t : bs <- n, id' == k, unique_pred k,
  77                      Just (ress, srt) <- findCopyIn t ->
  78                          let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
  79                              delayed =
  80                                  ptext SLIT("// delayed CopyIn follows previous call")
  81                          in  tail id (delayed : ppr call : prev') t bs
  82                    | otherwise -> endblock $ ppr l
  83           findCopyIn (Z.ZTail (G.CopyIn _ ress srt) _) = Just (ress, srt)
  84           findCopyIn (Z.ZTail _ t) = findCopyIn t
  85           findCopyIn (Z.ZLast _) = Nothing
  86           exit id prev' n = -- highly irregular (assertion violation?)
  87               let endblock stmt = block' id (stmt : prev') : swallow n in
  88               endblock (text "// <exit>")
  89 {-
  90               case n of [] -> [text "<exit>"]
  91                         Z.Block id' t : bs ->
  92                             if unique_pred id' then
  93                                 tail id (ptext SLIT("went thru exit") : prev') t bs
  94                             else
  95                                 endblock (ppr $ CmmBranch id')
  96 -}
  97           preds = zipPreds g
  98           entry_has_no_pred = case Z.lookupBlockEnv preds (Z.gr_entry g) of
  99                                 Nothing -> True
 100                                 Just s -> isEmptyUniqSet s
 101           single_preds =
 102               let add b single =
 103                     let id = Z.blockId b
 104                     in  case Z.lookupBlockEnv preds id of
 105                           Nothing -> single
 106                           Just s -> if sizeUniqSet s == 1 then
 107                                         Z.extendBlockSet single id
 108                                     else single
 109               in  Z.fold_blocks add Z.emptyBlockSet g
 110           unique_pred id = Z.elemBlockSet id single_preds
 111