2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[CgMonad]{The code generation monad}
7 See the beginning of the top-level @CodeGen@ module, to see how this
8 monadic stuff fits into the Big Picture.
15 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
16 returnFC, fixC, fixC_, checkedAbsC,
17 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
18 newUnique, newUniqSupply,
20 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
21 getCgStmts', getCgStmts,
22 noCgStmts, oneCgStmt, consCgStmt,
25 emitData, emitProc, emitSimpleProc,
28 forkClosureBody, forkStatics, forkAlts, forkEval,
29 forkEvalHelp, forkProc, codeOnly,
30 SemiTaggingStuff, ConTagZ,
33 setEndOfBlockInfo, getEndOfBlockInfo,
36 setSRTLabel, getSRTLabel,
37 setTickyCtrLabel, getTickyCtrLabel,
39 StackUsage(..), HeapUsage(..),
40 VirtualSpOffset, VirtualHpOffset,
41 initStkUsage, initHpUsage,
42 getHpUsage, setHpUsage,
47 Sequel(..), -- ToDo: unabstract?
49 -- ideally we wouldn't export these, but some other modules access internal state
50 getState, setState, getInfoDown, getDynFlags, getThisPackage,
52 -- more localised access to monad state
53 getStkUsage, setStkUsage,
54 getBinds, setBinds, getStaticBinds,
56 -- out of general friendliness, we also export ...
57 CgInfoDownwards(..), CgState(..) -- non-abstract
60 #include "HsVersions.h"
62 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
82 infixr 9 `thenC` -- Right-associative!
86 %************************************************************************
88 \subsection[CgMonad-environment]{Stuff for manipulating environments}
90 %************************************************************************
92 This monadery has some information that it only passes {\em
93 downwards}, as well as some ``state'' which is modified as we go
97 data CgInfoDownwards -- information only passed *downwards* by the monad
99 cgd_dflags :: DynFlags,
100 cgd_mod :: Module, -- Module being compiled
101 cgd_statics :: CgBindings, -- [Id -> info] : static environment
102 cgd_srt_lbl :: CLabel, -- label of the current SRT
103 cgd_srt :: SRT, -- the current SRT
104 cgd_ticky :: CLabel, -- current destination for ticky counts
105 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
108 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
109 initCgInfoDown dflags mod
110 = MkCgInfoDown { cgd_dflags = dflags,
112 cgd_statics = emptyVarEnv,
113 cgd_srt_lbl = error "initC: srt_lbl",
114 cgd_srt = error "initC: srt",
115 cgd_ticky = mkTopTickyCtrLabel,
116 cgd_eob = initEobInfo }
120 cgs_stmts :: OrdList CgStmt, -- Current proc
121 cgs_tops :: OrdList CmmTop,
122 -- Other procedures and data blocks in this compilation unit
123 -- Both the latter two are ordered only so that we can
124 -- reduce forward references, when it's easy to do so
126 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
127 -- Bindings for top-level things are given in
128 -- the info-down part
130 cgs_stk_usg :: StackUsage,
131 cgs_hp_usg :: HeapUsage,
133 cgs_uniqs :: UniqSupply }
135 initCgState :: UniqSupply -> CgState
137 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
138 cgs_binds = emptyVarEnv,
139 cgs_stk_usg = initStkUsage,
140 cgs_hp_usg = initHpUsage,
144 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
145 if the expression is a @case@, what to do at the end of each
151 VirtualSpOffset -- Args Sp: trim the stack to this point at a
152 -- return; push arguments starting just
153 -- above this point on a tail call.
155 -- This is therefore the stk ptr as seen
156 -- by a case alternative.
159 initEobInfo :: EndOfBlockInfo
160 initEobInfo = EndOfBlockInfo 0 OnStack
163 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
164 that it must survive stack pointer adjustments at the end of the
169 = OnStack -- Continuation is on the stack
172 CLabel -- Jump to this; if the continuation is for a vectored
173 -- case this might be the label of a return vector
175 Id -- The case binder, only used to see if it's dead
177 type SemiTaggingStuff
178 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
179 ([(ConTagZ, CmmLit)], -- Alternatives
180 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
182 type ConTagZ = Int -- A *zero-indexed* contructor tag
184 -- The case branch is executed only from a successful semitagging
185 -- venture, when a case has looked at a variable, found that it's
186 -- evaluated, and wants to load up the contents and go to the join
190 %************************************************************************
194 %************************************************************************
196 The CgStmts type is what the code generator outputs: it is a tree of
197 statements, including in-line labels. The job of flattenCgStmts is to
198 turn this into a list of basic blocks, each of which ends in a jump
199 statement (either a local branch or a non-local jump).
202 type CgStmts = OrdList CgStmt
207 | CgFork BlockId CgStmts
209 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
210 flattenCgStmts id stmts =
211 case flatten (fromOL stmts) of
212 ([],blocks) -> blocks
213 (block,blocks) -> BasicBlock id block : blocks
217 -- A label at the end of a function or fork: this label must not be reachable,
218 -- but it might be referred to from another BB that also isn't reachable.
219 -- Eliminating these has to be done with a dead-code analysis. For now,
220 -- we just make it into a well-formed block by adding a recursive jump.
222 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
224 -- A jump/branch: throw away all the code up to the next label, because
225 -- it is unreachable. Be careful to keep forks that we find on the way.
226 flatten (CgStmt stmt : stmts)
228 = case dropWhile isOrdinaryStmt stmts of
230 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
231 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
232 where (block,blocks) = flatten stmts
233 (CgFork fork_id stmts : ss) ->
234 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
235 (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
239 CgStmt stmt -> (stmt:block,blocks)
240 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
241 CgFork fork_id stmts ->
242 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
243 where (fork_block, fork_blocks) = flatten (fromOL stmts)
244 where (block,blocks) = flatten ss
246 isJump :: CmmStmt -> Bool
247 isJump (CmmJump _ _) = True
248 isJump (CmmBranch _) = True
249 isJump (CmmSwitch _ _) = True
250 isJump (CmmReturn _) = True
253 isOrdinaryStmt :: CgStmt -> Bool
254 isOrdinaryStmt (CgStmt _) = True
255 isOrdinaryStmt _ = False
258 %************************************************************************
260 Stack and heap models
262 %************************************************************************
265 type VirtualHpOffset = WordOff -- Both are in
266 type VirtualSpOffset = WordOff -- units of words
270 virtSp :: VirtualSpOffset,
271 -- Virtual offset of topmost allocated slot
273 frameSp :: VirtualSpOffset,
274 -- Virtual offset of the return address of the enclosing frame.
275 -- This RA describes the liveness/pointedness of
276 -- all the stack from frameSp downwards
277 -- INVARIANT: less than or equal to virtSp
279 freeStk :: [VirtualSpOffset],
280 -- List of free slots, in *increasing* order
281 -- INVARIANT: all <= virtSp
282 -- All slots <= virtSp are taken except these ones
284 realSp :: VirtualSpOffset,
285 -- Virtual offset of real stack pointer register
287 hwSp :: VirtualSpOffset
288 } -- Highest value ever taken by virtSp
290 -- INVARIANT: The environment contains no Stable references to
291 -- stack slots below (lower offset) frameSp
292 -- It can contain volatile references to this area though.
296 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
297 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
301 The heap high water mark is the larger of virtHp and hwHp. The latter is
302 only records the high water marks of forked-off branches, so to find the
303 heap high water mark you have to take the max of virtHp and hwHp. Remember,
304 virtHp never retreats!
306 Note Jan 04: ok, so why do we only look at the virtual Hp??
309 heapHWM :: HeapUsage -> VirtualHpOffset
316 initStkUsage :: StackUsage
317 initStkUsage = StackUsage {
325 initHpUsage :: HeapUsage
326 initHpUsage = HeapUsage {
332 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
333 marks found in $e_2$.
336 stateIncUsage :: CgState -> CgState -> CgState
337 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
338 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
339 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
340 `addCodeBlocksFrom` s2
342 stateIncUsageEval :: CgState -> CgState -> CgState
343 stateIncUsageEval s1 s2
344 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
345 `addCodeBlocksFrom` s2
346 -- We don't max the heap high-watermark because stateIncUsageEval is
347 -- used only in forkEval, which in turn is only used for blocks of code
348 -- which do their own heap-check.
350 addCodeBlocksFrom :: CgState -> CgState -> CgState
351 -- Add code blocks from the latter to the former
352 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
353 s1 `addCodeBlocksFrom` s2
354 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
355 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
357 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
358 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
360 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
361 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
364 %************************************************************************
368 %************************************************************************
371 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
374 instance Monad FCode where
379 {-# INLINE thenFC #-}
380 {-# INLINE returnFC #-}
382 The Abstract~C is not in the environment so as to improve strictness.
385 initC :: DynFlags -> Module -> FCode a -> IO a
387 initC dflags mod (FCode code)
388 = do { uniqs <- mkSplitUniqSupply 'c'
389 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
390 (res, _) -> return res
393 returnFC :: a -> FCode a
394 returnFC val = FCode (\_ state -> (val, state))
398 thenC :: Code -> FCode a -> FCode a
399 thenC (FCode m) (FCode k) =
400 FCode (\info_down state -> let (_,new_state) = m info_down state in
401 k info_down new_state)
403 listCs :: [Code] -> Code
404 listCs [] = return ()
409 mapCs :: (a -> Code) -> [a] -> Code
414 thenFC :: FCode a -> (a -> FCode c) -> FCode c
415 thenFC (FCode m) k = FCode (
418 (m_result, new_state) = m info_down state
419 (FCode kcode) = k m_result
421 kcode info_down new_state
424 listFCs :: [FCode a] -> FCode [a]
427 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
431 And the knot-tying combinator:
433 fixC :: (a -> FCode a) -> FCode a
438 result@(v,_) = fc info_down state
444 fixC_ :: (a -> FCode a) -> FCode ()
445 fixC_ fcode = fixC fcode >> return ()
448 %************************************************************************
450 Operators for getting and setting the state and "info_down".
453 %************************************************************************
456 getState :: FCode CgState
457 getState = FCode $ \_ state -> (state,state)
459 setState :: CgState -> FCode ()
460 setState state = FCode $ \_ _ -> ((),state)
462 getStkUsage :: FCode StackUsage
465 return $ cgs_stk_usg state
467 setStkUsage :: StackUsage -> Code
468 setStkUsage new_stk_usg = do
470 setState $ state {cgs_stk_usg = new_stk_usg}
472 getHpUsage :: FCode HeapUsage
475 return $ cgs_hp_usg state
477 setHpUsage :: HeapUsage -> Code
478 setHpUsage new_hp_usg = do
480 setState $ state {cgs_hp_usg = new_hp_usg}
482 getBinds :: FCode CgBindings
485 return $ cgs_binds state
487 setBinds :: CgBindings -> FCode ()
488 setBinds new_binds = do
490 setState $ state {cgs_binds = new_binds}
492 getStaticBinds :: FCode CgBindings
495 return (cgd_statics info)
497 withState :: FCode a -> CgState -> FCode (a,CgState)
498 withState (FCode fcode) newstate = FCode $ \info_down state ->
499 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
501 newUniqSupply :: FCode UniqSupply
504 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
505 setState $ state { cgs_uniqs = us1 }
508 newUnique :: FCode Unique
511 return (uniqFromSupply us)
514 getInfoDown :: FCode CgInfoDownwards
515 getInfoDown = FCode $ \info_down state -> (info_down,state)
517 getDynFlags :: FCode DynFlags
518 getDynFlags = liftM cgd_dflags getInfoDown
520 getThisPackage :: FCode PackageId
521 getThisPackage = liftM thisPackage getDynFlags
523 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
524 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
526 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
527 doFCode (FCode fcode) info_down state = fcode info_down state
531 %************************************************************************
535 %************************************************************************
537 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
538 fresh environment, except that:
539 - compilation info and statics are passed in unchanged.
540 The current environment is passed on completely unaltered, except that
541 abstract C from the fork is incorporated.
543 @forkProc@ takes a code and compiles it in the current environment,
544 returning the basic blocks thus constructed. The current environment
545 is passed on completely unchanged. It is pretty similar to
546 @getBlocks@, except that the latter does affect the environment.
548 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
549 from the current bindings, but which is otherwise freshly initialised.
550 The Abstract~C returned is attached to the current state, but the
551 bindings and usage information is otherwise unchanged.
554 forkClosureBody :: Code -> Code
555 forkClosureBody body_code
556 = do { info <- getInfoDown
557 ; us <- newUniqSupply
559 ; let body_info_down = info { cgd_eob = initEobInfo }
560 ((),fork_state) = doFCode body_code body_info_down
562 ; ASSERT( isNilOL (cgs_stmts fork_state) )
563 setState $ state `addCodeBlocksFrom` fork_state }
565 forkStatics :: FCode a -> FCode a
566 forkStatics body_code
567 = do { info <- getInfoDown
568 ; us <- newUniqSupply
570 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
571 cgd_eob = initEobInfo }
572 (result, fork_state_out) = doFCode body_code rhs_info_down
574 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
575 setState (state `addCodeBlocksFrom` fork_state_out)
578 forkProc :: Code -> FCode CgStmts
580 = do { info_down <- getInfoDown
581 ; us <- newUniqSupply
583 ; let fork_state_in = (initCgState us)
584 { cgs_binds = cgs_binds state,
585 cgs_stk_usg = cgs_stk_usg state,
586 cgs_hp_usg = cgs_hp_usg state }
587 -- ToDo: is the hp usage necesary?
588 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
589 info_down fork_state_in
590 ; setState $ state `stateIncUsageEval` fork_state_out
593 codeOnly :: Code -> Code
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
598 = do { info_down <- getInfoDown
599 ; us <- newUniqSupply
601 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
602 cgs_stk_usg = cgs_stk_usg state,
603 cgs_hp_usg = cgs_hp_usg state }
604 ((), fork_state_out) = doFCode body_code info_down fork_state_in
605 ; setState $ state `addCodeBlocksFrom` fork_state_out }
608 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
609 an fcode for the default case $d$, and compiles each in the current
610 environment. The current environment is passed on unmodified, except
612 - the worst stack high-water mark is incorporated
613 - the virtual Hp is moved on to the worst virtual Hp for the branches
616 forkAlts :: [FCode a] -> FCode [a]
618 forkAlts branch_fcodes
619 = do { info_down <- getInfoDown
620 ; us <- newUniqSupply
622 ; let compile us branch
623 = (us2, doFCode branch info_down branch_state)
625 (us1,us2) = splitUniqSupply us
626 branch_state = (initCgState us1) {
627 cgs_binds = cgs_binds state,
628 cgs_stk_usg = cgs_stk_usg state,
629 cgs_hp_usg = cgs_hp_usg state }
631 (_us, results) = mapAccumL compile us branch_fcodes
632 (branch_results, branch_out_states) = unzip results
633 ; setState $ foldl stateIncUsage state branch_out_states
634 -- NB foldl. state is the *left* argument to stateIncUsage
635 ; return branch_results }
638 @forkEval@ takes two blocks of code.
640 - The first meddles with the environment to set it up as expected by
641 the alternatives of a @case@ which does an eval (or gc-possible primop).
642 - The second block is the code for the alternatives.
643 (plus info for semi-tagging purposes)
645 @forkEval@ picks up the virtual stack pointer and returns a suitable
646 @EndOfBlockInfo@ for the caller to use, together with whatever value
647 is returned by the second block.
649 It uses @initEnvForAlternatives@ to initialise the environment, and
650 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
654 forkEval :: EndOfBlockInfo -- For the body
655 -> Code -- Code to set environment
656 -> FCode Sequel -- Semi-tagging info to store
657 -> FCode EndOfBlockInfo -- The new end of block info
659 forkEval body_eob_info env_code body_code
660 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
661 ; returnFC (EndOfBlockInfo v sequel) }
663 forkEvalHelp :: EndOfBlockInfo -- For the body
664 -> Code -- Code to set environment
665 -> FCode a -- The code to do after the eval
666 -> FCode (VirtualSpOffset, -- Sp
667 a) -- Result of the FCode
668 -- A disturbingly complicated function
669 forkEvalHelp body_eob_info env_code body_code
670 = do { info_down <- getInfoDown
671 ; us <- newUniqSupply
673 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
674 ; (_, env_state) = doFCode env_code info_down_for_body
675 (state {cgs_uniqs = us})
676 ; state_for_body = (initCgState (cgs_uniqs env_state))
677 { cgs_binds = binds_for_body,
678 cgs_stk_usg = stk_usg_for_body }
679 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
680 ; stk_usg_from_env = cgs_stk_usg env_state
681 ; virtSp_from_env = virtSp stk_usg_from_env
682 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
683 hwSp = virtSp_from_env}
684 ; (value_returned, state_at_end_return)
685 = doFCode body_code info_down_for_body state_for_body
687 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
688 -- The code coming back should consist only of nested declarations,
689 -- notably of the return vector!
690 setState $ state `stateIncUsageEval` state_at_end_return
691 ; return (virtSp_from_env, value_returned) }
694 -- ----------------------------------------------------------------------------
695 -- Combinators for emitting code
700 whenC :: Bool -> Code -> Code
701 whenC True code = code
704 -- Corresponds to 'emit' in new code generator with a smart constructor
705 -- from cmm/MkGraph.hs
706 stmtC :: CmmStmt -> Code
707 stmtC stmt = emitCgStmt (CgStmt stmt)
709 labelC :: BlockId -> Code
710 labelC id = emitCgStmt (CgLabel id)
712 newLabelC :: FCode BlockId
713 newLabelC = do { u <- newUnique
714 ; return $ mkBlockId u }
716 checkedAbsC :: CmmStmt -> Code
717 -- Emit code, eliminating no-ops
718 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
721 stmtsC :: [CmmStmt] -> Code
722 stmtsC stmts = emitStmts (toOL stmts)
724 -- Emit code; no no-op checking
725 emitStmts :: CmmStmts -> Code
726 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
728 -- forkLabelledCode is for emitting a chunk of code with a label, outside
729 -- of the current instruction stream.
730 forkLabelledCode :: Code -> FCode BlockId
731 forkLabelledCode code = getCgStmts code >>= forkCgStmts
733 emitCgStmt :: CgStmt -> Code
735 = do { state <- getState
736 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
739 emitData :: Section -> [CmmStatic] -> Code
741 = do { state <- getState
742 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
744 data_block = CmmData sect lits
746 emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
747 emitProc info lbl [] blocks
748 = do { let proc_block = CmmProc info lbl (ListGraph blocks)
750 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
751 emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
753 emitSimpleProc :: CLabel -> Code -> Code
754 -- Emit a procedure whose body is the specified code; no info table
755 emitSimpleProc lbl code
756 = do { stmts <- getCgStmts code
757 ; blks <- cgStmtsToBlocks stmts
758 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
760 getCmm :: Code -> FCode Cmm
761 -- Get all the CmmTops (there should be no stmts)
762 -- Return a single Cmm which may be split from other Cmms by
763 -- object splitting (at a later stage)
765 = do { state1 <- getState
766 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
767 ; setState $ state2 { cgs_tops = cgs_tops state1 }
768 ; return (Cmm (fromOL (cgs_tops state2)))
771 -- ----------------------------------------------------------------------------
774 -- These functions deal in terms of CgStmts, which is an abstract type
775 -- representing the code in the current proc.
778 -- emit CgStmts into the current instruction stream
779 emitCgStmts :: CgStmts -> Code
781 = do { state <- getState
782 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
784 -- emit CgStmts outside the current instruction stream, and return a label
785 forkCgStmts :: CgStmts -> FCode BlockId
787 = do { id <- newLabelC
788 ; emitCgStmt (CgFork id stmts)
792 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
793 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
794 cgStmtsToBlocks stmts
795 = do { id <- newLabelC
796 ; return (flattenCgStmts id stmts)
799 -- collect the code emitted by an FCode computation
800 getCgStmts' :: FCode a -> FCode (a, CgStmts)
802 = do { state1 <- getState
803 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
804 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
805 ; return (a, cgs_stmts state2) }
807 getCgStmts :: FCode a -> FCode CgStmts
808 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
810 -- Simple ways to construct CgStmts:
814 oneCgStmt :: CmmStmt -> CgStmts
815 oneCgStmt stmt = unitOL (CgStmt stmt)
817 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
818 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
820 -- ----------------------------------------------------------------------------
821 -- Get the current module name
823 getModuleName :: FCode Module
824 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
826 -- ----------------------------------------------------------------------------
827 -- Get/set the end-of-block info
829 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
830 setEndOfBlockInfo eob_info code = do
832 withInfoDown code (info {cgd_eob = eob_info})
834 getEndOfBlockInfo :: FCode EndOfBlockInfo
835 getEndOfBlockInfo = do
837 return (cgd_eob info)
839 -- ----------------------------------------------------------------------------
840 -- Get/set the current SRT label
842 -- There is just one SRT for each top level binding; all the nested
843 -- bindings use sub-sections of this SRT. The label is passed down to
844 -- the nested bindings via the monad.
846 getSRTLabel :: FCode CLabel -- Used only by cgPanic
847 getSRTLabel = do info <- getInfoDown
848 return (cgd_srt_lbl info)
850 setSRTLabel :: CLabel -> FCode a -> FCode a
851 setSRTLabel srt_lbl code
852 = do info <- getInfoDown
853 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
856 getSRT = do info <- getInfoDown
857 return (cgd_srt info)
859 setSRT :: SRT -> FCode a -> FCode a
861 = do info <- getInfoDown
862 withInfoDown code (info { cgd_srt = srt})
864 -- ----------------------------------------------------------------------------
865 -- Get/set the current ticky counter label
867 getTickyCtrLabel :: FCode CLabel
868 getTickyCtrLabel = do
870 return (cgd_ticky info)
872 setTickyCtrLabel :: CLabel -> Code -> Code
873 setTickyCtrLabel ticky code = do
875 withInfoDown code (info {cgd_ticky = ticky})