1 {-# LANGUAGE PatternGuards #-}
2 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
5 ( cmmToZgraph, cmmOfZgraph )
9 import MkZipCfgCmm hiding (CmmGraph)
10 import ZipCfgCmmRep -- imported for reverse conversion
19 import qualified ZipCfg as G
21 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
22 cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
24 cmmToZgraph = cmmMapGraphM toZgraph
25 cmmOfZgraph = cmmMapGraph ofZgraph
28 toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
29 toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
30 toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
31 labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
32 where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g
33 mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
34 mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
35 mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
36 mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
37 mkStmts (CmmCall f res args (CmmSafe srt) CmmMayReturn : ss) =
38 mkCall f res args srt <*> mkStmts ss
39 mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
40 mkUnsafeCall f res args <*> mkStmts ss
41 mkStmts (CmmCondBranch e l : fbranch) =
42 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
43 mkStmts (last : []) = mkLast last
44 mkStmts [] = bad "fell off end"
45 mkStmts (_ : _ : _) = bad "last node not at end"
46 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
47 mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args
48 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
49 mkLast (CmmJump tgt args) = mkJump tgt args
50 mkLast (CmmReturn ress) = mkReturn ress
51 mkLast (CmmBranch tgt) = mkBranch tgt
52 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
53 panic "Call never returns but has results?!"
54 mkLast _ = panic "fell off end of block"
56 ofZgraph :: CmmGraph -> ListGraph CmmStmt
57 ofZgraph g = ListGraph $ swallow blocks
58 where blocks = G.postorder_dfs g
59 -- | the next two functions are hooks on which to hang debugging info
60 extend_entry stmts = stmts
61 extend_block _id stmts = stmts
62 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
63 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
64 concat (map (\(G.Block id _) -> " " ++ show id) blocks)
65 cscomm = "Call successors are" ++
66 (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
68 swallow (G.Block id t : rest) = tail id [] t rest
69 tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
70 tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
71 tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
73 mid (MidComment s) = CmmComment s
74 mid (MidAssign l r) = CmmAssign l r
75 mid (MidStore l r) = CmmStore l r
76 mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
77 mid m@(CopyOut {}) = pcomment (ppr m)
78 mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
79 pcomment p = scomment $ showSDoc p
81 | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
82 | otherwise = BasicBlock id $ extend_block id (reverse prev')
84 let endblock stmt = block' id (stmt : prev') : swallow n in
86 LastBranch _ (_:_) -> panic "unrepresentable branch"
90 | tgt == id', unique_pred id'
91 -> tail id prev' t bs -- optimize out redundant labels
92 _ -> endblock (CmmBranch tgt)
93 LastCondBranch expr tid fid ->
96 | id' == fid, unique_pred id' ->
97 tail id (CmmCondBranch expr tid : prev') t bs
98 | id' == tid, unique_pred id',
99 Just e' <- maybeInvertCmmExpr expr ->
100 tail id (CmmCondBranch e' fid : prev') t bs
101 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
102 in block' id instrs' : swallow n
103 LastJump expr params -> endblock $ CmmJump expr params
104 LastReturn params -> endblock $ CmmReturn params
105 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
106 LastCall tgt args Nothing ->
107 endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
108 LastCall tgt args (Just k)
109 | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
110 id' == k, unique_pred k ->
111 let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
112 in tail id (call : prev') t bs
113 | G.Block id' t : bs <- n, id' == k, unique_pred k ->
114 let (ress, srt) = findCopyIn t
115 call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
116 delayed = scomment "delayed CopyIn follows previous call"
117 in tail id (delayed : call : prev') t bs
118 | otherwise -> panic "unrepairable call"
119 findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
120 findCopyIn (G.ZTail _ t) = findCopyIn t
121 findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
122 exit id prev' n = -- highly irregular (assertion violation?)
123 let endblock stmt = block' id (stmt : prev') : swallow n in
124 case n of [] -> endblock (scomment "procedure falls off end")
125 G.Block id' t : bs ->
126 if unique_pred id' then
127 tail id (scomment "went thru exit" : prev') t bs
129 endblock (CmmBranch id')
134 in case G.lookupBlockEnv preds id of
136 Just s -> if sizeUniqSet s == 1 then
137 G.extendBlockSet single id
139 in G.fold_blocks add G.emptyBlockSet g
140 unique_pred id = G.elemBlockSet id single_preds
143 case G.last (G.unzip b) of
144 G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
146 in G.fold_blocks add emptyBlockSet g
147 _is_call_succ id = elemBlockSet id call_succs
149 scomment :: String -> CmmStmt
150 scomment s = CmmComment $ mkFastString s