1 {-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}
8 #include "HsVersions.h"
14 import qualified ZipCfgCmm as G
15 import qualified ZipCfg as Z
16 import qualified ZipDataflow as DF
22 ----------------------------------------------------------------
23 instance DF.DebugNodes G.Middle G.Last
26 instance Outputable G.CmmGraph where
29 pprCmmGraph :: G.CmmGraph -> SDoc
30 pprCmmGraph g = vcat (swallow blocks)
31 where blocks = Z.postorder_dfs g
32 swallow :: [G.CmmBlock] -> [SDoc]
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)"
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'))
46 let endblock stmt = block' id (stmt : prev') : swallow n in
48 G.LastBranch tgt [] ->
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
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
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,
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
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
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>")
91 case n of [] -> [text "<exit>"]
93 if unique_pred id' then
94 tail id (ptext SLIT("went thru exit") : prev') t bs
96 endblock (ppr $ CmmBranch id')
99 entry_has_no_pred = case Z.lookupBlockEnv preds (Z.gr_entry g) of
101 Just s -> isEmptyUniqSet s
105 in case Z.lookupBlockEnv preds id of
107 Just s -> if sizeUniqSet s == 1 then
108 Z.extendBlockSet single id
110 in Z.fold_blocks add Z.emptyBlockSet g
111 unique_pred id = Z.elemBlockSet id single_preds