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