ae336b56a37efa7c65bb8bb71e311c2906cc4fcc
[ghc.git] / compiler / cmm / CmmCvt.hs
1 {-# LANGUAGE PatternGuards #-}
2
3 module CmmCvt
4 ( cmmToZgraph, cmmOfZgraph )
5 where
6
7 import Cmm
8 import CmmExpr
9 import MkZipCfgCmm hiding (CmmGraph)
10 import ZipCfgCmmRep -- imported for reverse conversion
11 import CmmZipUtil
12 import PprCmm()
13 import PprCmmZ()
14 import qualified ZipCfg as G
15
16 import FastString
17 import Outputable
18 import Panic
19 import UniqSet
20 import UniqSupply
21
22 import Maybe
23
24 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
25 cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
26
27 cmmToZgraph = cmmMapGraphM toZgraph
28 cmmOfZgraph = cmmMapGraph ofZgraph
29
30
31 toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
32 toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
33 toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
34 labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
35 where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g
36 mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
37 mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
38 mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
39 mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
40 mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
41 mkCall f conv res args srt <*> mkStmts ss
42 mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
43 panic "safe call to a primitive CmmPrim CallishMachOp"
44 mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
45 mkUnsafeCall f res args <*> mkStmts ss
46 mkStmts (CmmCondBranch e l : fbranch) =
47 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
48 mkStmts (last : []) = mkLast last
49 mkStmts [] = bad "fell off end"
50 mkStmts (_ : _ : _) = bad "last node not at end"
51 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
52 mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
53 mkFinalCall f conv args
54 mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
55 panic "Call to CmmPrim never returns?!"
56 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
57 mkLast (CmmJump tgt args) = mkJump tgt args
58 mkLast (CmmReturn ress) = mkReturn ress
59 mkLast (CmmBranch tgt) = mkBranch tgt
60 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
61 panic "Call never returns but has results?!"
62 mkLast _ = panic "fell off end of block"
63
64 ofZgraph :: CmmGraph -> ListGraph CmmStmt
65 ofZgraph g = ListGraph $ swallow blocks
66 where blocks = G.postorder_dfs g
67 -- | the next two functions are hooks on which to hang debugging info
68 extend_entry stmts = stmts
69 extend_block _id stmts = stmts
70 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
71 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
72 concat (map (\(G.Block id _) -> " " ++ show id) blocks)
73 cscomm = "Call successors are" ++
74 (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
75 swallow [] = []
76 swallow (G.Block id t : rest) = tail id [] Nothing t rest
77 tail id prev' out (G.ZTail (CopyOut conv actuals) t) rest =
78 case out of
79 Nothing -> tail id prev' (Just (conv, actuals)) t rest
80 Just _ -> panic "multiple CopyOut nodes in one basic block"
81 tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest
82 tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest
83 tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out l rest
84 mid (MidNop) = CmmNop
85 mid (MidComment s) = CmmComment s
86 mid (MidAssign l r) = CmmAssign l r
87 mid (MidStore l r) = CmmStore l r
88 mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
89 mid m@(CopyOut {}) = pcomment (ppr m)
90 mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
91 pcomment p = scomment $ showSDoc p
92 block' id prev'
93 | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
94 | otherwise = BasicBlock id $ extend_block id (reverse prev')
95 last id prev' out l n =
96 let endblock stmt = block' id (stmt : prev') : swallow n in
97 case l of
98 LastBranch _ (_:_) -> panic "unrepresentable branch"
99 LastBranch tgt [] ->
100 case n of
101 G.Block id' t : bs
102 | tgt == id', unique_pred id'
103 -> tail id prev' out t bs -- optimize out redundant labels
104 _ -> if isNothing out then endblock (CmmBranch tgt)
105 else pprPanic "can't convert LGraph with pending CopyOut"
106 (ppr g)
107 LastCondBranch expr tid fid ->
108 if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
109 else
110 case n of
111 G.Block id' t : bs
112 | id' == fid, unique_pred id' ->
113 tail id (CmmCondBranch expr tid : prev') Nothing t bs
114 | id' == tid, unique_pred id',
115 Just e' <- maybeInvertCmmExpr expr ->
116 tail id (CmmCondBranch e' fid : prev') Nothing t bs
117 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
118 in block' id instrs' : swallow n
119 LastJump expr params -> endblock $ CmmJump expr params
120 LastReturn params -> endblock $ CmmReturn params
121 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
122 LastCall e cont
123 | Just (conv, args) <- out
124 -> let tgt = CmmCallee e (conv_to_cconv conv) in
125 case cont of
126 Nothing ->
127 endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
128 Just k
129 | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
130 id' == k, unique_pred k
131 -> let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
132 in tail id (call : prev') Nothing t bs
133 | G.Block id' t : bs <- n, id' == k, unique_pred k
134 -> let (ress, srt) = findCopyIn t
135 call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
136 delayed = scomment "delayed CopyIn follows prev. call"
137 in tail id (delayed : call : prev') Nothing t bs
138 | otherwise -> panic "unrepairable call"
139 | otherwise -> panic "call with no CopyOut"
140 findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
141 findCopyIn (G.ZTail _ t) = findCopyIn t
142 findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
143 exit id prev' out n = -- highly irregular (assertion violation?)
144 let endblock stmt = block' id (stmt : prev') : swallow n in
145 case n of [] -> endblock (scomment "procedure falls off end")
146 G.Block id' t : bs ->
147 if unique_pred id' then
148 tail id (scomment "went thru exit" : prev') out t bs
149 else
150 endblock (CmmBranch id')
151 conv_to_cconv (ConventionStandard c _) = c
152 conv_to_cconv (ConventionPrivate {}) =
153 panic "tried to convert private calling convention back to Cmm"
154 preds = zipPreds g
155 single_preds =
156 let add b single =
157 let id = G.blockId b
158 in case G.lookupBlockEnv preds id of
159 Nothing -> single
160 Just s -> if sizeUniqSet s == 1 then
161 G.extendBlockSet single id
162 else single
163 in G.fold_blocks add G.emptyBlockSet g
164 unique_pred id = G.elemBlockSet id single_preds
165 call_succs =
166 let add b succs =
167 case G.last (G.unzip b) of
168 G.LastOther (LastCall _ (Just id)) -> extendBlockSet succs id
169 _ -> succs
170 in G.fold_blocks add emptyBlockSet g
171 _is_call_succ id = elemBlockSet id call_succs
172
173 scomment :: String -> CmmStmt
174 scomment s = CmmComment $ mkFastString s