2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.41 2004/09/10 14:53:47 simonmar Exp $
6 \section[CgMonad]{The code generation monad}
8 See the beginning of the top-level @CodeGen@ module, to see how this
9 monadic stuff fits into the Big Picture.
16 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
17 returnFC, fixC, checkedAbsC,
18 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
19 newUnique, newUniqSupply,
21 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
22 getCgStmts', getCgStmts,
23 noCgStmts, oneCgStmt, consCgStmt,
26 emitData, emitProc, emitSimpleProc,
29 forkClosureBody, forkStatics, forkAlts, forkEval,
30 forkEvalHelp, forkProc, codeOnly,
31 SemiTaggingStuff, ConTagZ,
34 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,
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 )
65 import CmmUtils ( CmmStmts, isNopStmt )
67 import SMRep ( WordOff )
68 import Module ( Module )
72 import Unique ( Unique )
73 import Util ( mapAccumL )
74 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
78 infixr 9 `thenC` -- Right-associative!
82 %************************************************************************
84 \subsection[CgMonad-environment]{Stuff for manipulating environments}
86 %************************************************************************
88 This monadery has some information that it only passes {\em
89 downwards}, as well as some ``state'' which is modified as we go
93 data CgInfoDownwards -- information only passed *downwards* by the monad
95 cgd_mod :: Module, -- Module being compiled
96 cgd_statics :: CgBindings, -- [Id -> info] : static environment
97 cgd_srt :: CLabel, -- label of the current SRT
98 cgd_ticky :: CLabel, -- current destination for ticky counts
99 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
102 initCgInfoDown :: Module -> CgInfoDownwards
104 = MkCgInfoDown { cgd_mod = mod,
105 cgd_statics = emptyVarEnv,
106 cgd_srt = error "initC: srt",
107 cgd_ticky = mkTopTickyCtrLabel,
108 cgd_eob = initEobInfo }
112 cgs_stmts :: OrdList CgStmt, -- Current proc
113 cgs_tops :: OrdList CmmTop,
114 -- Other procedures and data blocks in this compilation unit
115 -- Both the latter two are ordered only so that we can
116 -- reduce forward references, when it's easy to do so
118 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
119 -- Bindings for top-level things are given in
120 -- the info-down part
122 cgs_stk_usg :: StackUsage,
123 cgs_hp_usg :: HeapUsage,
125 cgs_uniqs :: UniqSupply }
127 initCgState :: UniqSupply -> CgState
129 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
130 cgs_binds = emptyVarEnv,
131 cgs_stk_usg = initStkUsage,
132 cgs_hp_usg = initHpUsage,
136 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
137 if the expression is a @case@, what to do at the end of each
143 VirtualSpOffset -- Args Sp: trim the stack to this point at a
144 -- return; push arguments starting just
145 -- above this point on a tail call.
147 -- This is therefore the stk ptr as seen
148 -- by a case alternative.
151 initEobInfo = EndOfBlockInfo 0 OnStack
154 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
155 that it must survive stack pointer adjustments at the end of the
160 = OnStack -- Continuation is on the stack
161 | UpdateCode -- Continuation is update
164 CLabel -- Jump to this; if the continuation is for a vectored
165 -- case this might be the label of a return vector
167 Id -- The case binder, only used to see if it's dead
168 Bool -- True <=> polymorphic, push a SEQ frame too
170 type SemiTaggingStuff
171 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
172 ([(ConTagZ, CmmLit)], -- Alternatives
173 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
175 type ConTagZ = Int -- A *zero-indexed* contructor tag
177 -- The case branch is executed only from a successful semitagging
178 -- venture, when a case has looked at a variable, found that it's
179 -- evaluated, and wants to load up the contents and go to the join
183 %************************************************************************
187 %************************************************************************
189 The CgStmts type is what the code generator outputs: it is a tree of
190 statements, including in-line labels. The job of flattenCgStmts is to
191 turn this into a list of basic blocks, each of which ends in a jump
192 statement (either a local branch or a non-local jump).
195 type CgStmts = OrdList CgStmt
200 | CgFork BlockId CgStmts
202 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
203 flattenCgStmts id stmts =
204 case flatten (fromOL stmts) of
205 ([],blocks) -> blocks
206 (block,blocks) -> BasicBlock id block : blocks
210 -- A label at the end of a function or fork: this label must not be reachable,
211 -- but it might be referred to from another BB that also isn't reachable.
212 -- Eliminating these has to be done with a dead-code analysis. For now,
213 -- we just make it into a well-formed block by adding a recursive jump.
215 = ( [], [BasicBlock id [CmmBranch id]] )
217 -- A jump/branch: throw away all the code up to the next label, because
218 -- it is unreachable. Be careful to keep forks that we find on the way.
219 flatten (CgStmt stmt : stmts)
221 = case dropWhile isOrdinaryStmt stmts of
223 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
224 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
225 where (block,blocks) = flatten stmts
226 (CgFork fork_id stmts : ss) ->
227 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
231 CgStmt stmt -> (stmt:block,blocks)
232 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
233 CgFork fork_id stmts ->
234 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
235 where (fork_block, fork_blocks) = flatten (fromOL stmts)
236 where (block,blocks) = flatten ss
238 isJump (CmmJump _ _) = True
239 isJump (CmmBranch _) = True
242 isOrdinaryStmt (CgStmt _) = True
243 isOrdinaryStmt _ = False
246 %************************************************************************
248 Stack and heap models
250 %************************************************************************
253 type VirtualHpOffset = WordOff -- Both are in
254 type VirtualSpOffset = WordOff -- units of words
258 virtSp :: VirtualSpOffset,
259 -- Virtual offset of topmost allocated slot
261 frameSp :: VirtualSpOffset,
262 -- Virtual offset of the return address of the enclosing frame.
263 -- This RA describes the liveness/pointedness of
264 -- all the stack from frameSp downwards
265 -- INVARIANT: less than or equal to virtSp
267 freeStk :: [VirtualSpOffset],
268 -- List of free slots, in *increasing* order
269 -- INVARIANT: all <= virtSp
270 -- All slots <= virtSp are taken except these ones
272 realSp :: VirtualSpOffset,
273 -- Virtual offset of real stack pointer register
275 hwSp :: VirtualSpOffset
276 } -- Highest value ever taken by virtSp
278 -- INVARAINT: The environment contains no Stable references to
279 -- stack slots below (lower offset) frameSp
280 -- It can contain volatile references to this area though.
284 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
285 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
289 The heap high water mark is the larger of virtHp and hwHp. The latter is
290 only records the high water marks of forked-off branches, so to find the
291 heap high water mark you have to take the max of virtHp and hwHp. Remember,
292 virtHp never retreats!
294 Note Jan 04: ok, so why do we only look at the virtual Hp??
297 heapHWM :: HeapUsage -> VirtualHpOffset
304 initStkUsage :: StackUsage
305 initStkUsage = StackUsage {
313 initHpUsage :: HeapUsage
314 initHpUsage = HeapUsage {
320 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
321 marks found in $e_2$.
324 stateIncUsage :: CgState -> CgState -> CgState
325 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
326 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
327 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
328 `addCodeBlocksFrom` s2
330 stateIncUsageEval :: CgState -> CgState -> CgState
331 stateIncUsageEval s1 s2
332 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
333 `addCodeBlocksFrom` s2
334 -- We don't max the heap high-watermark because stateIncUsageEval is
335 -- used only in forkEval, which in turn is only used for blocks of code
336 -- which do their own heap-check.
338 addCodeBlocksFrom :: CgState -> CgState -> CgState
339 -- Add code blocks from the latter to the former
340 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
341 s1 `addCodeBlocksFrom` s2
342 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
343 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
345 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
346 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
348 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
349 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
352 %************************************************************************
356 %************************************************************************
359 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
362 instance Monad FCode where
367 {-# INLINE thenFC #-}
368 {-# INLINE returnFC #-}
370 The Abstract~C is not in the environment so as to improve strictness.
373 initC :: Module -> FCode a -> IO a
375 initC mod (FCode code)
376 = do { uniqs <- mkSplitUniqSupply 'c'
377 ; case code (initCgInfoDown mod) (initCgState uniqs) of
378 (res, _) -> return res
381 returnFC :: a -> FCode a
382 returnFC val = FCode (\info_down state -> (val, state))
386 thenC :: Code -> FCode a -> FCode a
387 thenC (FCode m) (FCode k) =
388 FCode (\info_down state -> let (_,new_state) = m info_down state in
389 k info_down new_state)
391 listCs :: [Code] -> Code
392 listCs [] = return ()
397 mapCs :: (a -> Code) -> [a] -> Code
402 thenFC :: FCode a -> (a -> FCode c) -> FCode c
403 thenFC (FCode m) k = FCode (
406 (m_result, new_state) = m info_down state
407 (FCode kcode) = k m_result
409 kcode info_down new_state
412 listFCs :: [FCode a] -> FCode [a]
415 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
419 And the knot-tying combinator:
421 fixC :: (a -> FCode a) -> FCode a
426 result@(v,_) = fc info_down state
433 %************************************************************************
435 Operators for getting and setting the state and "info_down".
438 %************************************************************************
441 getState :: FCode CgState
442 getState = FCode $ \info_down state -> (state,state)
444 setState :: CgState -> FCode ()
445 setState state = FCode $ \info_down _ -> ((),state)
447 getStkUsage :: FCode StackUsage
450 return $ cgs_stk_usg state
452 setStkUsage :: StackUsage -> Code
453 setStkUsage new_stk_usg = do
455 setState $ state {cgs_stk_usg = new_stk_usg}
457 getHpUsage :: FCode HeapUsage
460 return $ cgs_hp_usg state
462 setHpUsage :: HeapUsage -> Code
463 setHpUsage new_hp_usg = do
465 setState $ state {cgs_hp_usg = new_hp_usg}
467 getBinds :: FCode CgBindings
470 return $ cgs_binds state
472 setBinds :: CgBindings -> FCode ()
473 setBinds new_binds = do
475 setState $ state {cgs_binds = new_binds}
477 getStaticBinds :: FCode CgBindings
480 return (cgd_statics info)
482 withState :: FCode a -> CgState -> FCode (a,CgState)
483 withState (FCode fcode) newstate = FCode $ \info_down state ->
484 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
486 newUniqSupply :: FCode UniqSupply
489 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
490 setState $ state { cgs_uniqs = us1 }
493 newUnique :: FCode Unique
496 return (uniqFromSupply us)
499 getInfoDown :: FCode CgInfoDownwards
500 getInfoDown = FCode $ \info_down state -> (info_down,state)
502 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
503 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
505 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
506 doFCode (FCode fcode) info_down state = fcode info_down state
510 %************************************************************************
514 %************************************************************************
516 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
517 fresh environment, except that:
518 - compilation info and statics are passed in unchanged.
519 The current environment is passed on completely unaltered, except that
520 abstract C from the fork is incorporated.
522 @forkProc@ takes a code and compiles it in the current environment,
523 returning the basic blocks thus constructed. The current environment
524 is passed on completely unchanged. It is pretty similar to
525 @getBlocks@, except that the latter does affect the environment.
527 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
528 from the current bindings, but which is otherwise freshly initialised.
529 The Abstract~C returned is attached to the current state, but the
530 bindings and usage information is otherwise unchanged.
533 forkClosureBody :: Code -> Code
534 forkClosureBody body_code
535 = do { info <- getInfoDown
536 ; us <- newUniqSupply
538 ; let body_info_down = info { cgd_eob = initEobInfo }
539 ((),fork_state) = doFCode body_code body_info_down
541 ; ASSERT( isNilOL (cgs_stmts fork_state) )
542 setState $ state `addCodeBlocksFrom` fork_state }
544 forkStatics :: FCode a -> FCode a
545 forkStatics body_code
546 = do { info <- getInfoDown
547 ; us <- newUniqSupply
549 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
550 cgd_eob = initEobInfo }
551 (result, fork_state_out) = doFCode body_code rhs_info_down
553 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
554 setState (state `addCodeBlocksFrom` fork_state_out)
557 forkProc :: Code -> FCode CgStmts
559 = do { info_down <- getInfoDown
560 ; us <- newUniqSupply
562 ; let fork_state_in = (initCgState us)
563 { cgs_binds = cgs_binds state,
564 cgs_stk_usg = cgs_stk_usg state,
565 cgs_hp_usg = cgs_hp_usg state }
566 -- ToDo: is the hp usage necesary?
567 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
568 info_down fork_state_in
569 ; setState $ state `stateIncUsageEval` fork_state_out
572 codeOnly :: Code -> Code
573 -- Emit any code from the inner thing into the outer thing
574 -- Do not affect anything else in the outer state
575 -- Used in almost-circular code to prevent false loop dependencies
577 = do { info_down <- getInfoDown
578 ; us <- newUniqSupply
580 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
581 cgs_stk_usg = cgs_stk_usg state,
582 cgs_hp_usg = cgs_hp_usg state }
583 ((), fork_state_out) = doFCode body_code info_down fork_state_in
584 ; setState $ state `addCodeBlocksFrom` fork_state_out }
587 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
588 an fcode for the default case $d$, and compiles each in the current
589 environment. The current environment is passed on unmodified, except
591 - the worst stack high-water mark is incorporated
592 - the virtual Hp is moved on to the worst virtual Hp for the branches
595 forkAlts :: [FCode a] -> FCode [a]
597 forkAlts branch_fcodes
598 = do { info_down <- getInfoDown
599 ; us <- newUniqSupply
601 ; let compile us branch
602 = (us2, doFCode branch info_down branch_state)
604 (us1,us2) = splitUniqSupply us
605 branch_state = (initCgState us1) {
606 cgs_binds = cgs_binds state,
607 cgs_stk_usg = cgs_stk_usg state,
608 cgs_hp_usg = cgs_hp_usg state }
610 (_us, results) = mapAccumL compile us branch_fcodes
611 (branch_results, branch_out_states) = unzip results
612 ; setState $ foldl stateIncUsage state branch_out_states
613 -- NB foldl. state is the *left* argument to stateIncUsage
614 ; return branch_results }
617 @forkEval@ takes two blocks of code.
619 - The first meddles with the environment to set it up as expected by
620 the alternatives of a @case@ which does an eval (or gc-possible primop).
621 - The second block is the code for the alternatives.
622 (plus info for semi-tagging purposes)
624 @forkEval@ picks up the virtual stack pointer and returns a suitable
625 @EndOfBlockInfo@ for the caller to use, together with whatever value
626 is returned by the second block.
628 It uses @initEnvForAlternatives@ to initialise the environment, and
629 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
633 forkEval :: EndOfBlockInfo -- For the body
634 -> Code -- Code to set environment
635 -> FCode Sequel -- Semi-tagging info to store
636 -> FCode EndOfBlockInfo -- The new end of block info
638 forkEval body_eob_info env_code body_code
639 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
640 ; returnFC (EndOfBlockInfo v sequel) }
642 forkEvalHelp :: EndOfBlockInfo -- For the body
643 -> Code -- Code to set environment
644 -> FCode a -- The code to do after the eval
645 -> FCode (VirtualSpOffset, -- Sp
646 a) -- Result of the FCode
647 -- A disturbingly complicated function
648 forkEvalHelp body_eob_info env_code body_code
649 = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
650 ; us <- newUniqSupply
652 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
653 ; (_, env_state) = doFCode env_code info_down_for_body
654 (state {cgs_uniqs = us})
655 ; state_for_body = (initCgState (cgs_uniqs env_state))
656 { cgs_binds = binds_for_body,
657 cgs_stk_usg = stk_usg_for_body }
658 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
659 ; stk_usg_from_env = cgs_stk_usg env_state
660 ; virtSp_from_env = virtSp stk_usg_from_env
661 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
662 hwSp = virtSp_from_env}
663 ; (value_returned, state_at_end_return)
664 = doFCode body_code info_down_for_body state_for_body
666 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
667 -- The code coming back should consist only of nested declarations,
668 -- notably of the return vector!
669 setState $ state `stateIncUsageEval` state_at_end_return
670 ; return (virtSp_from_env, value_returned) }
673 -- ----------------------------------------------------------------------------
674 -- Combinators for emitting code
679 whenC :: Bool -> Code -> Code
680 whenC True code = code
681 whenC False code = nopC
683 stmtC :: CmmStmt -> Code
684 stmtC stmt = emitCgStmt (CgStmt stmt)
686 labelC :: BlockId -> Code
687 labelC id = emitCgStmt (CgLabel id)
689 newLabelC :: FCode BlockId
690 newLabelC = do { id <- newUnique; return (BlockId id) }
692 checkedAbsC :: CmmStmt -> Code
693 -- Emit code, eliminating no-ops
694 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
697 stmtsC :: [CmmStmt] -> Code
698 stmtsC stmts = emitStmts (toOL stmts)
700 -- Emit code; no no-op checking
701 emitStmts :: CmmStmts -> Code
702 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
704 -- forkLabelledCode is for emitting a chunk of code with a label, outside
705 -- of the current instruction stream.
706 forkLabelledCode :: Code -> FCode BlockId
707 forkLabelledCode code = getCgStmts code >>= forkCgStmts
709 emitCgStmt :: CgStmt -> Code
711 = do { state <- getState
712 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
715 emitData :: Section -> [CmmStatic] -> Code
717 = do { state <- getState
718 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
720 data_block = CmmData sect lits
722 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
723 emitProc lits lbl args blocks
724 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
726 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
728 emitSimpleProc :: CLabel -> Code -> Code
729 -- Emit a procedure whose body is the specified code; no info table
730 emitSimpleProc lbl code
731 = do { stmts <- getCgStmts code
732 ; blks <- cgStmtsToBlocks stmts
733 ; emitProc [] lbl [] blks }
735 getCmm :: Code -> FCode Cmm
736 -- Get all the CmmTops (there should be no stmts)
738 = do { state1 <- getState
739 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
740 ; setState $ state2 { cgs_tops = cgs_tops state1 }
741 ; return (Cmm (fromOL (cgs_tops state2))) }
743 -- ----------------------------------------------------------------------------
746 -- These functions deal in terms of CgStmts, which is an abstract type
747 -- representing the code in the current proc.
750 -- emit CgStmts into the current instruction stream
751 emitCgStmts :: CgStmts -> Code
753 = do { state <- getState
754 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
756 -- emit CgStmts outside the current instruction stream, and return a label
757 forkCgStmts :: CgStmts -> FCode BlockId
759 = do { id <- newLabelC
760 ; emitCgStmt (CgFork id stmts)
764 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
765 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
766 cgStmtsToBlocks stmts
767 = do { id <- newLabelC
768 ; return (flattenCgStmts id stmts)
771 -- collect the code emitted by an FCode computation
772 getCgStmts' :: FCode a -> FCode (a, CgStmts)
774 = do { state1 <- getState
775 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
776 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
777 ; return (a, cgs_stmts state2) }
779 getCgStmts :: FCode a -> FCode CgStmts
780 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
782 -- Simple ways to construct CgStmts:
786 oneCgStmt :: CmmStmt -> CgStmts
787 oneCgStmt stmt = unitOL (CgStmt stmt)
789 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
790 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
792 -- ----------------------------------------------------------------------------
793 -- Get the current module name
795 moduleName :: FCode Module
796 moduleName = do { info <- getInfoDown; return (cgd_mod info) }
798 -- ----------------------------------------------------------------------------
799 -- Get/set the end-of-block info
801 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
802 setEndOfBlockInfo eob_info code = do
804 withInfoDown code (info {cgd_eob = eob_info})
806 getEndOfBlockInfo :: FCode EndOfBlockInfo
807 getEndOfBlockInfo = do
809 return (cgd_eob info)
811 -- ----------------------------------------------------------------------------
812 -- Get/set the current SRT label
814 -- There is just one SRT for each top level binding; all the nested
815 -- bindings use sub-sections of this SRT. The label is passed down to
816 -- the nested bindings via the monad.
818 getSRTLabel :: FCode CLabel -- Used only by cgPanic
819 getSRTLabel = do info <- getInfoDown
820 return (cgd_srt info)
822 setSRTLabel :: CLabel -> FCode a -> FCode a
823 setSRTLabel srt_lbl code
824 = do info <- getInfoDown
825 withInfoDown code (info { cgd_srt = srt_lbl})
827 -- ----------------------------------------------------------------------------
828 -- Get/set the current ticky counter label
830 getTickyCtrLabel :: FCode CLabel
831 getTickyCtrLabel = do
833 return (cgd_ticky info)
835 setTickyCtrLabel :: CLabel -> Code -> Code
836 setTickyCtrLabel ticky code = do
838 withInfoDown code (info {cgd_ticky = ticky})