compiler/cmm/PprCmmZ.hs

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