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