2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
4 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
6 -- Module for building CmmAGraphs.
8 -- As the CmmAGraph is a wrapper over Graph CmmNode O x, it is different
9 -- from Hoopl's AGraph. The current clients expect functions with the
10 -- same names Hoopl uses, so this module cannot be in the same namespace
15 , emptyAGraph, (<*>), catAGraphs, outOfLine
16 , mkLabel, mkMiddle, mkLast
17 , withFreshLabel, withUnique, lgraphOfAGraph, labelAGraph
20 , mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
21 , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
22 , mkReturn, mkReturnSimple, mkComment, mkCallEntry
23 , mkBranch, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
24 , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
25 -- Reexport of needed Cmm stuff
26 , Convention(..), ForeignConvention(..), ForeignTarget(..)
27 , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..)
36 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
38 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
39 import qualified Compiler.Hoopl as H
40 import Compiler.Hoopl.GHC (uniqueToLbl)
44 import Prelude hiding (succ)
45 import SMRep (ByteOff)
50 #include "HsVersions.h"
53 A 'CmmAGraph' is an abstract version of a 'Graph CmmNode O x' from module
54 'Cmm'. The difference is that the 'CmmAGraph' can be eigher open of closed at
55 exit and it can supply fresh Labels and Uniques.
57 It also supports a splicing operation <*>, which is different from the Hoopl's
58 <*>, because it splices two CmmAGraphs. Specifically, it can splice Graph
59 O C and Graph O x. In this case, the open beginning of the second graph is
60 thrown away. In the debug mode this sequence is checked to be empty or
61 containing a branch (see note [Branch follows branch]).
63 When an CmmAGraph open at exit is being converted to a CmmGraph, the output
64 exit sequence is considered unreachable. If the graph consist of one block
65 only, if it not the case and we crash. Otherwise we just throw the exit
66 sequence away (and in debug mode we test that it really was unreachable).
70 Node [Branch follows branch]
71 ============================
72 Why do we say it's ok for a Branch to follow a Branch?
73 Because the standard constructor mkLabel has fall-through
74 semantics. So if you do a mkLabel, you finish the current block,
75 giving it a label, and start a new one that branches to that label.
76 Emitting a Branch at this point is fine:
77 goto L1; L2: ...stuff...
80 data CmmGraphOC = Opened (Graph CmmNode O O)
81 | Closed (Graph CmmNode O C)
82 type CmmAGraph = UniqSM CmmGraphOC -- Graph open at entry
86 newtype CmmAGraph = forall x. AG (UniqSM (Graph CmmNode O x))
87 but that does not work well, because we cannot take the graph
88 out of the monad -- we do not know the type of what we would take
89 out and pattern matching does not help, as we cannot pattern match
90 on a graph inside the monad.
93 data Transfer = Call | Jump | Ret deriving Eq
95 ---------- AGraph manipulation
97 emptyAGraph :: CmmAGraph
98 (<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
99 catAGraphs :: [CmmAGraph] -> CmmAGraph
101 mkLabel :: BlockId -> CmmAGraph -- created a sequence "goto id; id:" as an AGraph
102 mkMiddle :: CmmNode O O -> CmmAGraph -- creates an open AGraph from a given node
103 mkLast :: CmmNode O C -> CmmAGraph -- created a closed AGraph from a given node
105 withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
106 withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
108 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
109 -- ^ allocate a fresh label for the entry point
110 labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
111 -- ^ use the given BlockId as the label of the entry point
115 mkComment :: FastString -> CmmAGraph
117 ---------- Assignment and store
118 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
119 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
122 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] ->
123 UpdFrameOffset -> CmmAGraph
124 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] ->
125 UpdFrameOffset -> CmmAGraph
126 -- Native C-- calling convention
127 mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> Bool -> CmmAGraph
128 mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
129 mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
130 -- Never returns; like exit() or barf()
132 ---------- Control transfer
133 mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
134 mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
135 mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
136 mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
137 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
138 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
139 mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
140 mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
142 mkBranch :: BlockId -> CmmAGraph
143 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
144 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
145 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
147 outOfLine :: CmmAGraph -> CmmAGraph
148 -- ^ The argument is an CmmAGraph that must have an
149 -- empty entry sequence and be closed at the end.
150 -- The result is a new CmmAGraph that is open at the
151 -- end and goes directly from entry to exit, with the
152 -- original graph sitting to the side out-of-line.
154 -- Example: mkMiddle (x = 3)
155 -- <*> outOfLine (mkLabel L <*> ...stuff...)
156 -- <*> mkMiddle (y = x)
157 -- Control will flow directly from x=3 to y=x;
158 -- the block starting with L is "on the side".
160 -- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
162 --------------------------------------------------------------------------
164 -- ================ IMPLEMENTATION ================--
166 --------------------------------------------------
167 -- Raw CmmAGraph handling
169 emptyAGraph = return $ Opened emptyGraph
170 ag <*> ah = do g <- ag
172 return (case (g, h) of
173 (Opened g, Opened h) -> Opened $ g H.<*> h
174 (Opened g, Closed h) -> Closed $ g H.<*> h
175 (Closed g, Opened GNil) -> Closed g
176 (Closed g, Opened (GUnit e)) -> note_unreachable e $ Closed g
177 (Closed g, Opened (GMany (JustO e) b x)) -> note_unreachable e $ Opened $ g H.|*><*| GMany NothingO b x
178 (Closed g, Closed (GMany (JustO e) b x)) -> note_unreachable e $ Closed $ g H.|*><*| GMany NothingO b x
180 catAGraphs = foldl (<*>) emptyAGraph
182 outOfLine ag = withFreshLabel "outOfLine" $ \l ->
185 Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
186 GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
187 _ -> panic "outOfLine"
190 note_unreachable :: Block CmmNode O x -> a -> a
191 note_unreachable block graph =
192 ASSERT (block_is_empty_or_label) -- Note [Branch follows branch]
194 where block_is_empty_or_label :: Bool
195 block_is_empty_or_label = case blockToNodeList block of
196 (NothingC, [], NothingC) -> True
197 (NothingC, [], JustC (CmmBranch _)) -> True
200 mkLabel bid = return $ Opened $ H.mkLast (CmmBranch bid) |*><*| H.mkFirst (CmmEntry bid)
201 mkMiddle middle = return $ Opened $ H.mkMiddle middle
202 mkLast last = return $ Closed $ H.mkLast last
204 withUnique f = getUniqueM >>= f
205 withFreshLabel _name f = getUniqueM >>= f . uniqueToLbl . intToUnique . getKey
207 lgraphOfAGraph g = do u <- getUniqueM
208 labelAGraph (mkBlockId u) g
210 labelAGraph lbl ag = do g <- ag
211 return $ CmmGraph {g_entry=lbl, g_graph=H.mkFirst (CmmEntry lbl) H.<*> closed g}
212 where closed :: CmmGraphOC -> Graph CmmNode O C
213 closed (Closed g) = g
214 closed (Opened g@(GMany entry body (JustO exit))) =
215 ASSERT (entryLabel exit `notElem` map entryLabel (postorder_dfs g))
216 GMany entry body NothingO
217 closed (Opened _) = panic "labelAGraph"
219 --------------------------------------------------
220 -- CmmAGraph constructions
223 mkComment fs = mkMiddle $ CmmComment fs
224 mkStore l r = mkMiddle $ CmmStore l r
226 -- NEED A COMPILER-DEBUGGING FLAG HERE
227 -- Sanity check: any value assigned to a pointer must be non-zero.
228 -- If it's 0, cause a crash immediately.
229 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
230 where assign l r = mkMiddle (CmmAssign l r)
231 check (CmmGlobal _) = mkNop
232 check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
233 if isGcPtrType ty then
234 mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
235 (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
237 where ty = localRegType reg
242 -- Why are we inserting extra blocks that simply branch to the successors?
243 -- Because in addition to the branch instruction, @mkBranch@ will insert
244 -- a necessary adjustment to the stack pointer.
245 mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
246 mkSwitch e tbl = mkLast $ CmmSwitch e tbl
248 mkSafeCall t fs as upd i = withFreshLabel "safe call" $ body
251 ( mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth))
252 (CmmLit (CmmBlock k))
253 <*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i})
255 mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
257 mkBranch bid = mkLast (CmmBranch bid)
259 mkCmmIfThenElse e tbranch fbranch =
260 withFreshLabel "end of if" $ \endif ->
261 withFreshLabel "start of then" $ \tid ->
262 withFreshLabel "start of else" $ \fid ->
263 mkCbranch e tid fid <*>
264 mkLabel tid <*> tbranch <*> mkBranch endif <*>
265 mkLabel fid <*> fbranch <*> mkLabel endif
267 mkCmmIfThen e tbranch
268 = withFreshLabel "end of if" $ \endif ->
269 withFreshLabel "start of then" $ \tid ->
270 mkCbranch e tid endif <*>
271 mkLabel tid <*> tbranch <*> mkLabel endif
273 mkCmmWhileDo e body =
274 withFreshLabel "loop test" $ \test ->
275 withFreshLabel "loop head" $ \head ->
276 withFreshLabel "end while" $ \endwhile ->
277 -- Forrest Baskett's while-loop layout
278 mkBranch test <*> mkLabel head <*> body
279 <*> mkLabel test <*> mkCbranch e head endwhile
282 -- For debugging purposes, we can stub out dead stack slots:
283 stackStubExpr :: Width -> CmmExpr
284 stackStubExpr w = CmmLit (CmmInt 0 w)
286 -- When we copy in parameters, we usually want to put overflow
287 -- parameters on the stack, but sometimes we want to pass
288 -- the variables in their spill slots.
289 -- Therefore, for copying arguments and results, we provide different
290 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
291 copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
292 copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O]
293 copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
295 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
296 where (offset, nodes) = copyIn oneCopyOflowI conv area formals
297 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
299 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
300 (ByteOff, [CmmNode O O])
301 type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
303 -- Return the number of bytes used for copying arguments, as well as the
304 -- instructions to copy the arguments.
306 copyIn oflow conv area formals =
307 foldr ci (init_offset, []) args'
308 where ci (reg, RegisterParam r) (n, ms) =
309 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
310 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
311 init_offset = widthInBytes wordWidth -- infotable
312 args = assignArgumentsPos conv localRegType formals
313 args' = foldl adjust [] args
314 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
315 adjust rst x@(_, RegisterParam _) = x : rst
317 -- Copy-in one arg, using overflow space if needed.
318 oneCopyOflowI, oneCopySlotI :: SlotCopier
319 oneCopyOflowI area (reg, off) (n, ms) =
320 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
321 where ty = localRegType reg
323 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
324 -- a procpoint that is not a return point. The offset is irrelevant here...
325 oneCopySlotI _ (reg, _) (n, ms) =
326 (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
327 where ty = localRegType reg
328 w = widthInBytes (typeWidth ty)
331 -- Factoring out the common parts of the copyout functions yielded something
334 copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset ->
336 -- Generate code to move the actual parameters into the locations
337 -- required by the calling convention. This includes a store for the return address.
339 -- The argument layout function ignores the pointer to the info table, so we slot that
340 -- in here. When copying-out to a young area, we set the info table for return
341 -- and adjust the offsets of the other parameters.
342 -- If this is a call instruction, we adjust the offsets of the other parameters.
343 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off
344 = foldr co (init_offset, emptyAGraph) args'
346 co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
347 co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms)
349 (setRA, init_offset) =
350 case a of Young id -> id `seq` -- Generate a store instruction for
351 -- the return address if making a call
352 if transfer == Call then
353 ([(CmmLit (CmmBlock id), StackParam init_offset)],
354 widthInBytes wordWidth)
356 Old -> ([], updfr_off)
358 args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
359 args = assignArgumentsPos conv cmmExprType actuals
361 args' = foldl adjust setRA args
362 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
363 adjust rst x@(_, RegisterParam _) = x : rst
365 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
367 -- Args passed only in registers and stack slots; no overflow space.
368 -- No return address may apply!
369 copyOutSlot conv actuals = foldr co [] args
370 where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
371 co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
372 toExp r = CmmReg (CmmLocal r)
373 args = assignArgumentsPos conv localRegType actuals
375 mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
376 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
378 lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset ->
379 (ByteOff -> CmmAGraph) -> CmmAGraph
380 lastWithArgs transfer area conv actuals updfr_off last =
381 let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
382 copies <*> last outArgs
384 -- The area created for the jump and return arguments is the same area as the
388 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
389 toCall e cont updfr_off res_space arg_space =
390 mkLast $ CmmCall e cont arg_space res_space updfr_off
391 mkJump e actuals updfr_off =
392 lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
393 mkDirectJump e actuals updfr_off =
394 lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
395 mkJumpGC e actuals updfr_off =
396 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
397 mkForeignJump conv e actuals updfr_off =
398 lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
399 mkReturn e actuals updfr_off =
400 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
401 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
402 mkReturnSimple actuals updfr_off =
403 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
404 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
406 mkFinalCall f _ actuals updfr_off =
407 lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
409 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
411 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
412 mkCall f (callConv, retConv) results actuals updfr_off =
413 withFreshLabel "call successor" $ \k ->
414 let area = CallArea $ Young k
415 (off, copyin) = copyInOflow retConv area results
416 copyout = lastWithArgs Call area callConv actuals updfr_off
417 (toCall f (Just k) updfr_off off)
418 in (copyout <*> mkLabel k <*> copyin)