compiler/cmm/PprCmmZ.hs

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