7 #include "HsVersions.h"
13 import qualified ZipCfgCmmRep as G
14 import qualified ZipCfg as Z
20 ----------------------------------------------------------------
21 pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc
22 pprCmmGraphLikeCmm g = vcat (swallow blocks)
23 where blocks = Z.postorder_dfs g
24 swallow :: [G.CmmBlock] -> [SDoc]
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)"
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'))
38 let endblock stmt = block' id (stmt : prev') : swallow n in
40 G.LastBranch tgt [] ->
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
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
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,
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
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
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>")
83 case n of [] -> [text "<exit>"]
85 if unique_pred id' then
86 tail id (ptext SLIT("went thru exit") : prev') t bs
88 endblock (ppr $ CmmBranch id')
91 entry_has_no_pred = case Z.lookupBlockEnv preds (Z.lg_entry g) of
93 Just s -> isEmptyUniqSet s
97 in case Z.lookupBlockEnv preds id of
99 Just s -> if sizeUniqSet s == 1 then
100 Z.extendBlockSet single id
102 in Z.fold_blocks add Z.emptyBlockSet g
103 unique_pred id = Z.elemBlockSet id single_preds