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