adding new files to do with new cmm functionality
[ghc.git] / compiler / cmm / CmmCvt.hs
1 {-# LANGUAGE PatternGuards #-}
2 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
3
4 module CmmCvt
5 ( cmmToZgraph, cmmOfZgraph )
6 where
7 import Cmm
8 import CmmExpr
9 import ZipCfgCmm
10 import MkZipCfg
11 import CmmZipUtil
12 import FastString
13 import Outputable
14 import Panic
15 import PprCmm()
16 import PprCmmZ()
17 import UniqSet
18 import UniqSupply
19 import qualified ZipCfg as G
20
21 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
22 cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
23
24 cmmToZgraph = cmmMapGraphM toZgraph
25 cmmOfZgraph = cmmMapGraph ofZgraph
26
27
28 toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
29 toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
30 toZgraph fun_name (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 mkIfThenElse (mkCbranch 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 = panic (msg {- ++ " in block " ++ showSDoc (ppr b) -}
47 ++ " in function " ++ fun_name)
48 mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args
49 mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
50 mkLast (CmmJump tgt args) = mkJump tgt args
51 mkLast (CmmReturn ress) = mkReturn ress
52 mkLast (CmmBranch tgt) = mkBranch tgt
53 mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
54 panic "Call never returns but has results?!"
55 mkLast _ = panic "fell off end of block"
56
57 ofZgraph :: CmmGraph -> ListGraph CmmStmt
58 ofZgraph g = ListGraph $ swallow blocks
59 where blocks = G.postorder_dfs g
60 -- | the next two functions are hooks on which to hang debugging info
61 extend_entry stmts = stmts
62 extend_block _id stmts = stmts
63 _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
64 showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
65 concat (map (\(G.Block id _) -> " " ++ show id) blocks)
66 cscomm = "Call successors are" ++
67 (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
68 swallow [] = []
69 swallow (G.Block id t : rest) = tail id [] t rest
70 tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
71 tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
72 tail id prev' (G.ZLast (G.LastOther l))rest = last id prev' l rest
73 mid (MidNop) = CmmNop
74 mid (MidComment s) = CmmComment s
75 mid (MidAssign l r) = CmmAssign l r
76 mid (MidStore l r) = CmmStore l r
77 mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
78 mid m@(CopyOut {}) = pcomment (ppr m)
79 mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
80 pcomment p = scomment $ showSDoc p
81 block' id prev'
82 | id == G.gr_entry g = BasicBlock id $ extend_entry (reverse prev')
83 | otherwise = BasicBlock id $ extend_block id (reverse prev')
84 last id prev' l n =
85 let endblock stmt = block' id (stmt : prev') : swallow n in
86 case l of
87 LastBranch _ (_:_) -> panic "unrepresentable branch"
88 LastBranch tgt [] ->
89 case n of
90 G.Block id' t : bs
91 | tgt == id', unique_pred id'
92 -> tail id prev' t bs -- optimize out redundant labels
93 _ -> endblock (CmmBranch tgt)
94 LastCondBranch expr tid fid ->
95 case n of
96 G.Block id' t : bs
97 | id' == fid, unique_pred id' ->
98 tail id (CmmCondBranch expr tid : prev') t bs
99 | id' == tid, unique_pred id',
100 Just e' <- maybeInvertCmmExpr expr ->
101 tail id (CmmCondBranch e' fid : prev') t bs
102 _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
103 in block' id instrs' : swallow n
104 LastJump expr params -> endblock $ CmmJump expr params
105 LastReturn params -> endblock $ CmmReturn params
106 LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
107 LastCall tgt args Nothing ->
108 endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
109 LastCall tgt args (Just k)
110 | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
111 id' == k, unique_pred k ->
112 let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
113 in tail id (call : prev') t bs
114 | G.Block id' t : bs <- n, id' == k, unique_pred k ->
115 let (ress, srt) = findCopyIn t
116 call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
117 delayed = scomment "delayed CopyIn follows previous call"
118 in tail id (delayed : call : prev') t bs
119 | otherwise -> panic "unrepairable call"
120 findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
121 findCopyIn (G.ZTail _ t) = findCopyIn t
122 findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
123 exit id prev' n = -- highly irregular (assertion violation?)
124 let endblock stmt = block' id (stmt : prev') : swallow n in
125 case n of [] -> endblock (scomment "procedure falls off end")
126 G.Block id' t : bs ->
127 if unique_pred id' then
128 tail id (scomment "went thru exit" : prev') t bs
129 else
130 endblock (CmmBranch id')
131 preds = zipPreds g
132 single_preds =
133 let add b single =
134 let id = G.blockId b
135 in case G.lookupBlockEnv preds id of
136 Nothing -> single
137 Just s -> if sizeUniqSet s == 1 then
138 G.extendBlockSet single id
139 else single
140 in G.fold_blocks add G.emptyBlockSet g
141 unique_pred id = G.elemBlockSet id single_preds
142 call_succs =
143 let add b succs =
144 case G.last (G.unzip b) of
145 G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
146 _ -> succs
147 in G.fold_blocks add emptyBlockSet g
148 _is_call_succ id = elemBlockSet id call_succs
149
150 scomment :: String -> CmmStmt
151 scomment s = CmmComment $ mkFastString s