Comments only
[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,
326
327 cgs_hp_usg :: HeapUsage,
328
329 cgs_uniqs :: UniqSupply }
330
331 data HeapUsage =
332 HeapUsage {
333 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
334 -- Incremented whenever we allocate
335 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
336 -- Used in instruction addressing modes
337 }
338
339 type VirtualHpOffset = WordOff
340
341
342
343 initCgState :: UniqSupply -> CgState
344 initCgState uniqs
345 = MkCgState { cgs_stmts = mkNop
346 , cgs_tops = nilOL
347 , cgs_binds = emptyVarEnv
348 , cgs_hp_usg = initHpUsage
349 , cgs_uniqs = uniqs }
350
351 stateIncUsage :: CgState -> CgState -> CgState
352 -- stateIncUsage@ e1 e2 incorporates in e1
353 -- the heap high water mark found in e2.
354 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
355 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
356 `addCodeBlocksFrom` s2
357
358 addCodeBlocksFrom :: CgState -> CgState -> CgState
359 -- Add code blocks from the latter to the former
360 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
361 s1 `addCodeBlocksFrom` s2
362 = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
363 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
364
365
366 -- The heap high water mark is the larger of virtHp and hwHp. The latter is
367 -- only records the high water marks of forked-off branches, so to find the
368 -- heap high water mark you have to take the max of virtHp and hwHp. Remember,
369 -- virtHp never retreats!
370 --
371 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
372
373 heapHWM :: HeapUsage -> VirtualHpOffset
374 heapHWM = virtHp
375
376 initHpUsage :: HeapUsage
377 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
378
379 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
380 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
381
382 --------------------------------------------------------
383 -- Operators for getting and setting the state and "info_down".
384 --------------------------------------------------------
385
386 getState :: FCode CgState
387 getState = FCode $ \_info_down state -> (# state, state #)
388
389 setState :: CgState -> FCode ()
390 setState state = FCode $ \_info_down _ -> (# (), state #)
391
392 getHpUsage :: FCode HeapUsage
393 getHpUsage = do
394 state <- getState
395 return $ cgs_hp_usg state
396
397 setHpUsage :: HeapUsage -> FCode ()
398 setHpUsage new_hp_usg = do
399 state <- getState
400 setState $ state {cgs_hp_usg = new_hp_usg}
401
402 setVirtHp :: VirtualHpOffset -> FCode ()
403 setVirtHp new_virtHp
404 = do { hp_usage <- getHpUsage
405 ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
406
407 getVirtHp :: FCode VirtualHpOffset
408 getVirtHp
409 = do { hp_usage <- getHpUsage
410 ; return (virtHp hp_usage) }
411
412 setRealHp :: VirtualHpOffset -> FCode ()
413 setRealHp new_realHp
414 = do { hp_usage <- getHpUsage
415 ; setHpUsage (hp_usage {realHp = new_realHp}) }
416
417 getBinds :: FCode CgBindings
418 getBinds = do
419 state <- getState
420 return $ cgs_binds state
421
422 setBinds :: CgBindings -> FCode ()
423 setBinds new_binds = do
424 state <- getState
425 setState $ state {cgs_binds = new_binds}
426
427 withState :: FCode a -> CgState -> FCode (a,CgState)
428 withState (FCode fcode) newstate = FCode $ \info_down state ->
429 case fcode info_down newstate of
430 (# retval, state2 #) -> (# (retval,state2), state #)
431
432 newUniqSupply :: FCode UniqSupply
433 newUniqSupply = do
434 state <- getState
435 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
436 setState $ state { cgs_uniqs = us1 }
437 return us2
438
439 newUnique :: FCode Unique
440 newUnique = do
441 state <- getState
442 let (u,us') = takeUniqFromSupply (cgs_uniqs state)
443 setState $ state { cgs_uniqs = us' }
444 return u
445
446 ------------------
447 getInfoDown :: FCode CgInfoDownwards
448 getInfoDown = FCode $ \info_down state -> (# info_down,state #)
449
450 instance HasDynFlags FCode where
451 getDynFlags = liftM cgd_dflags getInfoDown
452
453 getThisPackage :: FCode PackageId
454 getThisPackage = liftM thisPackage getDynFlags
455
456 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
457 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
458
459 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
460 doFCode (FCode fcode) info_down state =
461 case fcode info_down state of
462 (# a, s #) -> ( a, s )
463
464 -- ----------------------------------------------------------------------------
465 -- Get the current module name
466
467 getModuleName :: FCode Module
468 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
469
470 -- ----------------------------------------------------------------------------
471 -- Get/set the end-of-block info
472
473 withSequel :: Sequel -> FCode a -> FCode a
474 withSequel sequel code
475 = do { info <- getInfoDown
476 ; withInfoDown code (info {cgd_sequel = sequel }) }
477
478 getSequel :: FCode Sequel
479 getSequel = do { info <- getInfoDown
480 ; return (cgd_sequel info) }
481
482 -- ----------------------------------------------------------------------------
483 -- Get/set the size of the update frame
484
485 -- We keep track of the size of the update frame so that we
486 -- can set the stack pointer to the proper address on return
487 -- (or tail call) from the closure.
488 -- There should be at most one update frame for each closure.
489 -- Note: I'm including the size of the original return address
490 -- in the size of the update frame -- hence the default case on `get'.
491
492 withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
493 withUpdFrameOff size code
494 = do { info <- getInfoDown
495 ; withInfoDown code (info {cgd_updfr_off = size }) }
496
497 getUpdFrameOff :: FCode UpdFrameOffset
498 getUpdFrameOff
499 = do { info <- getInfoDown
500 ; return $ cgd_updfr_off info }
501
502 -- ----------------------------------------------------------------------------
503 -- Get/set the current ticky counter label
504
505 getTickyCtrLabel :: FCode CLabel
506 getTickyCtrLabel = do
507 info <- getInfoDown
508 return (cgd_ticky info)
509
510 setTickyCtrLabel :: CLabel -> FCode a -> FCode a
511 setTickyCtrLabel ticky code = do
512 info <- getInfoDown
513 withInfoDown code (info {cgd_ticky = ticky})
514
515
516 --------------------------------------------------------
517 -- Forking
518 --------------------------------------------------------
519
520 forkClosureBody :: FCode () -> FCode ()
521 -- forkClosureBody takes a code, $c$, and compiles it in a
522 -- fresh environment, except that:
523 -- - compilation info and statics are passed in unchanged.
524 -- - local bindings are passed in unchanged
525 -- (it's up to the enclosed code to re-bind the
526 -- free variables to a field of the closure)
527 --
528 -- The current state is passed on completely unaltered, except that
529 -- C-- from the fork is incorporated.
530
531 forkClosureBody body_code
532 = do { dflags <- getDynFlags
533 ; info <- getInfoDown
534 ; us <- newUniqSupply
535 ; state <- getState
536 ; let body_info_down = info { cgd_sequel = initSequel
537 , cgd_updfr_off = initUpdFrameOff dflags }
538 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
539 ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
540 ; setState $ state `addCodeBlocksFrom` fork_state_out }
541
542 forkProc :: FCode a -> FCode a
543 -- 'forkProc' takes a code and compiles it in the *current* environment,
544 -- returning the graph thus constructed.
545 --
546 -- The current environment is passed on completely unchanged to
547 -- the successor. In particular, any heap usage from the enclosed
548 -- code is discarded; it should deal with its own heap consumption.
549 -- forkProc is used to compile let-no-escape bindings.
550 forkProc body_code
551 = do { info_down <- getInfoDown
552 ; us <- newUniqSupply
553 ; state <- getState
554 ; let info_down' = info_down -- { cgd_sequel = initSequel }
555 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
556 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
557 ; setState $ state `addCodeBlocksFrom` fork_state_out
558 ; return result }
559
560 codeOnly :: FCode () -> FCode ()
561 -- Emit any code from the inner thing into the outer thing
562 -- Do not affect anything else in the outer state
563 -- Used in almost-circular code to prevent false loop dependencies
564 codeOnly body_code
565 = do { info_down <- getInfoDown
566 ; us <- newUniqSupply
567 ; state <- getState
568 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
569 cgs_hp_usg = cgs_hp_usg state }
570 ((), fork_state_out) = doFCode body_code info_down fork_state_in
571 ; setState $ state `addCodeBlocksFrom` fork_state_out }
572
573 forkAlts :: [FCode a] -> FCode [a]
574 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
575 -- an fcode for the default case 'd', and compiles each in the current
576 -- environment. The current environment is passed on unmodified, except
577 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
578
579 forkAlts branch_fcodes
580 = do { info_down <- getInfoDown
581 ; us <- newUniqSupply
582 ; state <- getState
583 ; let compile us branch
584 = (us2, doFCode branch info_down branch_state)
585 where
586 (us1,us2) = splitUniqSupply us
587 branch_state = (initCgState us1) {
588 cgs_binds = cgs_binds state,
589 cgs_hp_usg = cgs_hp_usg state }
590
591 (_us, results) = mapAccumL compile us branch_fcodes
592 (branch_results, branch_out_states) = unzip results
593 ; setState $ foldl stateIncUsage state branch_out_states
594 -- NB foldl. state is the *left* argument to stateIncUsage
595 ; return branch_results }
596
597 -- collect the code emitted by an FCode computation
598 getCodeR :: FCode a -> FCode (a, CmmAGraph)
599 getCodeR fcode
600 = do { state1 <- getState
601 ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
602 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
603 ; return (a, cgs_stmts state2) }
604
605 getCode :: FCode a -> FCode CmmAGraph
606 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
607
608 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
609 -- It initialises the heap usage to zeros, and passes on an unchanged
610 -- heap usage.
611 --
612 -- It is usually a prelude to performing a GC check, so everything must
613 -- be in a tidy and consistent state.
614 --
615 -- Note the slightly subtle fixed point behaviour needed here
616
617 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
618 getHeapUsage fcode
619 = do { info_down <- getInfoDown
620 ; state <- getState
621 ; let fstate_in = state { cgs_hp_usg = initHpUsage }
622 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
623 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
624
625 ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
626 ; return r }
627
628 -- ----------------------------------------------------------------------------
629 -- Combinators for emitting code
630
631 emitCgStmt :: CgStmt -> FCode ()
632 emitCgStmt stmt
633 = do { state <- getState
634 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
635 }
636
637 emitLabel :: BlockId -> FCode ()
638 emitLabel id = emitCgStmt (CgLabel id)
639
640 emitComment :: FastString -> FCode ()
641 #if 0 /* def DEBUG */
642 emitComment s = emitCgStmt (CgStmt (CmmComment s))
643 #else
644 emitComment _ = return ()
645 #endif
646
647 emitAssign :: CmmReg -> CmmExpr -> FCode ()
648 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
649
650 emitStore :: CmmExpr -> CmmExpr -> FCode ()
651 emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
652
653
654 newLabelC :: FCode BlockId
655 newLabelC = do { u <- newUnique
656 ; return $ mkBlockId u }
657
658 emit :: CmmAGraph -> FCode ()
659 emit ag
660 = do { state <- getState
661 ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
662
663 emitDecl :: CmmDecl -> FCode ()
664 emitDecl decl
665 = do { state <- getState
666 ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
667
668 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
669 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
670
671 emitProcWithStackFrame
672 :: Convention -- entry convention
673 -> Maybe CmmInfoTable -- info table?
674 -> CLabel -- label for the proc
675 -> [CmmFormal] -- stack frame
676 -> [CmmFormal] -- arguments
677 -> CmmAGraph -- code
678 -> Bool -- do stack layout?
679 -> FCode ()
680
681 emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
682 = do { dflags <- getDynFlags
683 ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
684 }
685 emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
686 = do { dflags <- getDynFlags
687 ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
688 ; emitProc_ mb_info lbl live (entry <*> blocks) offset True
689 }
690 emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
691
692 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
693 -> [CmmFormal]
694 -> CmmAGraph
695 -> FCode ()
696 emitProcWithConvention conv mb_info lbl args blocks
697 = emitProcWithStackFrame conv mb_info lbl [] args blocks True
698
699 emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
700 emitProc mb_info lbl live blocks offset
701 = emitProc_ mb_info lbl live blocks offset True
702
703 emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
704 -> FCode ()
705 emitProc_ mb_info lbl live blocks offset do_layout
706 = do { dflags <- getDynFlags
707 ; l <- newLabelC
708 ; let
709 blks = labelAGraph l blocks
710
711 infos | Just info <- mb_info = mapSingleton (g_entry blks) info
712 | otherwise = mapEmpty
713
714 sinfo = StackInfo { arg_space = offset
715 , updfr_space = Just (initUpdFrameOff dflags)
716 , do_layout = do_layout }
717
718 tinfo = TopInfo { info_tbls = infos
719 , stack_info=sinfo}
720
721 proc_block = CmmProc tinfo lbl live blks
722
723 ; state <- getState
724 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
725
726 getCmm :: FCode () -> FCode CmmGroup
727 -- Get all the CmmTops (there should be no stmts)
728 -- Return a single Cmm which may be split from other Cmms by
729 -- object splitting (at a later stage)
730 getCmm code
731 = do { state1 <- getState
732 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
733 ; setState $ state2 { cgs_tops = cgs_tops state1 }
734 ; return (fromOL (cgs_tops state2)) }
735
736
737 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
738 mkCmmIfThenElse e tbranch fbranch = do
739 endif <- newLabelC
740 tid <- newLabelC
741 fid <- newLabelC
742 return $ mkCbranch e tid fid <*>
743 mkLabel tid <*> tbranch <*> mkBranch endif <*>
744 mkLabel fid <*> fbranch <*> mkLabel endif
745
746 mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
747 mkCmmIfGoto e tid = do
748 endif <- newLabelC
749 return $ mkCbranch e tid endif <*> mkLabel endif
750
751 mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
752 mkCmmIfThen e tbranch = do
753 endif <- newLabelC
754 tid <- newLabelC
755 return $ mkCbranch e tid endif <*>
756 mkLabel tid <*> tbranch <*> mkLabel endif
757
758
759 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
760 -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph
761 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
762 dflags <- getDynFlags
763 k <- newLabelC
764 let area = Young k
765 (off, _, copyin) = copyInOflow dflags retConv area results []
766 copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
767 return (copyout <*> mkLabel k <*> copyin)
768
769 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
770 -> FCode CmmAGraph
771 mkCmmCall f results actuals updfr_off
772 = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
773
774
775 -- ----------------------------------------------------------------------------
776 -- turn CmmAGraph into CmmGraph, for making a new proc.
777
778 aGraphToGraph :: CmmAGraph -> FCode CmmGraph
779 aGraphToGraph stmts
780 = do { l <- newLabelC
781 ; return (labelAGraph l stmts) }