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, 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,
35 setSRTLabel, getSRTLabel,
36 setTickyCtrLabel, getTickyCtrLabel,
38 StackUsage(..), HeapUsage(..),
39 VirtualSpOffset, VirtualHpOffset,
40 initStkUsage, initHpUsage,
41 getHpUsage, setHpUsage,
46 Sequel(..), -- ToDo: unabstract?
48 -- ideally we wouldn't export these, but some other modules access internal state
49 getState, setState, getInfoDown, getDynFlags, getThisPackage,
51 -- more localised access to monad state
52 getStkUsage, setStkUsage,
53 getBinds, setBinds, getStaticBinds,
55 -- out of general friendliness, we also export ...
56 CgInfoDownwards(..), CgState(..) -- non-abstract
59 #include "HsVersions.h"
61 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
81 infixr 9 `thenC` -- Right-associative!
85 %************************************************************************
87 \subsection[CgMonad-environment]{Stuff for manipulating environments}
89 %************************************************************************
91 This monadery has some information that it only passes {\em
92 downwards}, as well as some ``state'' which is modified as we go
96 data CgInfoDownwards -- information only passed *downwards* by the monad
98 cgd_dflags :: DynFlags,
99 cgd_mod :: Module, -- Module being compiled
100 cgd_statics :: CgBindings, -- [Id -> info] : static environment
101 cgd_srt :: CLabel, -- label of the current SRT
102 cgd_ticky :: CLabel, -- current destination for ticky counts
103 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
106 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
107 initCgInfoDown dflags mod
108 = MkCgInfoDown { cgd_dflags = dflags,
110 cgd_statics = emptyVarEnv,
111 cgd_srt = error "initC: srt",
112 cgd_ticky = mkTopTickyCtrLabel,
113 cgd_eob = initEobInfo }
117 cgs_stmts :: OrdList CgStmt, -- Current proc
118 cgs_tops :: OrdList CmmTop,
119 -- Other procedures and data blocks in this compilation unit
120 -- Both the latter two are ordered only so that we can
121 -- reduce forward references, when it's easy to do so
123 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
124 -- Bindings for top-level things are given in
125 -- the info-down part
127 cgs_stk_usg :: StackUsage,
128 cgs_hp_usg :: HeapUsage,
130 cgs_uniqs :: UniqSupply }
132 initCgState :: UniqSupply -> CgState
134 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
135 cgs_binds = emptyVarEnv,
136 cgs_stk_usg = initStkUsage,
137 cgs_hp_usg = initHpUsage,
141 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
142 if the expression is a @case@, what to do at the end of each
148 VirtualSpOffset -- Args Sp: trim the stack to this point at a
149 -- return; push arguments starting just
150 -- above this point on a tail call.
152 -- This is therefore the stk ptr as seen
153 -- by a case alternative.
156 initEobInfo = EndOfBlockInfo 0 OnStack
159 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
160 that it must survive stack pointer adjustments at the end of the
165 = OnStack -- Continuation is on the stack
166 | UpdateCode -- Continuation is update
169 CLabel -- Jump to this; if the continuation is for a vectored
170 -- case this might be the label of a return vector
172 Id -- The case binder, only used to see if it's dead
173 Bool -- True <=> polymorphic, push a SEQ frame too
175 type SemiTaggingStuff
176 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
177 ([(ConTagZ, CmmLit)], -- Alternatives
178 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
180 type ConTagZ = Int -- A *zero-indexed* contructor tag
182 -- The case branch is executed only from a successful semitagging
183 -- venture, when a case has looked at a variable, found that it's
184 -- evaluated, and wants to load up the contents and go to the join
188 %************************************************************************
192 %************************************************************************
194 The CgStmts type is what the code generator outputs: it is a tree of
195 statements, including in-line labels. The job of flattenCgStmts is to
196 turn this into a list of basic blocks, each of which ends in a jump
197 statement (either a local branch or a non-local jump).
200 type CgStmts = OrdList CgStmt
205 | CgFork BlockId CgStmts
207 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
208 flattenCgStmts id stmts =
209 case flatten (fromOL stmts) of
210 ([],blocks) -> blocks
211 (block,blocks) -> BasicBlock id block : blocks
215 -- A label at the end of a function or fork: this label must not be reachable,
216 -- but it might be referred to from another BB that also isn't reachable.
217 -- Eliminating these has to be done with a dead-code analysis. For now,
218 -- we just make it into a well-formed block by adding a recursive jump.
220 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
222 -- A jump/branch: throw away all the code up to the next label, because
223 -- it is unreachable. Be careful to keep forks that we find on the way.
224 flatten (CgStmt stmt : stmts)
226 = case dropWhile isOrdinaryStmt stmts of
228 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
229 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
230 where (block,blocks) = flatten stmts
231 (CgFork fork_id stmts : ss) ->
232 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
236 CgStmt stmt -> (stmt:block,blocks)
237 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
238 CgFork fork_id stmts ->
239 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
240 where (fork_block, fork_blocks) = flatten (fromOL stmts)
241 where (block,blocks) = flatten ss
243 isJump (CmmJump _ _) = True
244 isJump (CmmBranch _) = True
247 isOrdinaryStmt (CgStmt _) = True
248 isOrdinaryStmt _ = False
251 %************************************************************************
253 Stack and heap models
255 %************************************************************************
258 type VirtualHpOffset = WordOff -- Both are in
259 type VirtualSpOffset = WordOff -- units of words
263 virtSp :: VirtualSpOffset,
264 -- Virtual offset of topmost allocated slot
266 frameSp :: VirtualSpOffset,
267 -- Virtual offset of the return address of the enclosing frame.
268 -- This RA describes the liveness/pointedness of
269 -- all the stack from frameSp downwards
270 -- INVARIANT: less than or equal to virtSp
272 freeStk :: [VirtualSpOffset],
273 -- List of free slots, in *increasing* order
274 -- INVARIANT: all <= virtSp
275 -- All slots <= virtSp are taken except these ones
277 realSp :: VirtualSpOffset,
278 -- Virtual offset of real stack pointer register
280 hwSp :: VirtualSpOffset
281 } -- Highest value ever taken by virtSp
283 -- INVARIANT: The environment contains no Stable references to
284 -- stack slots below (lower offset) frameSp
285 -- It can contain volatile references to this area though.
289 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
290 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
294 The heap high water mark is the larger of virtHp and hwHp. The latter is
295 only records the high water marks of forked-off branches, so to find the
296 heap high water mark you have to take the max of virtHp and hwHp. Remember,
297 virtHp never retreats!
299 Note Jan 04: ok, so why do we only look at the virtual Hp??
302 heapHWM :: HeapUsage -> VirtualHpOffset
309 initStkUsage :: StackUsage
310 initStkUsage = StackUsage {
318 initHpUsage :: HeapUsage
319 initHpUsage = HeapUsage {
325 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
326 marks found in $e_2$.
329 stateIncUsage :: CgState -> CgState -> CgState
330 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
331 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
332 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
333 `addCodeBlocksFrom` s2
335 stateIncUsageEval :: CgState -> CgState -> CgState
336 stateIncUsageEval s1 s2
337 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
338 `addCodeBlocksFrom` s2
339 -- We don't max the heap high-watermark because stateIncUsageEval is
340 -- used only in forkEval, which in turn is only used for blocks of code
341 -- which do their own heap-check.
343 addCodeBlocksFrom :: CgState -> CgState -> CgState
344 -- Add code blocks from the latter to the former
345 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
346 s1 `addCodeBlocksFrom` s2
347 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
348 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
350 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
351 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
353 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
354 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
357 %************************************************************************
361 %************************************************************************
364 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
367 instance Monad FCode where
372 {-# INLINE thenFC #-}
373 {-# INLINE returnFC #-}
375 The Abstract~C is not in the environment so as to improve strictness.
378 initC :: DynFlags -> Module -> FCode a -> IO a
380 initC dflags mod (FCode code)
381 = do { uniqs <- mkSplitUniqSupply 'c'
382 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
383 (res, _) -> return res
386 returnFC :: a -> FCode a
387 returnFC val = FCode (\info_down state -> (val, state))
391 thenC :: Code -> FCode a -> FCode a
392 thenC (FCode m) (FCode k) =
393 FCode (\info_down state -> let (_,new_state) = m info_down state in
394 k info_down new_state)
396 listCs :: [Code] -> Code
397 listCs [] = return ()
402 mapCs :: (a -> Code) -> [a] -> Code
407 thenFC :: FCode a -> (a -> FCode c) -> FCode c
408 thenFC (FCode m) k = FCode (
411 (m_result, new_state) = m info_down state
412 (FCode kcode) = k m_result
414 kcode info_down new_state
417 listFCs :: [FCode a] -> FCode [a]
420 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
424 And the knot-tying combinator:
426 fixC :: (a -> FCode a) -> FCode a
431 result@(v,_) = fc info_down state
438 %************************************************************************
440 Operators for getting and setting the state and "info_down".
443 %************************************************************************
446 getState :: FCode CgState
447 getState = FCode $ \info_down state -> (state,state)
449 setState :: CgState -> FCode ()
450 setState state = FCode $ \info_down _ -> ((),state)
452 getStkUsage :: FCode StackUsage
455 return $ cgs_stk_usg state
457 setStkUsage :: StackUsage -> Code
458 setStkUsage new_stk_usg = do
460 setState $ state {cgs_stk_usg = new_stk_usg}
462 getHpUsage :: FCode HeapUsage
465 return $ cgs_hp_usg state
467 setHpUsage :: HeapUsage -> Code
468 setHpUsage new_hp_usg = do
470 setState $ state {cgs_hp_usg = new_hp_usg}
472 getBinds :: FCode CgBindings
475 return $ cgs_binds state
477 setBinds :: CgBindings -> FCode ()
478 setBinds new_binds = do
480 setState $ state {cgs_binds = new_binds}
482 getStaticBinds :: FCode CgBindings
485 return (cgd_statics info)
487 withState :: FCode a -> CgState -> FCode (a,CgState)
488 withState (FCode fcode) newstate = FCode $ \info_down state ->
489 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
491 newUniqSupply :: FCode UniqSupply
494 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
495 setState $ state { cgs_uniqs = us1 }
498 newUnique :: FCode Unique
501 return (uniqFromSupply us)
504 getInfoDown :: FCode CgInfoDownwards
505 getInfoDown = FCode $ \info_down state -> (info_down,state)
507 getDynFlags :: FCode DynFlags
508 getDynFlags = liftM cgd_dflags getInfoDown
510 getThisPackage :: FCode PackageId
511 getThisPackage = liftM thisPackage getDynFlags
513 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
514 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
516 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
517 doFCode (FCode fcode) info_down state = fcode info_down state
521 %************************************************************************
525 %************************************************************************
527 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
528 fresh environment, except that:
529 - compilation info and statics are passed in unchanged.
530 The current environment is passed on completely unaltered, except that
531 abstract C from the fork is incorporated.
533 @forkProc@ takes a code and compiles it in the current environment,
534 returning the basic blocks thus constructed. The current environment
535 is passed on completely unchanged. It is pretty similar to
536 @getBlocks@, except that the latter does affect the environment.
538 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
539 from the current bindings, but which is otherwise freshly initialised.
540 The Abstract~C returned is attached to the current state, but the
541 bindings and usage information is otherwise unchanged.
544 forkClosureBody :: Code -> Code
545 forkClosureBody body_code
546 = do { info <- getInfoDown
547 ; us <- newUniqSupply
549 ; let body_info_down = info { cgd_eob = initEobInfo }
550 ((),fork_state) = doFCode body_code body_info_down
552 ; ASSERT( isNilOL (cgs_stmts fork_state) )
553 setState $ state `addCodeBlocksFrom` fork_state }
555 forkStatics :: FCode a -> FCode a
556 forkStatics body_code
557 = do { info <- getInfoDown
558 ; us <- newUniqSupply
560 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
561 cgd_eob = initEobInfo }
562 (result, fork_state_out) = doFCode body_code rhs_info_down
564 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
565 setState (state `addCodeBlocksFrom` fork_state_out)
568 forkProc :: Code -> FCode CgStmts
570 = do { info_down <- getInfoDown
571 ; us <- newUniqSupply
573 ; let fork_state_in = (initCgState us)
574 { cgs_binds = cgs_binds state,
575 cgs_stk_usg = cgs_stk_usg state,
576 cgs_hp_usg = cgs_hp_usg state }
577 -- ToDo: is the hp usage necesary?
578 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
579 info_down fork_state_in
580 ; setState $ state `stateIncUsageEval` fork_state_out
583 codeOnly :: Code -> Code
584 -- Emit any code from the inner thing into the outer thing
585 -- Do not affect anything else in the outer state
586 -- Used in almost-circular code to prevent false loop dependencies
588 = do { info_down <- getInfoDown
589 ; us <- newUniqSupply
591 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
592 cgs_stk_usg = cgs_stk_usg state,
593 cgs_hp_usg = cgs_hp_usg state }
594 ((), fork_state_out) = doFCode body_code info_down fork_state_in
595 ; setState $ state `addCodeBlocksFrom` fork_state_out }
598 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
599 an fcode for the default case $d$, and compiles each in the current
600 environment. The current environment is passed on unmodified, except
602 - the worst stack high-water mark is incorporated
603 - the virtual Hp is moved on to the worst virtual Hp for the branches
606 forkAlts :: [FCode a] -> FCode [a]
608 forkAlts branch_fcodes
609 = do { info_down <- getInfoDown
610 ; us <- newUniqSupply
612 ; let compile us branch
613 = (us2, doFCode branch info_down branch_state)
615 (us1,us2) = splitUniqSupply us
616 branch_state = (initCgState us1) {
617 cgs_binds = cgs_binds state,
618 cgs_stk_usg = cgs_stk_usg state,
619 cgs_hp_usg = cgs_hp_usg state }
621 (_us, results) = mapAccumL compile us branch_fcodes
622 (branch_results, branch_out_states) = unzip results
623 ; setState $ foldl stateIncUsage state branch_out_states
624 -- NB foldl. state is the *left* argument to stateIncUsage
625 ; return branch_results }
628 @forkEval@ takes two blocks of code.
630 - The first meddles with the environment to set it up as expected by
631 the alternatives of a @case@ which does an eval (or gc-possible primop).
632 - The second block is the code for the alternatives.
633 (plus info for semi-tagging purposes)
635 @forkEval@ picks up the virtual stack pointer and returns a suitable
636 @EndOfBlockInfo@ for the caller to use, together with whatever value
637 is returned by the second block.
639 It uses @initEnvForAlternatives@ to initialise the environment, and
640 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
644 forkEval :: EndOfBlockInfo -- For the body
645 -> Code -- Code to set environment
646 -> FCode Sequel -- Semi-tagging info to store
647 -> FCode EndOfBlockInfo -- The new end of block info
649 forkEval body_eob_info env_code body_code
650 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
651 ; returnFC (EndOfBlockInfo v sequel) }
653 forkEvalHelp :: EndOfBlockInfo -- For the body
654 -> Code -- Code to set environment
655 -> FCode a -- The code to do after the eval
656 -> FCode (VirtualSpOffset, -- Sp
657 a) -- Result of the FCode
658 -- A disturbingly complicated function
659 forkEvalHelp body_eob_info env_code body_code
660 = do { info_down <- getInfoDown
661 ; us <- newUniqSupply
663 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
664 ; (_, env_state) = doFCode env_code info_down_for_body
665 (state {cgs_uniqs = us})
666 ; state_for_body = (initCgState (cgs_uniqs env_state))
667 { cgs_binds = binds_for_body,
668 cgs_stk_usg = stk_usg_for_body }
669 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
670 ; stk_usg_from_env = cgs_stk_usg env_state
671 ; virtSp_from_env = virtSp stk_usg_from_env
672 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
673 hwSp = virtSp_from_env}
674 ; (value_returned, state_at_end_return)
675 = doFCode body_code info_down_for_body state_for_body
677 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
678 -- The code coming back should consist only of nested declarations,
679 -- notably of the return vector!
680 setState $ state `stateIncUsageEval` state_at_end_return
681 ; return (virtSp_from_env, value_returned) }
684 -- ----------------------------------------------------------------------------
685 -- Combinators for emitting code
690 whenC :: Bool -> Code -> Code
691 whenC True code = code
692 whenC False code = nopC
694 stmtC :: CmmStmt -> Code
695 stmtC stmt = emitCgStmt (CgStmt stmt)
697 labelC :: BlockId -> Code
698 labelC id = emitCgStmt (CgLabel id)
700 newLabelC :: FCode BlockId
701 newLabelC = do { id <- newUnique; return (BlockId id) }
703 checkedAbsC :: CmmStmt -> Code
704 -- Emit code, eliminating no-ops
705 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
708 stmtsC :: [CmmStmt] -> Code
709 stmtsC stmts = emitStmts (toOL stmts)
711 -- Emit code; no no-op checking
712 emitStmts :: CmmStmts -> Code
713 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
715 -- forkLabelledCode is for emitting a chunk of code with a label, outside
716 -- of the current instruction stream.
717 forkLabelledCode :: Code -> FCode BlockId
718 forkLabelledCode code = getCgStmts code >>= forkCgStmts
720 emitCgStmt :: CgStmt -> Code
722 = do { state <- getState
723 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
726 emitData :: Section -> [CmmStatic] -> Code
728 = do { state <- getState
729 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
731 data_block = CmmData sect lits
733 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
734 emitProc lits lbl args blocks
735 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
737 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
739 emitSimpleProc :: CLabel -> Code -> Code
740 -- Emit a procedure whose body is the specified code; no info table
741 emitSimpleProc lbl code
742 = do { stmts <- getCgStmts code
743 ; blks <- cgStmtsToBlocks stmts
744 ; emitProc [] lbl [] blks }
746 getCmm :: Code -> FCode Cmm
747 -- Get all the CmmTops (there should be no stmts)
749 = do { state1 <- getState
750 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
751 ; setState $ state2 { cgs_tops = cgs_tops state1 }
752 ; return (Cmm (fromOL (cgs_tops state2))) }
754 -- ----------------------------------------------------------------------------
757 -- These functions deal in terms of CgStmts, which is an abstract type
758 -- representing the code in the current proc.
761 -- emit CgStmts into the current instruction stream
762 emitCgStmts :: CgStmts -> Code
764 = do { state <- getState
765 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
767 -- emit CgStmts outside the current instruction stream, and return a label
768 forkCgStmts :: CgStmts -> FCode BlockId
770 = do { id <- newLabelC
771 ; emitCgStmt (CgFork id stmts)
775 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
776 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
777 cgStmtsToBlocks stmts
778 = do { id <- newLabelC
779 ; return (flattenCgStmts id stmts)
782 -- collect the code emitted by an FCode computation
783 getCgStmts' :: FCode a -> FCode (a, CgStmts)
785 = do { state1 <- getState
786 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
787 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
788 ; return (a, cgs_stmts state2) }
790 getCgStmts :: FCode a -> FCode CgStmts
791 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
793 -- Simple ways to construct CgStmts:
797 oneCgStmt :: CmmStmt -> CgStmts
798 oneCgStmt stmt = unitOL (CgStmt stmt)
800 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
801 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
803 -- ----------------------------------------------------------------------------
804 -- Get the current module name
806 getModuleName :: FCode Module
807 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
809 -- ----------------------------------------------------------------------------
810 -- Get/set the end-of-block info
812 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
813 setEndOfBlockInfo eob_info code = do
815 withInfoDown code (info {cgd_eob = eob_info})
817 getEndOfBlockInfo :: FCode EndOfBlockInfo
818 getEndOfBlockInfo = do
820 return (cgd_eob info)
822 -- ----------------------------------------------------------------------------
823 -- Get/set the current SRT label
825 -- There is just one SRT for each top level binding; all the nested
826 -- bindings use sub-sections of this SRT. The label is passed down to
827 -- the nested bindings via the monad.
829 getSRTLabel :: FCode CLabel -- Used only by cgPanic
830 getSRTLabel = do info <- getInfoDown
831 return (cgd_srt info)
833 setSRTLabel :: CLabel -> FCode a -> FCode a
834 setSRTLabel srt_lbl code
835 = do info <- getInfoDown
836 withInfoDown code (info { cgd_srt = srt_lbl})
838 -- ----------------------------------------------------------------------------
839 -- Get/set the current ticky counter label
841 getTickyCtrLabel :: FCode CLabel
842 getTickyCtrLabel = do
844 return (cgd_ticky info)
846 setTickyCtrLabel :: CLabel -> Code -> Code
847 setTickyCtrLabel ticky code = do
849 withInfoDown code (info {cgd_ticky = ticky})