1 {-# LANGUAGE PatternGuards #-}
4 ( cmmToZgraph, cmmOfZgraph )
8 import ClosureInfo (C_SRT(..))
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
36 toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph
37 toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph
38 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
39 let (offset, entry) = mkEntry id Native args in
40 labelAGraph id offset $
41 entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
42 where addBlock (BasicBlock id ss) g = mkLabel id Nothing <*> 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 (map hintlessCmm res) (map hintlessCmm 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 (convert_target f res args)
53 (strip_hints res) (strip_hints args) <*> mkStmts ss
54 mkStmts (CmmCondBranch e l : fbranch) =
55 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
56 mkStmts (last : []) = mkLast last
57 mkStmts [] = bad "fell off end"
58 mkStmts (_ : _ : _) = bad "last node not at end"
59 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
60 mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
61 mkFinalCall f conv $ map hintlessCmm args
62 mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
63 panic "Call to CmmPrim never returns?!"
64 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
65 -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
66 -- CONVENTIONS ARE HONORED?
67 mkLast (CmmJump tgt args) = mkJump tgt $ map hintlessCmm args
68 mkLast (CmmReturn ress) = mkReturn $ map hintlessCmm ress
69 mkLast (CmmBranch tgt) = mkBranch tgt
70 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
71 panic "Call never returns but has results?!"
72 mkLast _ = panic "fell off end of block"
74 strip_hints :: [CmmHinted a] -> [a]
75 strip_hints = map hintlessCmm
77 convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
78 convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
79 convert_target (CmmPrim op) _ress _args = PrimTarget op
81 add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
82 add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
84 get_hints :: Convention -> ValueDirection -> [ForeignHint]
85 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
86 get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
87 get_hints _other_conv _vd = repeat NoHint
89 get_conv :: MidCallTarget -> Convention
90 get_conv (PrimTarget _) = Native
91 get_conv (ForeignTarget _ fc) = Foreign fc
93 cmm_target :: MidCallTarget -> CmmCallTarget
94 cmm_target (PrimTarget op) = CmmPrim op
95 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
97 ofZgraph :: CmmGraph -> ListGraph CmmStmt
98 ofZgraph g = ListGraph $ swallow blocks
99 where blocks = G.postorder_dfs g
100 -- | the next two functions are hooks on which to hang debugging info
101 extend_entry stmts = stmts
102 extend_block _id stmts = stmts
103 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
104 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
105 concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
106 cscomm = "Call successors are" ++
107 (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
109 swallow (G.Block id _ t : rest) = tail id [] t rest
110 tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
111 tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
112 tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
113 mid (MidComment s) = CmmComment s
114 mid (MidAssign l r) = CmmAssign l r
115 mid (MidStore l r) = CmmStore l r
116 mid (MidUnsafeCall target ress args)
117 = CmmCall (cmm_target target)
118 (add_hints conv Results ress)
119 (add_hints conv Arguments args)
120 CmmUnsafe CmmMayReturn
122 conv = get_conv target
123 mid m@(MidAddToContext {}) = pcomment (ppr m)
124 pcomment p = scomment $ showSDoc p
126 | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
127 | otherwise = BasicBlock id $ extend_block id (reverse prev')
129 let endblock stmt = block' id (stmt : prev') : swallow n in
133 -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
134 --G.Block id' _ t : bs
135 -- | tgt == id', unique_pred id'
136 -- -> tail id prev' t bs -- optimize out redundant labels
137 _ -> endblock (CmmBranch tgt)
138 LastCondBranch expr tid fid ->
141 | id' == fid, unique_pred id' ->
142 tail id (CmmCondBranch expr tid : prev') t bs
143 | id' == tid, unique_pred id',
144 Just e' <- maybeInvertCmmExpr expr ->
145 tail id (CmmCondBranch e' fid : prev') t bs
146 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
147 in block' id instrs' : swallow n
148 LastJump expr _ -> endblock $ CmmJump expr []
149 LastReturn _ -> endblock $ CmmReturn []
150 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
152 let tgt = CmmCallee e CCallConv in
155 endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns
157 endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn
158 exit id prev' n = -- highly irregular (assertion violation?)
159 let endblock stmt = block' id (stmt : prev') : swallow n in
160 case n of [] -> endblock (scomment "procedure falls off end")
161 G.Block id' _ t : bs ->
162 if unique_pred id' then
163 tail id (scomment "went thru exit" : prev') t bs
165 endblock (CmmBranch id')
170 in case lookupBlockEnv preds id of
172 Just s -> if sizeUniqSet s == 1 then
173 extendBlockSet single id
175 in G.fold_blocks add emptyBlockSet g
176 unique_pred id = elemBlockSet id single_preds
179 case G.last (G.unzip b) of
180 G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id
182 in G.fold_blocks add emptyBlockSet g
183 _is_call_succ id = elemBlockSet id call_succs
185 scomment :: String -> CmmStmt
186 scomment s = CmmComment $ mkFastString s