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