Remove the implementation of gmp primops from the rts
[ghc-hetmet.git] / compiler / cmm / CmmCvt.hs
1 {-# LANGUAGE PatternGuards #-}
2
3 module CmmCvt
4   ( cmmToZgraph, cmmOfZgraph )
5 where
6
7 import BlockId
8 import Cmm
9 import CmmExpr
10 import MkZipCfgCmm hiding (CmmGraph)
11 import ZipCfg       -- imported for reverse conversion
12 import ZipCfgCmmRep -- imported for reverse conversion
13 import CmmZipUtil
14 import PprCmm()
15 import qualified ZipCfg as G
16
17 import FastString
18 import Monad
19 import Outputable
20 import Panic
21 import UniqSupply
22
23 import Maybe
24
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)
27
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)
33
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
52             <*> mkStmts ss 
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)
59                       <*> mkStmts ss
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"
80
81 strip_hints :: [CmmHinted a] -> [a]
82 strip_hints = map hintlessCmm
83
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
87
88 add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
89 add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
90
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
95
96 get_conv :: MidCallTarget -> Convention
97 get_conv (PrimTarget _)       = NativeNodeCall -- JD: SUSPICIOUS
98 get_conv (ForeignTarget _ fc) = Foreign fc
99
100 cmm_target :: MidCallTarget -> CmmCallTarget
101 cmm_target (PrimTarget op) = CmmPrim op
102 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
103
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)
115           swallow [] = []
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
128                 where
129                   conv = get_conv target
130           block' id prev'
131               | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')
132               | otherwise          = BasicBlock id $ extend_block id (reverse prev')
133           last id prev' l n =
134             let endblock stmt = block' id (stmt : prev') : swallow n in
135             case l of
136               LastBranch tgt ->
137                   case n of
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 ->
144                   case n of
145                     G.Block id' t : bs
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' ->
149                                  tail id prev' t bs
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 
165                             else
166                                 endblock (CmmBranch id')
167           preds = zipPreds g
168           single_preds =
169               let add b single =
170                     let id = G.blockId b
171                     in  case lookupBlockEnv preds id of
172                           Nothing -> single
173                           Just s -> if sizeBlockSet s == 1 then
174                                         extendBlockSet single id
175                                     else single
176               in  G.fold_blocks add emptyBlockSet g
177           unique_pred id = elemBlockSet id single_preds
178           call_succs = 
179               let add b succs =
180                       case G.last (G.unzip b) of
181                         G.LastOther (LastCall _ (Just id) _ _ _) ->
182                           extendBlockSet succs id
183                         _ -> succs
184               in  G.fold_blocks add emptyBlockSet g
185           _is_call_succ id = elemBlockSet id call_succs
186
187 scomment :: String -> CmmStmt
188 scomment s = CmmComment $ mkFastString s