1 {-# LANGUAGE PatternGuards #-}
4 ( cmmToZgraph, cmmOfZgraph )
10 import MkZipCfgCmm hiding (CmmGraph)
11 import ZipCfg -- imported for reverse conversion
12 import ZipCfgCmmRep -- imported for reverse conversion
15 import qualified ZipCfg as G
25 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
26 cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
28 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
29 where mapTop (CmmProc h l args g) =
30 toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
31 mapTop (CmmData s ds) = return $ CmmData s ds
32 cmmOfZgraph = cmmMapGraph (ofZgraph . snd)
34 toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
35 toZgraph _ _ (ListGraph []) =
36 do g <- lgraphOfAGraph emptyAGraph
37 return ((0, Nothing), g)
38 toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
39 let (offset, entry) = mkEntry id NativeNodeCall args in
40 do g <- labelAGraph id $
41 entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
42 return ((offset, Nothing), g)
43 where addBlock (BasicBlock id ss) g =
44 mkLabel id <*> mkStmts ss <*> g
45 updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
46 mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
47 mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
48 mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
49 mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
50 mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
51 mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz
53 where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
54 mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
55 panic "safe call to a primitive CmmPrim CallishMachOp"
56 mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
57 mkUnsafeCall (convert_target f res args)
58 (strip_hints res) (strip_hints args)
60 mkStmts (CmmCondBranch e l : fbranch) =
61 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
62 mkStmts (last : []) = mkLast last
63 mkStmts [] = bad "fell off end"
64 mkStmts (_ : _ : _) = bad "last node not at end"
65 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
66 mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
67 mkFinalCall f conv (map hintlessCmm args) updfr_sz
68 mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
69 panic "Call to CmmPrim never returns?!"
70 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
71 -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
72 -- CONVENTIONS ARE HONORED?
73 mkLast (CmmJump tgt args) = mkJump tgt (map hintlessCmm args) updfr_sz
74 mkLast (CmmReturn ress) =
75 mkReturnSimple (map hintlessCmm ress) updfr_sz
76 mkLast (CmmBranch tgt) = mkBranch tgt
77 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
78 panic "Call never returns but has results?!"
79 mkLast _ = panic "fell off end of block"
81 strip_hints :: [CmmHinted a] -> [a]
82 strip_hints = map hintlessCmm
84 convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
85 convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
86 convert_target (CmmPrim op) _ress _args = PrimTarget op
88 add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
89 add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
91 get_hints :: Convention -> ValueDirection -> [ForeignHint]
92 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
93 get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
94 get_hints _other_conv _vd = repeat NoHint
96 get_conv :: MidCallTarget -> Convention
97 get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
98 get_conv (ForeignTarget _ fc) = Foreign fc
100 cmm_target :: MidCallTarget -> CmmCallTarget
101 cmm_target (PrimTarget op) = CmmPrim op
102 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
104 ofZgraph :: CmmGraph -> ListGraph CmmStmt
105 ofZgraph g = ListGraph $ swallow blocks
106 where blocks = G.postorder_dfs g
107 -- | the next two functions are hooks on which to hang debugging info
108 extend_entry stmts = stmts
109 extend_block _id stmts = stmts
110 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
111 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
112 concat (map (\(G.Block id _) -> " " ++ show id) blocks)
113 cscomm = "Call successors are" ++
114 (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
116 swallow (G.Block id t : rest) = tail id [] t rest
117 tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
118 tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
119 tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
120 mid (MidComment s) = CmmComment s
121 mid (MidAssign l r) = CmmAssign l r
122 mid (MidStore l r) = CmmStore l r
123 mid (MidForeignCall _ target ress args)
124 = CmmCall (cmm_target target)
125 (add_hints conv Results ress)
126 (add_hints conv Arguments args)
127 CmmUnsafe CmmMayReturn
129 conv = get_conv target
131 | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
132 | otherwise = BasicBlock id $ extend_block id (reverse prev')
134 let endblock stmt = block' id (stmt : prev') : swallow n in
138 -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
139 --G.Block id' _ t : bs
140 -- | tgt == id', unique_pred id'
141 -- -> tail id prev' t bs -- optimize out redundant labels
142 _ -> endblock (CmmBranch tgt)
143 LastCondBranch expr tid fid ->
146 -- It would be better to handle earlier, but we still must
147 -- generate correct code here.
148 | id' == fid, tid == fid, unique_pred id' ->
150 | id' == fid, unique_pred id' ->
151 tail id (CmmCondBranch expr tid : prev') t bs
152 | id' == tid, unique_pred id',
153 Just e' <- maybeInvertCmmExpr expr ->
154 tail id (CmmCondBranch e' fid : prev') t bs
155 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
156 in block' id instrs' : swallow n
157 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
158 LastCall e _ _ _ _ -> endblock $ CmmJump e []
159 exit id prev' n = -- highly irregular (assertion violation?)
160 let endblock stmt = block' id (stmt : prev') : swallow n in
161 case n of [] -> endblock (scomment "procedure falls off end")
162 G.Block id' t : bs ->
163 if unique_pred id' then
164 tail id (scomment "went thru exit" : prev') t bs
166 endblock (CmmBranch id')
171 in case lookupBlockEnv preds id of
173 Just s -> if sizeBlockSet s == 1 then
174 extendBlockSet single id
176 in G.fold_blocks add emptyBlockSet g
177 unique_pred id = elemBlockSet id single_preds
180 case G.last (G.unzip b) of
181 G.LastOther (LastCall _ (Just id) _ _ _) ->
182 extendBlockSet succs id
184 in G.fold_blocks add emptyBlockSet g
185 _is_call_succ id = elemBlockSet id call_succs
187 scomment :: String -> CmmStmt
188 scomment s = CmmComment $ mkFastString s