Cleanup StgCmm pass
[ghc.git] / compiler / codeGen / StgCmmMonad.hs
1 {-# LANGUAGE GADTs #-}
2 -----------------------------------------------------------------------------
3 --
4 -- Monad for Stg to C-- code generation
5 --
6 -- (c) The University of Glasgow 2004-2006
7 --
8 -----------------------------------------------------------------------------
9
10 module StgCmmMonad (
11 FCode, -- type
12
13 initC, runC, thenC, thenFC, listCs,
14 returnFC, fixC,
15 newUnique, newUniqSupply,
16
17 newLabelC, emitLabel,
18
19 emit, emitDecl, emitProc,
20 emitProcWithConvention, emitProcWithStackFrame,
21 emitOutOfLine, emitAssign, emitStore, emitComment,
22
23 getCmm, aGraphToGraph,
24 getCodeR, getCode, getHeapUsage,
25
26 mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
27 mkCall, mkCmmCall,
28
29 forkClosureBody, forkAlts, forkProc, codeOnly,
30
31 ConTagZ,
32
33 Sequel(..), ReturnKind(..),
34 withSequel, getSequel,
35
36 setTickyCtrLabel, getTickyCtrLabel,
37
38 withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
39
40 HeapUsage(..), VirtualHpOffset, initHpUsage,
41 getHpUsage, setHpUsage, heapHWM,
42 setVirtHp, getVirtHp, setRealHp,
43
44 getModuleName,
45
46 -- ideally we wouldn't export these, but some other modules access internal state
47 getState, setState, getInfoDown, getDynFlags, getThisPackage,
48
49 -- more localised access to monad state
50 CgIdInfo(..), CgLoc(..),
51 getBinds, setBinds,
52
53 -- out of general friendliness, we also export ...
54 CgInfoDownwards(..), CgState(..) -- non-abstract
55 ) where
56
57 #include "HsVersions.h"
58
59 import Cmm
60 import StgCmmClosure
61 import DynFlags
62 import Hoopl
63 import MkGraph
64 import BlockId
65 import CLabel
66 import SMRep
67 import Module
68 import Id
69 import VarEnv
70 import OrdList
71 import Unique
72 import UniqSupply
73 import FastString
74 import Outputable
75
76 import Control.Monad
77 import Data.List
78 import Prelude hiding( sequence, succ )
79
80 infixr 9 `thenC` -- Right-associative!
81 infixr 9 `thenFC`
82
83
84 --------------------------------------------------------
85 -- The FCode monad and its types
86 --
87 -- FCode is the monad plumbed through the Stg->Cmm code generator, and
88 -- the Cmm parser. It contains the following things:
89 --
90 -- - A writer monad, collecting:
91 -- - code for the current function, in the form of a CmmAGraph.
92 -- The function "emit" appends more code to this.
93 -- - the top-level CmmDecls accumulated so far
94 --
95 -- - A state monad with:
96 -- - the local bindings in scope
97 -- - the current heap usage
98 -- - a UniqSupply
99 --
100 -- - A reader monad, for CgInfoDownwards, containing
101 -- - DynFlags,
102 -- - the current Module
103 -- - the static top-level environmnet
104 -- - the update-frame offset
105 -- - the ticky counter label
106 -- - the Sequel (the continuation to return to)
107
108
109 --------------------------------------------------------
110
111 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
112
113 instance Functor FCode where
114 fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
115
116 instance Monad FCode where
117 (>>=) = thenFC
118 return = returnFC
119
120 {-# INLINE thenC #-}
121 {-# INLINE thenFC #-}
122 {-# INLINE returnFC #-}
123
124 initC :: IO CgState
125 initC = do { uniqs <- mkSplitUniqSupply 'c'
126 ; return (initCgState uniqs) }
127
128 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
129 runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
130
131 returnFC :: a -> FCode a
132 returnFC val = FCode (\_info_down state -> (# val, state #))
133
134 thenC :: FCode () -> FCode a -> FCode a
135 thenC (FCode m) (FCode k) =
136 FCode $ \info_down state -> case m info_down state of
137 (# _,new_state #) -> k info_down new_state
138
139 listCs :: [FCode ()] -> FCode ()
140 listCs [] = return ()
141 listCs (fc:fcs) = do
142 fc
143 listCs fcs
144
145 thenFC :: FCode a -> (a -> FCode c) -> FCode c
146 thenFC (FCode m) k = FCode $
147 \info_down state ->
148 case m info_down state of
149 (# m_result, new_state #) ->
150 case k m_result of
151 FCode kcode -> kcode info_down new_state
152
153 fixC :: (a -> FCode a) -> FCode a
154 fixC fcode = FCode (
155 \info_down state ->
156 let
157 (v,s) = doFCode (fcode v) info_down state
158 in
159 (# v, s #)
160 )
161
162 --------------------------------------------------------
163 -- The code generator environment
164 --------------------------------------------------------
165
166 -- This monadery has some information that it only passes
167 -- *downwards*, as well as some ``state'' which is modified
168 -- as we go along.
169
170 data CgInfoDownwards -- information only passed *downwards* by the monad
171 = MkCgInfoDown {
172 cgd_dflags :: DynFlags,
173 cgd_mod :: Module, -- Module being compiled
174 cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
175 cgd_ticky :: CLabel, -- Current destination for ticky counts
176 cgd_sequel :: Sequel -- What to do at end of basic block
177 }
178
179 type CgBindings = IdEnv CgIdInfo
180
181 data CgIdInfo
182 = CgIdInfo
183 { cg_id :: Id -- Id that this is the info for
184 -- Can differ from the Id at occurrence sites by
185 -- virtue of being externalised, for splittable C
186 , cg_lf :: LambdaFormInfo
187 , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
188 }
189
190 data CgLoc
191 = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
192 -- Hp, so that it remains valid across calls
193
194 | LneLoc BlockId [LocalReg] -- A join point
195 -- A join point (= let-no-escape) should only
196 -- be tail-called, and in a saturated way.
197 -- To tail-call it, assign to these locals,
198 -- and branch to the block id
199
200 instance Outputable CgIdInfo where
201 ppr (CgIdInfo { cg_id = id, cg_loc = loc })
202 = ppr id <+> ptext (sLit "-->") <+> ppr loc
203
204 instance Outputable CgLoc where
205 ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e
206 ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
207
208
209 -- Sequel tells what to do with the result of this expression
210 data Sequel
211 = Return Bool -- Return result(s) to continuation found on the stack
212 -- True <=> the continuation is update code (???)
213
214 | AssignTo
215 [LocalReg] -- Put result(s) in these regs and fall through
216 -- NB: no void arguments here
217 --
218 Bool -- Should we adjust the heap pointer back to
219 -- recover space that's unused on this path?
220 -- We need to do this only if the expression
221 -- may allocate (e.g. it's a foreign call or
222 -- allocating primOp)
223
224 -- See Note [sharing continuations] below
225 data ReturnKind
226 = AssignedDirectly
227 | ReturnedTo BlockId ByteOff
228
229 -- Note [sharing continuations]
230 --
231 -- ReturnKind says how the expression being compiled returned its
232 -- results: either by assigning directly to the registers specified
233 -- by the Sequel, or by returning to a continuation that does the
234 -- assignments. The point of this is we might be able to re-use the
235 -- continuation in a subsequent heap-check. Consider:
236 --
237 -- case f x of z
238 -- True -> <True code>
239 -- False -> <False code>
240 --
241 -- Naively we would generate
242 --
243 -- R2 = x -- argument to f
244 -- Sp[young(L1)] = L1
245 -- call f returns to L1
246 -- L1:
247 -- z = R1
248 -- if (z & 1) then Ltrue else Lfalse
249 -- Ltrue:
250 -- Hp = Hp + 24
251 -- if (Hp > HpLim) then L4 else L7
252 -- L4:
253 -- HpAlloc = 24
254 -- goto L5
255 -- L5:
256 -- R1 = z
257 -- Sp[young(L6)] = L6
258 -- call stg_gc_unpt_r1 returns to L6
259 -- L6:
260 -- z = R1
261 -- goto L1
262 -- L7:
263 -- <True code>
264 -- Lfalse:
265 -- <False code>
266 --
267 -- We want the gc call in L4 to return to L1, and discard L6. Note
268 -- that not only can we share L1 and L6, but the assignment of the
269 -- return address in L4 is unnecessary because the return address for
270 -- L1 is already on the stack. We used to catch the sharing of L1 and
271 -- L6 in the common-block-eliminator, but not the unnecessary return
272 -- address assignment.
273 --
274 -- Since this case is so common I decided to make it more explicit and
275 -- robust by programming the sharing directly, rather than relying on
276 -- the common-block elimiantor to catch it. This makes
277 -- common-block-elimianteion an optional optimisation, and furthermore
278 -- generates less code in the first place that we have to subsequently
279 -- clean up.
280 --
281 -- There are some rarer cases of common blocks that we don't catch
282 -- this way, but that's ok. Common-block-elimation is still available
283 -- to catch them when optimisation is enabled. Some examples are:
284 --
285 -- - when both the True and False branches do a heap check, we
286 -- can share the heap-check failure code L4a and maybe L4
287 --
288 -- - in a case-of-case, there might be multiple continuations that
289 -- we can common up.
290 --
291 -- It is always safe to use AssignedDirectly. Expressions that jump
292 -- to the continuation from multiple places (e.g. case expressions)
293 -- fall back to AssignedDirectly.
294 --
295
296
297 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
298 initCgInfoDown dflags mod
299 = MkCgInfoDown { cgd_dflags = dflags
300 , cgd_mod = mod
301 , cgd_updfr_off = initUpdFrameOff dflags
302 , cgd_ticky = mkTopTickyCtrLabel
303 , cgd_sequel = initSequel }
304
305 initSequel :: Sequel
306 initSequel = Return False
307
308 initUpdFrameOff :: DynFlags -> UpdFrameOffset
309 initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
310
311
312 --------------------------------------------------------
313 -- The code generator state
314 --------------------------------------------------------
315
316 data CgState
317 = MkCgState {
318 cgs_stmts :: CmmAGraph, -- Current procedure
319
320 cgs_tops :: OrdList CmmDecl,
321 -- Other procedures and data blocks in this compilation unit
322 -- Both are ordered only so that we can
323 -- reduce forward references, when it's easy to do so
324
325 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
326 -- Bindings for top-level things are given in
327 -- the info-down part
328
329 cgs_hp_usg :: HeapUsage,
330
331 cgs_uniqs :: UniqSupply }
332
333 data HeapUsage =
334 HeapUsage {
335 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
336 -- Incremented whenever we allocate
337 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
338 -- Used in instruction addressing modes
339 }
340
341 type VirtualHpOffset = WordOff
342
343
344
345 initCgState :: UniqSupply -> CgState
346 initCgState uniqs
347 = MkCgState { cgs_stmts = mkNop
348 , cgs_tops = nilOL
349 , cgs_binds = emptyVarEnv
350 , cgs_hp_usg = initHpUsage
351 , cgs_uniqs = uniqs }
352
353 stateIncUsage :: CgState -> CgState -> CgState
354 -- stateIncUsage@ e1 e2 incorporates in e1
355 -- the heap high water mark found in e2.
356 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
357 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
358 `addCodeBlocksFrom` s2
359
360 addCodeBlocksFrom :: CgState -> CgState -> CgState
361 -- Add code blocks from the latter to the former
362 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
363 s1 `addCodeBlocksFrom` s2
364 = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
365 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
366
367
368 -- The heap high water mark is the larger of virtHp and hwHp. The latter is
369 -- only records the high water marks of forked-off branches, so to find the
370 -- heap high water mark you have to take the max of virtHp and hwHp. Remember,
371 -- virtHp never retreats!
372 --
373 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
374
375 heapHWM :: HeapUsage -> VirtualHpOffset
376 heapHWM = virtHp
377
378 initHpUsage :: HeapUsage
379 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
380
381 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
382 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
383
384 --------------------------------------------------------
385 -- Operators for getting and setting the state and "info_down".
386 --------------------------------------------------------
387
388 getState :: FCode CgState
389 getState = FCode $ \_info_down state -> (# state, state #)
390
391 setState :: CgState -> FCode ()
392 setState state = FCode $ \_info_down _ -> (# (), state #)
393
394 getHpUsage :: FCode HeapUsage
395 getHpUsage = do
396 state <- getState
397 return $ cgs_hp_usg state
398
399 setHpUsage :: HeapUsage -> FCode ()
400 setHpUsage new_hp_usg = do
401 state <- getState
402 setState $ state {cgs_hp_usg = new_hp_usg}
403
404 setVirtHp :: VirtualHpOffset -> FCode ()
405 setVirtHp new_virtHp
406 = do { hp_usage <- getHpUsage
407 ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
408
409 getVirtHp :: FCode VirtualHpOffset
410 getVirtHp
411 = do { hp_usage <- getHpUsage
412 ; return (virtHp hp_usage) }
413
414 setRealHp :: VirtualHpOffset -> FCode ()
415 setRealHp new_realHp
416 = do { hp_usage <- getHpUsage
417 ; setHpUsage (hp_usage {realHp = new_realHp}) }
418
419 getBinds :: FCode CgBindings
420 getBinds = do
421 state <- getState
422 return $ cgs_binds state
423
424 setBinds :: CgBindings -> FCode ()
425 setBinds new_binds = do
426 state <- getState
427 setState $ state {cgs_binds = new_binds}
428
429 withState :: FCode a -> CgState -> FCode (a,CgState)
430 withState (FCode fcode) newstate = FCode $ \info_down state ->
431 case fcode info_down newstate of
432 (# retval, state2 #) -> (# (retval,state2), state #)
433
434 newUniqSupply :: FCode UniqSupply
435 newUniqSupply = do
436 state <- getState
437 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
438 setState $ state { cgs_uniqs = us1 }
439 return us2
440
441 newUnique :: FCode Unique
442 newUnique = do
443 state <- getState
444 let (u,us') = takeUniqFromSupply (cgs_uniqs state)
445 setState $ state { cgs_uniqs = us' }
446 return u
447
448 ------------------
449 getInfoDown :: FCode CgInfoDownwards
450 getInfoDown = FCode $ \info_down state -> (# info_down,state #)
451
452 instance HasDynFlags FCode where
453 getDynFlags = liftM cgd_dflags getInfoDown
454
455 getThisPackage :: FCode PackageId
456 getThisPackage = liftM thisPackage getDynFlags
457
458 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
459 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
460
461 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
462 doFCode (FCode fcode) info_down state =
463 case fcode info_down state of
464 (# a, s #) -> ( a, s )
465
466 -- ----------------------------------------------------------------------------
467 -- Get the current module name
468
469 getModuleName :: FCode Module
470 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
471
472 -- ----------------------------------------------------------------------------
473 -- Get/set the end-of-block info
474
475 withSequel :: Sequel -> FCode a -> FCode a
476 withSequel sequel code
477 = do { info <- getInfoDown
478 ; withInfoDown code (info {cgd_sequel = sequel }) }
479
480 getSequel :: FCode Sequel
481 getSequel = do { info <- getInfoDown
482 ; return (cgd_sequel info) }
483
484 -- ----------------------------------------------------------------------------
485 -- Get/set the size of the update frame
486
487 -- We keep track of the size of the update frame so that we
488 -- can set the stack pointer to the proper address on return
489 -- (or tail call) from the closure.
490 -- There should be at most one update frame for each closure.
491 -- Note: I'm including the size of the original return address
492 -- in the size of the update frame -- hence the default case on `get'.
493
494 withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
495 withUpdFrameOff size code
496 = do { info <- getInfoDown
497 ; withInfoDown code (info {cgd_updfr_off = size }) }
498
499 getUpdFrameOff :: FCode UpdFrameOffset
500 getUpdFrameOff
501 = do { info <- getInfoDown
502 ; return $ cgd_updfr_off info }
503
504 -- ----------------------------------------------------------------------------
505 -- Get/set the current ticky counter label
506
507 getTickyCtrLabel :: FCode CLabel
508 getTickyCtrLabel = do
509 info <- getInfoDown
510 return (cgd_ticky info)
511
512 setTickyCtrLabel :: CLabel -> FCode a -> FCode a
513 setTickyCtrLabel ticky code = do
514 info <- getInfoDown
515 withInfoDown code (info {cgd_ticky = ticky})
516
517
518 --------------------------------------------------------
519 -- Forking
520 --------------------------------------------------------
521
522 forkClosureBody :: FCode () -> FCode ()
523 -- forkClosureBody takes a code, $c$, and compiles it in a
524 -- fresh environment, except that:
525 -- - compilation info and statics are passed in unchanged.
526 -- - local bindings are passed in unchanged
527 -- (it's up to the enclosed code to re-bind the
528 -- free variables to a field of the closure)
529 --
530 -- The current state is passed on completely unaltered, except that
531 -- C-- from the fork is incorporated.
532
533 forkClosureBody body_code
534 = do { dflags <- getDynFlags
535 ; info <- getInfoDown
536 ; us <- newUniqSupply
537 ; state <- getState
538 ; let body_info_down = info { cgd_sequel = initSequel
539 , cgd_updfr_off = initUpdFrameOff dflags }
540 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
541 ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
542 ; setState $ state `addCodeBlocksFrom` fork_state_out }
543
544 forkProc :: FCode a -> FCode a
545 -- 'forkProc' takes a code and compiles it in the *current* environment,
546 -- returning the graph thus constructed.
547 --
548 -- The current environment is passed on completely unchanged to
549 -- the successor. In particular, any heap usage from the enclosed
550 -- code is discarded; it should deal with its own heap consumption
551 forkProc body_code
552 = do { info_down <- getInfoDown
553 ; us <- newUniqSupply
554 ; state <- getState
555 ; let info_down' = info_down -- { cgd_sequel = initSequel }
556 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
557 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
558 ; setState $ state `addCodeBlocksFrom` fork_state_out
559 ; return result }
560
561 codeOnly :: FCode () -> FCode ()
562 -- Emit any code from the inner thing into the outer thing
563 -- Do not affect anything else in the outer state
564 -- Used in almost-circular code to prevent false loop dependencies
565 codeOnly body_code
566 = do { info_down <- getInfoDown
567 ; us <- newUniqSupply
568 ; state <- getState
569 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
570 cgs_hp_usg = cgs_hp_usg state }
571 ((), fork_state_out) = doFCode body_code info_down fork_state_in
572 ; setState $ state `addCodeBlocksFrom` fork_state_out }
573
574 forkAlts :: [FCode a] -> FCode [a]
575 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
576 -- an fcode for the default case 'd', and compiles each in the current
577 -- environment. The current environment is passed on unmodified, except
578 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
579
580 forkAlts branch_fcodes
581 = do { info_down <- getInfoDown
582 ; us <- newUniqSupply
583 ; state <- getState
584 ; let compile us branch
585 = (us2, doFCode branch info_down branch_state)
586 where
587 (us1,us2) = splitUniqSupply us
588 branch_state = (initCgState us1) {
589 cgs_binds = cgs_binds state,
590 cgs_hp_usg = cgs_hp_usg state }
591
592 (_us, results) = mapAccumL compile us branch_fcodes
593 (branch_results, branch_out_states) = unzip results
594 ; setState $ foldl stateIncUsage state branch_out_states
595 -- NB foldl. state is the *left* argument to stateIncUsage
596 ; return branch_results }
597
598 -- collect the code emitted by an FCode computation
599 getCodeR :: FCode a -> FCode (a, CmmAGraph)
600 getCodeR fcode
601 = do { state1 <- getState
602 ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
603 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
604 ; return (a, cgs_stmts state2) }
605
606 getCode :: FCode a -> FCode CmmAGraph
607 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
608
609 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
610 -- It initialises the heap usage to zeros, and passes on an unchanged
611 -- heap usage.
612 --
613 -- It is usually a prelude to performing a GC check, so everything must
614 -- be in a tidy and consistent state.
615 --
616 -- Note the slightly subtle fixed point behaviour needed here
617
618 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
619 getHeapUsage fcode
620 = do { info_down <- getInfoDown
621 ; state <- getState
622 ; let fstate_in = state { cgs_hp_usg = initHpUsage }
623 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
624 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
625
626 ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
627 ; return r }
628
629 -- ----------------------------------------------------------------------------
630 -- Combinators for emitting code
631
632 emitCgStmt :: CgStmt -> FCode ()
633 emitCgStmt stmt
634 = do { state <- getState
635 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
636 }
637
638 emitLabel :: BlockId -> FCode ()
639 emitLabel id = emitCgStmt (CgLabel id)
640
641 emitComment :: FastString -> FCode ()
642 #if 0 /* def DEBUG */
643 emitComment s = emitCgStmt (CgStmt (CmmComment s))
644 #else
645 emitComment _ = return ()
646 #endif
647
648 emitAssign :: CmmReg -> CmmExpr -> FCode ()
649 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
650
651 emitStore :: CmmExpr -> CmmExpr -> FCode ()
652 emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
653
654
655 newLabelC :: FCode BlockId
656 newLabelC = do { u <- newUnique
657 ; return $ mkBlockId u }
658
659 emit :: CmmAGraph -> FCode ()
660 emit ag
661 = do { state <- getState
662 ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
663
664 emitDecl :: CmmDecl -> FCode ()
665 emitDecl decl
666 = do { state <- getState
667 ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
668
669 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
670 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
671
672 emitProcWithStackFrame
673 :: Convention -- entry convention
674 -> Maybe CmmInfoTable -- info table?
675 -> CLabel -- label for the proc
676 -> [CmmFormal] -- stack frame
677 -> [CmmFormal] -- arguments
678 -> CmmAGraph -- code
679 -> Bool -- do stack layout?
680 -> FCode ()
681
682 emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
683 = do { dflags <- getDynFlags
684 ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
685 }
686 emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
687 = do { dflags <- getDynFlags
688 ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
689 ; emitProc_ mb_info lbl live (entry <*> blocks) offset True
690 }
691 emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
692
693 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
694 -> [CmmFormal]
695 -> CmmAGraph
696 -> FCode ()
697 emitProcWithConvention conv mb_info lbl args blocks
698 = emitProcWithStackFrame conv mb_info lbl [] args blocks True
699
700 emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
701 emitProc mb_info lbl live blocks offset
702 = emitProc_ mb_info lbl live blocks offset True
703
704 emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
705 -> FCode ()
706 emitProc_ mb_info lbl live blocks offset do_layout
707 = do { dflags <- getDynFlags
708 ; l <- newLabelC
709 ; let
710 blks = labelAGraph l blocks
711
712 infos | Just info <- mb_info = mapSingleton (g_entry blks) info
713 | otherwise = mapEmpty
714
715 sinfo = StackInfo { arg_space = offset
716 , updfr_space = Just (initUpdFrameOff dflags)
717 , do_layout = do_layout }
718
719 tinfo = TopInfo { info_tbls = infos
720 , stack_info=sinfo}
721
722 proc_block = CmmProc tinfo lbl live blks
723
724 ; state <- getState
725 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
726
727 getCmm :: FCode () -> FCode CmmGroup
728 -- Get all the CmmTops (there should be no stmts)
729 -- Return a single Cmm which may be split from other Cmms by
730 -- object splitting (at a later stage)
731 getCmm code
732 = do { state1 <- getState
733 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
734 ; setState $ state2 { cgs_tops = cgs_tops state1 }
735 ; return (fromOL (cgs_tops state2)) }
736
737
738 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
739 mkCmmIfThenElse e tbranch fbranch = do
740 endif <- newLabelC
741 tid <- newLabelC
742 fid <- newLabelC
743 return $ mkCbranch e tid fid <*>
744 mkLabel tid <*> tbranch <*> mkBranch endif <*>
745 mkLabel fid <*> fbranch <*> mkLabel endif
746
747 mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
748 mkCmmIfGoto e tid = do
749 endif <- newLabelC
750 return $ mkCbranch e tid endif <*> mkLabel endif
751
752 mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
753 mkCmmIfThen e tbranch = do
754 endif <- newLabelC
755 tid <- newLabelC
756 return $ mkCbranch e tid endif <*>
757 mkLabel tid <*> tbranch <*> mkLabel endif
758
759
760 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
761 -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph
762 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
763 dflags <- getDynFlags
764 k <- newLabelC
765 let area = Young k
766 (off, _, copyin) = copyInOflow dflags retConv area results []
767 copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
768 return (copyout <*> mkLabel k <*> copyin)
769
770 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
771 -> FCode CmmAGraph
772 mkCmmCall f results actuals updfr_off
773 = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
774
775
776 -- ----------------------------------------------------------------------------
777 -- turn CmmAGraph into CmmGraph, for making a new proc.
778
779 aGraphToGraph :: CmmAGraph -> FCode CmmGraph
780 aGraphToGraph stmts
781 = do { l <- newLabelC
782 ; return (labelAGraph l stmts) }