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