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