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