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,
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 )
84 infixr 9 `thenC` -- Right-associative!
88 %************************************************************************
90 \subsection[CgMonad-environment]{Stuff for manipulating environments}
92 %************************************************************************
94 This monadery has some information that it only passes {\em
95 downwards}, as well as some ``state'' which is modified as we go
99 data CgInfoDownwards -- information only passed *downwards* by the monad
101 cgd_dflags :: DynFlags,
102 cgd_mod :: Module, -- Module being compiled
103 cgd_statics :: CgBindings, -- [Id -> info] : static environment
104 cgd_srt_lbl :: CLabel, -- label of the current SRT
105 cgd_srt :: SRT, -- the current SRT
106 cgd_ticky :: CLabel, -- current destination for ticky counts
107 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
110 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
111 initCgInfoDown dflags mod
112 = MkCgInfoDown { cgd_dflags = dflags,
114 cgd_statics = emptyVarEnv,
115 cgd_srt_lbl = error "initC: srt_lbl",
116 cgd_srt = error "initC: srt",
117 cgd_ticky = mkTopTickyCtrLabel,
118 cgd_eob = initEobInfo }
122 cgs_stmts :: OrdList CgStmt, -- Current proc
123 cgs_tops :: OrdList CmmTop,
124 -- Other procedures and data blocks in this compilation unit
125 -- Both the latter two are ordered only so that we can
126 -- reduce forward references, when it's easy to do so
128 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
129 -- Bindings for top-level things are given in
130 -- the info-down part
132 cgs_stk_usg :: StackUsage,
133 cgs_hp_usg :: HeapUsage,
135 cgs_uniqs :: UniqSupply }
137 initCgState :: UniqSupply -> CgState
139 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
140 cgs_binds = emptyVarEnv,
141 cgs_stk_usg = initStkUsage,
142 cgs_hp_usg = initHpUsage,
146 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
147 if the expression is a @case@, what to do at the end of each
153 VirtualSpOffset -- Args Sp: trim the stack to this point at a
154 -- return; push arguments starting just
155 -- above this point on a tail call.
157 -- This is therefore the stk ptr as seen
158 -- by a case alternative.
161 initEobInfo = EndOfBlockInfo 0 OnStack
164 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
165 that it must survive stack pointer adjustments at the end of the
170 = OnStack -- Continuation is on the stack
171 | UpdateCode -- Continuation is update
174 CLabel -- Jump to this; if the continuation is for a vectored
175 -- case this might be the label of a return vector
177 Id -- The case binder, only used to see if it's dead
179 type SemiTaggingStuff
180 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
181 ([(ConTagZ, CmmLit)], -- Alternatives
182 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
184 type ConTagZ = Int -- A *zero-indexed* contructor tag
186 -- The case branch is executed only from a successful semitagging
187 -- venture, when a case has looked at a variable, found that it's
188 -- evaluated, and wants to load up the contents and go to the join
192 %************************************************************************
196 %************************************************************************
198 The CgStmts type is what the code generator outputs: it is a tree of
199 statements, including in-line labels. The job of flattenCgStmts is to
200 turn this into a list of basic blocks, each of which ends in a jump
201 statement (either a local branch or a non-local jump).
204 type CgStmts = OrdList CgStmt
209 | CgFork BlockId CgStmts
211 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
212 flattenCgStmts id stmts =
213 case flatten (fromOL stmts) of
214 ([],blocks) -> blocks
215 (block,blocks) -> BasicBlock id block : blocks
219 -- A label at the end of a function or fork: this label must not be reachable,
220 -- but it might be referred to from another BB that also isn't reachable.
221 -- Eliminating these has to be done with a dead-code analysis. For now,
222 -- we just make it into a well-formed block by adding a recursive jump.
224 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
226 -- A jump/branch: throw away all the code up to the next label, because
227 -- it is unreachable. Be careful to keep forks that we find on the way.
228 flatten (CgStmt stmt : stmts)
230 = case dropWhile isOrdinaryStmt stmts of
232 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
233 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
234 where (block,blocks) = flatten stmts
235 (CgFork fork_id stmts : ss) ->
236 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
240 CgStmt stmt -> (stmt:block,blocks)
241 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
242 CgFork fork_id stmts ->
243 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
244 where (fork_block, fork_blocks) = flatten (fromOL stmts)
245 where (block,blocks) = flatten ss
247 isJump (CmmJump _ _) = True
248 isJump (CmmBranch _) = True
249 isJump (CmmSwitch _ _) = True
252 isOrdinaryStmt (CgStmt _) = True
253 isOrdinaryStmt _ = False
256 %************************************************************************
258 Stack and heap models
260 %************************************************************************
263 type VirtualHpOffset = WordOff -- Both are in
264 type VirtualSpOffset = WordOff -- units of words
268 virtSp :: VirtualSpOffset,
269 -- Virtual offset of topmost allocated slot
271 frameSp :: VirtualSpOffset,
272 -- Virtual offset of the return address of the enclosing frame.
273 -- This RA describes the liveness/pointedness of
274 -- all the stack from frameSp downwards
275 -- INVARIANT: less than or equal to virtSp
277 freeStk :: [VirtualSpOffset],
278 -- List of free slots, in *increasing* order
279 -- INVARIANT: all <= virtSp
280 -- All slots <= virtSp are taken except these ones
282 realSp :: VirtualSpOffset,
283 -- Virtual offset of real stack pointer register
285 hwSp :: VirtualSpOffset
286 } -- Highest value ever taken by virtSp
288 -- INVARIANT: The environment contains no Stable references to
289 -- stack slots below (lower offset) frameSp
290 -- It can contain volatile references to this area though.
294 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
295 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
299 The heap high water mark is the larger of virtHp and hwHp. The latter is
300 only records the high water marks of forked-off branches, so to find the
301 heap high water mark you have to take the max of virtHp and hwHp. Remember,
302 virtHp never retreats!
304 Note Jan 04: ok, so why do we only look at the virtual Hp??
307 heapHWM :: HeapUsage -> VirtualHpOffset
314 initStkUsage :: StackUsage
315 initStkUsage = StackUsage {
323 initHpUsage :: HeapUsage
324 initHpUsage = HeapUsage {
330 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
331 marks found in $e_2$.
334 stateIncUsage :: CgState -> CgState -> CgState
335 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
336 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
337 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
338 `addCodeBlocksFrom` s2
340 stateIncUsageEval :: CgState -> CgState -> CgState
341 stateIncUsageEval s1 s2
342 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
343 `addCodeBlocksFrom` s2
344 -- We don't max the heap high-watermark because stateIncUsageEval is
345 -- used only in forkEval, which in turn is only used for blocks of code
346 -- which do their own heap-check.
348 addCodeBlocksFrom :: CgState -> CgState -> CgState
349 -- Add code blocks from the latter to the former
350 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
351 s1 `addCodeBlocksFrom` s2
352 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
353 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
355 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
356 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
358 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
359 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
362 %************************************************************************
366 %************************************************************************
369 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
372 instance Monad FCode where
377 {-# INLINE thenFC #-}
378 {-# INLINE returnFC #-}
380 The Abstract~C is not in the environment so as to improve strictness.
383 initC :: DynFlags -> Module -> FCode a -> IO a
385 initC dflags mod (FCode code)
386 = do { uniqs <- mkSplitUniqSupply 'c'
387 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
388 (res, _) -> return res
391 returnFC :: a -> FCode a
392 returnFC val = FCode (\info_down state -> (val, state))
396 thenC :: Code -> FCode a -> FCode a
397 thenC (FCode m) (FCode k) =
398 FCode (\info_down state -> let (_,new_state) = m info_down state in
399 k info_down new_state)
401 listCs :: [Code] -> Code
402 listCs [] = return ()
407 mapCs :: (a -> Code) -> [a] -> Code
412 thenFC :: FCode a -> (a -> FCode c) -> FCode c
413 thenFC (FCode m) k = FCode (
416 (m_result, new_state) = m info_down state
417 (FCode kcode) = k m_result
419 kcode info_down new_state
422 listFCs :: [FCode a] -> FCode [a]
425 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
429 And the knot-tying combinator:
431 fixC :: (a -> FCode a) -> FCode a
436 result@(v,_) = fc info_down state
443 %************************************************************************
445 Operators for getting and setting the state and "info_down".
448 %************************************************************************
451 getState :: FCode CgState
452 getState = FCode $ \info_down state -> (state,state)
454 setState :: CgState -> FCode ()
455 setState state = FCode $ \info_down _ -> ((),state)
457 getStkUsage :: FCode StackUsage
460 return $ cgs_stk_usg state
462 setStkUsage :: StackUsage -> Code
463 setStkUsage new_stk_usg = do
465 setState $ state {cgs_stk_usg = new_stk_usg}
467 getHpUsage :: FCode HeapUsage
470 return $ cgs_hp_usg state
472 setHpUsage :: HeapUsage -> Code
473 setHpUsage new_hp_usg = do
475 setState $ state {cgs_hp_usg = new_hp_usg}
477 getBinds :: FCode CgBindings
480 return $ cgs_binds state
482 setBinds :: CgBindings -> FCode ()
483 setBinds new_binds = do
485 setState $ state {cgs_binds = new_binds}
487 getStaticBinds :: FCode CgBindings
490 return (cgd_statics info)
492 withState :: FCode a -> CgState -> FCode (a,CgState)
493 withState (FCode fcode) newstate = FCode $ \info_down state ->
494 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
496 newUniqSupply :: FCode UniqSupply
499 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
500 setState $ state { cgs_uniqs = us1 }
503 newUnique :: FCode Unique
506 return (uniqFromSupply us)
509 getInfoDown :: FCode CgInfoDownwards
510 getInfoDown = FCode $ \info_down state -> (info_down,state)
512 getDynFlags :: FCode DynFlags
513 getDynFlags = liftM cgd_dflags getInfoDown
515 getThisPackage :: FCode PackageId
516 getThisPackage = liftM thisPackage getDynFlags
518 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
519 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
521 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
522 doFCode (FCode fcode) info_down state = fcode info_down state
526 %************************************************************************
530 %************************************************************************
532 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
533 fresh environment, except that:
534 - compilation info and statics are passed in unchanged.
535 The current environment is passed on completely unaltered, except that
536 abstract C from the fork is incorporated.
538 @forkProc@ takes a code and compiles it in the current environment,
539 returning the basic blocks thus constructed. The current environment
540 is passed on completely unchanged. It is pretty similar to
541 @getBlocks@, except that the latter does affect the environment.
543 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
544 from the current bindings, but which is otherwise freshly initialised.
545 The Abstract~C returned is attached to the current state, but the
546 bindings and usage information is otherwise unchanged.
549 forkClosureBody :: Code -> Code
550 forkClosureBody body_code
551 = do { info <- getInfoDown
552 ; us <- newUniqSupply
554 ; let body_info_down = info { cgd_eob = initEobInfo }
555 ((),fork_state) = doFCode body_code body_info_down
557 ; ASSERT( isNilOL (cgs_stmts fork_state) )
558 setState $ state `addCodeBlocksFrom` fork_state }
560 forkStatics :: FCode a -> FCode a
561 forkStatics body_code
562 = do { info <- getInfoDown
563 ; us <- newUniqSupply
565 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
566 cgd_eob = initEobInfo }
567 (result, fork_state_out) = doFCode body_code rhs_info_down
569 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
570 setState (state `addCodeBlocksFrom` fork_state_out)
573 forkProc :: Code -> FCode CgStmts
575 = do { info_down <- getInfoDown
576 ; us <- newUniqSupply
578 ; let fork_state_in = (initCgState us)
579 { cgs_binds = cgs_binds state,
580 cgs_stk_usg = cgs_stk_usg state,
581 cgs_hp_usg = cgs_hp_usg state }
582 -- ToDo: is the hp usage necesary?
583 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
584 info_down fork_state_in
585 ; setState $ state `stateIncUsageEval` fork_state_out
588 codeOnly :: Code -> Code
589 -- Emit any code from the inner thing into the outer thing
590 -- Do not affect anything else in the outer state
591 -- Used in almost-circular code to prevent false loop dependencies
593 = do { info_down <- getInfoDown
594 ; us <- newUniqSupply
596 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
597 cgs_stk_usg = cgs_stk_usg state,
598 cgs_hp_usg = cgs_hp_usg state }
599 ((), fork_state_out) = doFCode body_code info_down fork_state_in
600 ; setState $ state `addCodeBlocksFrom` fork_state_out }
603 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
604 an fcode for the default case $d$, and compiles each in the current
605 environment. The current environment is passed on unmodified, except
607 - the worst stack high-water mark is incorporated
608 - the virtual Hp is moved on to the worst virtual Hp for the branches
611 forkAlts :: [FCode a] -> FCode [a]
613 forkAlts branch_fcodes
614 = do { info_down <- getInfoDown
615 ; us <- newUniqSupply
617 ; let compile us branch
618 = (us2, doFCode branch info_down branch_state)
620 (us1,us2) = splitUniqSupply us
621 branch_state = (initCgState us1) {
622 cgs_binds = cgs_binds state,
623 cgs_stk_usg = cgs_stk_usg state,
624 cgs_hp_usg = cgs_hp_usg state }
626 (_us, results) = mapAccumL compile us branch_fcodes
627 (branch_results, branch_out_states) = unzip results
628 ; setState $ foldl stateIncUsage state branch_out_states
629 -- NB foldl. state is the *left* argument to stateIncUsage
630 ; return branch_results }
633 @forkEval@ takes two blocks of code.
635 - The first meddles with the environment to set it up as expected by
636 the alternatives of a @case@ which does an eval (or gc-possible primop).
637 - The second block is the code for the alternatives.
638 (plus info for semi-tagging purposes)
640 @forkEval@ picks up the virtual stack pointer and returns a suitable
641 @EndOfBlockInfo@ for the caller to use, together with whatever value
642 is returned by the second block.
644 It uses @initEnvForAlternatives@ to initialise the environment, and
645 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
649 forkEval :: EndOfBlockInfo -- For the body
650 -> Code -- Code to set environment
651 -> FCode Sequel -- Semi-tagging info to store
652 -> FCode EndOfBlockInfo -- The new end of block info
654 forkEval body_eob_info env_code body_code
655 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
656 ; returnFC (EndOfBlockInfo v sequel) }
658 forkEvalHelp :: EndOfBlockInfo -- For the body
659 -> Code -- Code to set environment
660 -> FCode a -- The code to do after the eval
661 -> FCode (VirtualSpOffset, -- Sp
662 a) -- Result of the FCode
663 -- A disturbingly complicated function
664 forkEvalHelp body_eob_info env_code body_code
665 = do { info_down <- getInfoDown
666 ; us <- newUniqSupply
668 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
669 ; (_, env_state) = doFCode env_code info_down_for_body
670 (state {cgs_uniqs = us})
671 ; state_for_body = (initCgState (cgs_uniqs env_state))
672 { cgs_binds = binds_for_body,
673 cgs_stk_usg = stk_usg_for_body }
674 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
675 ; stk_usg_from_env = cgs_stk_usg env_state
676 ; virtSp_from_env = virtSp stk_usg_from_env
677 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
678 hwSp = virtSp_from_env}
679 ; (value_returned, state_at_end_return)
680 = doFCode body_code info_down_for_body state_for_body
682 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
683 -- The code coming back should consist only of nested declarations,
684 -- notably of the return vector!
685 setState $ state `stateIncUsageEval` state_at_end_return
686 ; return (virtSp_from_env, value_returned) }
689 -- ----------------------------------------------------------------------------
690 -- Combinators for emitting code
695 whenC :: Bool -> Code -> Code
696 whenC True code = code
697 whenC False code = nopC
699 stmtC :: CmmStmt -> Code
700 stmtC stmt = emitCgStmt (CgStmt stmt)
702 labelC :: BlockId -> Code
703 labelC id = emitCgStmt (CgLabel id)
705 newLabelC :: FCode BlockId
706 newLabelC = do { id <- newUnique; return (BlockId id) }
708 checkedAbsC :: CmmStmt -> Code
709 -- Emit code, eliminating no-ops
710 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
713 stmtsC :: [CmmStmt] -> Code
714 stmtsC stmts = emitStmts (toOL stmts)
716 -- Emit code; no no-op checking
717 emitStmts :: CmmStmts -> Code
718 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
720 -- forkLabelledCode is for emitting a chunk of code with a label, outside
721 -- of the current instruction stream.
722 forkLabelledCode :: Code -> FCode BlockId
723 forkLabelledCode code = getCgStmts code >>= forkCgStmts
725 emitCgStmt :: CgStmt -> Code
727 = do { state <- getState
728 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
731 emitData :: Section -> [CmmStatic] -> Code
733 = do { state <- getState
734 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
736 data_block = CmmData sect lits
738 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
739 emitProc info lbl args blocks
740 = do { let proc_block = CmmProc info lbl args blocks
742 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
744 emitSimpleProc :: CLabel -> Code -> Code
745 -- Emit a procedure whose body is the specified code; no info table
746 emitSimpleProc lbl code
747 = do { stmts <- getCgStmts code
748 ; blks <- cgStmtsToBlocks stmts
749 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
751 getCmm :: Code -> FCode Cmm
752 -- Get all the CmmTops (there should be no stmts)
754 = do { state1 <- getState
755 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
756 ; setState $ state2 { cgs_tops = cgs_tops state1 }
757 ; return (Cmm (fromOL (cgs_tops state2))) }
759 -- ----------------------------------------------------------------------------
762 -- These functions deal in terms of CgStmts, which is an abstract type
763 -- representing the code in the current proc.
766 -- emit CgStmts into the current instruction stream
767 emitCgStmts :: CgStmts -> Code
769 = do { state <- getState
770 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
772 -- emit CgStmts outside the current instruction stream, and return a label
773 forkCgStmts :: CgStmts -> FCode BlockId
775 = do { id <- newLabelC
776 ; emitCgStmt (CgFork id stmts)
780 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
781 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
782 cgStmtsToBlocks stmts
783 = do { id <- newLabelC
784 ; return (flattenCgStmts id stmts)
787 -- collect the code emitted by an FCode computation
788 getCgStmts' :: FCode a -> FCode (a, CgStmts)
790 = do { state1 <- getState
791 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
792 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
793 ; return (a, cgs_stmts state2) }
795 getCgStmts :: FCode a -> FCode CgStmts
796 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
798 -- Simple ways to construct CgStmts:
802 oneCgStmt :: CmmStmt -> CgStmts
803 oneCgStmt stmt = unitOL (CgStmt stmt)
805 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
806 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
808 -- ----------------------------------------------------------------------------
809 -- Get the current module name
811 getModuleName :: FCode Module
812 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
814 -- ----------------------------------------------------------------------------
815 -- Get/set the end-of-block info
817 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
818 setEndOfBlockInfo eob_info code = do
820 withInfoDown code (info {cgd_eob = eob_info})
822 getEndOfBlockInfo :: FCode EndOfBlockInfo
823 getEndOfBlockInfo = do
825 return (cgd_eob info)
827 -- ----------------------------------------------------------------------------
828 -- Get/set the current SRT label
830 -- There is just one SRT for each top level binding; all the nested
831 -- bindings use sub-sections of this SRT. The label is passed down to
832 -- the nested bindings via the monad.
834 getSRTLabel :: FCode CLabel -- Used only by cgPanic
835 getSRTLabel = do info <- getInfoDown
836 return (cgd_srt_lbl info)
838 setSRTLabel :: CLabel -> FCode a -> FCode a
839 setSRTLabel srt_lbl code
840 = do info <- getInfoDown
841 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
844 getSRT = do info <- getInfoDown
845 return (cgd_srt info)
847 setSRT :: SRT -> FCode a -> FCode a
849 = do info <- getInfoDown
850 withInfoDown code (info { cgd_srt = srt})
852 -- ----------------------------------------------------------------------------
853 -- Get/set the current ticky counter label
855 getTickyCtrLabel :: FCode CLabel
856 getTickyCtrLabel = do
858 return (cgd_ticky info)
860 setTickyCtrLabel :: CLabel -> Code -> Code
861 setTickyCtrLabel ticky code = do
863 withInfoDown code (info {cgd_ticky = ticky})