1 {-# LANGUAGE PatternGuards #-}
4 ( cmmToZgraph, cmmOfZgraph )
11 import MkZipCfgCmm hiding (CmmGraph)
12 import ZipCfgCmmRep -- imported for reverse conversion
16 import qualified ZipCfg as G
27 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
28 cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
30 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
31 where mapTop (CmmProc h l args g) =
32 toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
33 mapTop (CmmData s ds) = return $ CmmData s ds
34 cmmOfZgraph = cmmMapGraph ofZgraph
37 toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
38 toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
39 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
40 labelAGraph id $ mkMiddles (mkEntry area undefined args) <*>
41 mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
42 where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g
43 mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
44 mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
45 mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
46 mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
47 mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
48 mkCall f conv res args srt <*> mkStmts ss
49 mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
50 panic "safe call to a primitive CmmPrim CallishMachOp"
51 mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
52 mkUnsafeCall f res args <*> mkStmts ss
53 mkStmts (CmmCondBranch e l : fbranch) =
54 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
55 mkStmts (last : []) = mkLast last
56 mkStmts [] = bad "fell off end"
57 mkStmts (_ : _ : _) = bad "last node not at end"
58 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
59 mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
60 mkFinalCall f conv args
61 mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
62 panic "Call to CmmPrim never returns?!"
63 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
64 mkLast (CmmJump tgt args) = mkJump area tgt args
65 mkLast (CmmReturn ress) = mkReturn area ress
66 mkLast (CmmBranch tgt) = mkBranch tgt
67 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
68 panic "Call never returns but has results?!"
69 mkLast _ = panic "fell off end of block"
70 -- The entry, jump, and return areas should be the same.
71 -- This code is horrible, but there's no point trying to fix it until we've figured
72 -- out our interface for calling conventions.
73 -- All return statements are required to use return areas of equal size.
74 -- This isn't necessarily required to write correct programs, but it's sane.
75 area = case foldr retBlock (retStmts ss Nothing) other_blocks of
76 Just (as, _) -> mkCallArea id as $ Just args
77 Nothing -> mkCallArea id [] $ Just args
78 retBlock (BasicBlock _ ss) z = retStmts ss z
79 retStmts [CmmReturn ress] z@(Just (_, n)) =
80 if size ress == n then z
81 else panic "return statements in C-- procs must return the same results"
82 retStmts [CmmReturn ress] Nothing = Just (ress, size ress)
83 retStmts (_ : rst) z = retStmts rst z
85 size args = areaSize $ mkCallArea id args Nothing
87 ofZgraph :: CmmGraph -> ListGraph CmmStmt
88 ofZgraph g = ListGraph $ swallow blocks
89 where blocks = G.postorder_dfs g
90 -- | the next two functions are hooks on which to hang debugging info
91 extend_entry stmts = stmts
92 extend_block _id stmts = stmts
93 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
94 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
95 concat (map (\(G.Block id _) -> " " ++ show id) blocks)
96 cscomm = "Call successors are" ++
97 (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
99 swallow (G.Block id t : rest) = tail id [] Nothing t rest
100 tail id prev' out (G.ZTail (CopyOut conv actuals) t) rest =
102 Nothing -> tail id prev' (Just (conv, actuals)) t rest
103 Just _ -> panic "multiple CopyOut nodes in one basic block"
104 tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest
105 tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest
106 tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out l rest
107 mid (MidComment s) = CmmComment s
108 mid (MidAssign l r) = CmmAssign l r
109 mid (MidStore l r) = CmmStore l r
110 mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
111 mid m@(MidAddToContext {}) = pcomment (ppr m)
112 mid m@(CopyOut {}) = pcomment (ppr m)
113 mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
114 pcomment p = scomment $ showSDoc p
116 | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
117 | otherwise = BasicBlock id $ extend_block id (reverse prev')
118 last id prev' out l n =
119 let endblock stmt = block' id (stmt : prev') : swallow n in
124 | tgt == id', unique_pred id'
125 -> tail id prev' out t bs -- optimize out redundant labels
126 _ -> if isNothing out then endblock (CmmBranch tgt)
127 else pprPanic "can't convert LGraph with pending CopyOut"
128 (text "target" <+> ppr tgt <+> ppr g)
129 LastCondBranch expr tid fid ->
130 if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
134 | id' == fid, unique_pred id' ->
135 tail id (CmmCondBranch expr tid : prev') Nothing t bs
136 | id' == tid, unique_pred id',
137 Just e' <- maybeInvertCmmExpr expr ->
138 tail id (CmmCondBranch e' fid : prev') Nothing t bs
139 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
140 in block' id instrs' : swallow n
141 LastJump expr -> endblock $ with_out out $ CmmJump expr
142 LastReturn -> endblock $ with_out out $ CmmReturn
143 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
145 | Just (conv, args) <- out
146 -> let tgt = CmmCallee e (conv_to_cconv conv) in
149 endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
151 | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
152 id' == k, unique_pred k
153 -> let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
154 in tail id (call : prev') Nothing t bs
155 | G.Block id' t : bs <- n, id' == k, unique_pred k
156 -> let (ress, srt) = findCopyIn t
157 call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
158 delayed = scomment "delayed CopyIn follows prev. call"
159 in tail id (delayed : call : prev') Nothing t bs
160 | otherwise -> panic "unrepairable call"
161 | otherwise -> panic "call with no CopyOut"
162 with_out (Just (_conv, actuals)) f = f actuals
163 with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f [])
164 findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
165 findCopyIn (G.ZTail _ t) = findCopyIn t
166 findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
167 exit id prev' out n = -- highly irregular (assertion violation?)
168 let endblock stmt = block' id (stmt : prev') : swallow n in
169 case n of [] -> endblock (scomment "procedure falls off end")
170 G.Block id' t : bs ->
171 if unique_pred id' then
172 tail id (scomment "went thru exit" : prev') out t bs
174 endblock (CmmBranch id')
175 conv_to_cconv (ConventionStandard c _) = c
176 conv_to_cconv (ConventionPrivate {}) =
177 panic "tried to convert private calling convention back to Cmm"
182 in case lookupBlockEnv preds id of
184 Just s -> if sizeUniqSet s == 1 then
185 extendBlockSet single id
187 in G.fold_blocks add emptyBlockSet g
188 unique_pred id = elemBlockSet id single_preds
191 case G.last (G.unzip b) of
192 G.LastOther (LastCall _ (Just id)) -> extendBlockSet succs id
194 in G.fold_blocks add emptyBlockSet g
195 _is_call_succ id = elemBlockSet id call_succs
197 scomment :: String -> CmmStmt
198 scomment s = CmmComment $ mkFastString s