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) -> CmmFormals -> CmmActuals ->
123 UpdFrameOffset -> CmmAGraph
124 mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
125 UpdFrameOffset -> CmmAGraph
126 -- Native C-- calling convention
127 mkSafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
128 mkUnsafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> CmmAGraph
129 mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
130 -- Never returns; like exit() or barf()
132 ---------- Control transfer
133 mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
134 mkDirectJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
135 mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
136 mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
137 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
138 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
139 mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
140 mkReturnSimple :: CmmActuals -> 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 -> CmmFormals -> (Int, CmmAGraph)
292 copyInSlot :: Convention -> CmmFormals -> [CmmNode O O]
293 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
295 copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
297 copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
298 where (offset, nodes) = copyIn oneCopyOflowI conv area formals
299 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
301 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
302 (ByteOff, [CmmNode O O])
303 type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O])
305 -- Return the number of bytes used for copying arguments, as well as the
306 -- instructions to copy the arguments.
308 copyIn oflow conv area formals =
309 foldr ci (init_offset, []) args'
310 where ci (reg, RegisterParam r) (n, ms) =
311 (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
312 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
313 init_offset = widthInBytes wordWidth -- infotable
314 args = assignArgumentsPos conv localRegType formals
315 args' = foldl adjust [] args
316 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
317 adjust rst x@(_, RegisterParam _) = x : rst
319 -- Copy-in one arg, using overflow space if needed.
320 oneCopyOflowI, oneCopySlotI :: SlotCopier
321 oneCopyOflowI area (reg, off) (n, ms) =
322 (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
323 where ty = localRegType reg
325 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
326 -- a procpoint that is not a return point. The offset is irrelevant here...
327 oneCopySlotI _ (reg, _) (n, ms) =
328 (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
329 where ty = localRegType reg
330 w = widthInBytes (typeWidth ty)
333 -- Factoring out the common parts of the copyout functions yielded something
336 -- The argument layout function ignores the pointer to the info table, so we slot that
337 -- in here. When copying-out to a young area, we set the info table for return
338 -- and adjust the offsets of the other parameters.
339 -- If this is a call instruction, we adjust the offsets of the other parameters.
340 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
341 foldr co (init_offset, emptyAGraph) args'
342 where co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
343 co (v, StackParam off) (n, ms) =
344 (max n off, mkStore (CmmStackSlot area off) v <*> ms)
345 (setRA, init_offset) =
346 case a of Young id -> id `seq` -- set RA if making a call
347 if transfer == Call then
348 ([(CmmLit (CmmBlock id), StackParam init_offset)],
349 widthInBytes wordWidth)
351 Old -> ([], updfr_off)
352 args = assignArgumentsPos conv cmmExprType actuals
353 args' = foldl adjust setRA args
354 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
355 adjust rst x@(_, RegisterParam _) = x : rst
356 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
358 -- Args passed only in registers and stack slots; no overflow space.
359 -- No return address may apply!
360 copyOutSlot conv actuals = foldr co [] args
361 where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
362 co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
363 toExp r = CmmReg (CmmLocal r)
364 args = assignArgumentsPos conv localRegType actuals
366 mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph)
367 mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
369 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
370 (ByteOff -> CmmAGraph) -> CmmAGraph
371 lastWithArgs transfer area conv actuals updfr_off last =
372 let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
373 copies <*> last outArgs
375 -- The area created for the jump and return arguments is the same area as the
379 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
380 toCall e cont updfr_off res_space arg_space =
381 mkLast $ CmmCall e cont arg_space res_space updfr_off
382 mkJump e actuals updfr_off =
383 lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
384 mkDirectJump e actuals updfr_off =
385 lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
386 mkJumpGC e actuals updfr_off =
387 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
388 mkForeignJump conv e actuals updfr_off =
389 lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
390 mkReturn e actuals updfr_off =
391 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
392 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
393 mkReturnSimple actuals updfr_off =
394 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
395 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
397 mkFinalCall f _ actuals updfr_off =
398 lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
400 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
402 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
403 mkCall f (callConv, retConv) results actuals updfr_off =
404 withFreshLabel "call successor" $ \k ->
405 let area = CallArea $ Young k
406 (off, copyin) = copyInOflow retConv area results
407 copyout = lastWithArgs Call area callConv actuals updfr_off
408 (toCall f (Just k) updfr_off off)
409 in (copyout <*> mkLabel k <*> copyin)