3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
6 ( cmmToZgraph, cmmOfZgraph )
14 import qualified OldCmm as Old
17 import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
24 cmmToZgraph :: Old.Cmm -> UniqSM Cmm
25 cmmOfZgraph :: Cmm -> Old.Cmm
27 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
28 where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
29 do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
30 return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
31 mapTop (CmmData s ds) = return $ CmmData s ds
32 cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
33 where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
34 mapTop (CmmData s ds) = CmmData s ds
36 toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
37 toZgraph _ (Old.ListGraph []) =
38 do g <- lgraphOfAGraph emptyAGraph
39 return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
40 toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
41 let (offset, entry) = mkCallEntry NativeNodeCall [] in
42 do g <- labelAGraph id $
43 entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
44 return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
45 where addBlock (Old.BasicBlock id ss) g =
46 mkLabel id <*> mkStmts ss <*> g
47 updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
48 mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss
49 mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss
50 mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
51 mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss
52 mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
53 mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
55 where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
56 mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
57 panic "safe call to a primitive CmmPrim CallishMachOp"
58 mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
59 mkUnsafeCall (convert_target f res args)
60 (strip_hints res) (strip_hints args)
62 mkStmts (Old.CmmCondBranch e l : fbranch) =
63 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
64 mkStmts (last : []) = mkLast last
65 mkStmts [] = bad "fell off end"
66 mkStmts (_ : _ : _) = bad "last node not at end"
67 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
68 mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
69 mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
70 mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
71 panic "Call to CmmPrim never returns?!"
72 mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
73 -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
74 -- CONVENTIONS ARE HONORED?
75 mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz
76 mkLast (Old.CmmReturn ress) =
77 mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
78 mkLast (Old.CmmBranch tgt) = mkBranch tgt
79 mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
80 panic "Call never returns but has results?!"
81 mkLast _ = panic "fell off end of block"
83 strip_hints :: [Old.CmmHinted a] -> [a]
84 strip_hints = map Old.hintlessCmm
86 convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget
87 convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
88 convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
90 data ValueDirection = Arguments | Results
92 add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
93 add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
95 get_hints :: Convention -> ValueDirection -> [ForeignHint]
96 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
97 get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
98 get_hints _other_conv _vd = repeat NoHint
100 get_conv :: ForeignTarget -> Convention
101 get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
102 get_conv (ForeignTarget _ fc) = Foreign fc
104 cmm_target :: ForeignTarget -> Old.CmmCallTarget
105 cmm_target (PrimTarget op) = Old.CmmPrim op
106 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
108 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
109 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
110 -- We catenated some blocks in the conversion process,
111 -- because of the CmmCondBranch -- the machine code does not have
112 -- 'jump here or there' instruction, but has 'jump if true' instruction.
113 -- As OldCmm has the same instruction, so we use it.
114 -- When we are doing this, we also catenate normal goto-s (it is for free).
116 -- Exactly, we catenate blocks with nonentry labes, that are
117 -- a) mentioned exactly once as a successor
118 -- b) any of 1) are a target of a goto
119 -- 2) are false branch target of a conditional jump
120 -- 3) are true branch target of a conditional jump, and
121 -- the false branch target is a successor of at least 2 blocks
122 -- and the condition can be inverted
123 -- The complicated rule 3) is here because we need to assign at most one
124 -- catenable block to a CmmCondBranch.
125 where preds :: BlockEnv [CmmNode O C]
126 preds = mapFold add mapEmpty $ toBlockMap g
127 where add block env = foldr (add' $ lastNode block) env (successors block)
128 add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
129 add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
131 to_be_catenated :: BlockId -> Bool
132 to_be_catenated id | id == g_entry g = False
133 | Just [CmmBranch _] <- mapLookup id preds = True
134 | Just [CmmCondBranch _ _ f] <- mapLookup id preds
136 | Just [CmmCondBranch e t f] <- mapLookup id preds
138 , Just (_:_:_) <- mapLookup f preds
139 , Just _ <- maybeInvertCmmExpr e = True
140 to_be_catenated _ = False
142 convert_block block | to_be_catenated (entryLabel block) = Nothing
143 convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
144 where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
145 first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
147 middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
148 middle node stmts = stmt : stmts
149 where stmt :: Old.CmmStmt
151 CmmComment s -> Old.CmmComment s
152 CmmAssign l r -> Old.CmmAssign l r
153 CmmStore l r -> Old.CmmStore l r
154 CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
155 CmmUnsafeForeignCall target ress args ->
156 Old.CmmCall (cmm_target target)
157 (add_hints (get_conv target) Results ress)
158 (add_hints (get_conv target) Arguments args)
159 Old.CmmUnsafe Old.CmmMayReturn
161 last :: CmmNode O C -> () -> [Old.CmmStmt]
163 where stmts :: [Old.CmmStmt]
165 CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
166 | otherwise -> [Old.CmmBranch tgt]
167 CmmCondBranch expr tid fid
168 | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
169 | to_be_catenated tid
170 , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
171 | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
172 CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
173 CmmCall e _ _ _ _ -> [Old.CmmJump e []]
174 CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
175 tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
176 Old.BasicBlock _ stmts -> stmts
177 where Just block = mapLookup bid $ toBlockMap g