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.
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and fix
14 -- any warnings in the module. See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
23 returnFC, fixC, checkedAbsC,
24 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
25 newUnique, newUniqSupply,
27 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
28 getCgStmts', getCgStmts,
29 noCgStmts, oneCgStmt, consCgStmt,
32 emitData, emitProc, emitSimpleProc,
35 forkClosureBody, forkStatics, forkAlts, forkEval,
36 forkEvalHelp, forkProc, codeOnly,
37 SemiTaggingStuff, ConTagZ,
40 setEndOfBlockInfo, getEndOfBlockInfo,
43 setSRTLabel, getSRTLabel,
44 setTickyCtrLabel, getTickyCtrLabel,
46 StackUsage(..), HeapUsage(..),
47 VirtualSpOffset, VirtualHpOffset,
48 initStkUsage, initHpUsage,
49 getHpUsage, setHpUsage,
54 Sequel(..), -- ToDo: unabstract?
56 -- ideally we wouldn't export these, but some other modules access internal state
57 getState, setState, getInfoDown, getDynFlags, getThisPackage,
59 -- more localised access to monad state
60 getStkUsage, setStkUsage,
61 getBinds, setBinds, getStaticBinds,
63 -- out of general friendliness, we also export ...
64 CgInfoDownwards(..), CgState(..) -- non-abstract
67 #include "HsVersions.h"
69 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
91 infixr 9 `thenC` -- Right-associative!
95 %************************************************************************
97 \subsection[CgMonad-environment]{Stuff for manipulating environments}
99 %************************************************************************
101 This monadery has some information that it only passes {\em
102 downwards}, as well as some ``state'' which is modified as we go
106 data CgInfoDownwards -- information only passed *downwards* by the monad
108 cgd_dflags :: DynFlags,
109 cgd_mod :: Module, -- Module being compiled
110 cgd_statics :: CgBindings, -- [Id -> info] : static environment
111 cgd_srt_lbl :: CLabel, -- label of the current SRT
112 cgd_srt :: SRT, -- the current SRT
113 cgd_ticky :: CLabel, -- current destination for ticky counts
114 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
117 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
118 initCgInfoDown dflags mod
119 = MkCgInfoDown { cgd_dflags = dflags,
121 cgd_statics = emptyVarEnv,
122 cgd_srt_lbl = error "initC: srt_lbl",
123 cgd_srt = error "initC: srt",
124 cgd_ticky = mkTopTickyCtrLabel,
125 cgd_eob = initEobInfo }
129 cgs_stmts :: OrdList CgStmt, -- Current proc
130 cgs_tops :: OrdList CmmTop,
131 -- Other procedures and data blocks in this compilation unit
132 -- Both the latter two are ordered only so that we can
133 -- reduce forward references, when it's easy to do so
135 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
136 -- Bindings for top-level things are given in
137 -- the info-down part
139 cgs_stk_usg :: StackUsage,
140 cgs_hp_usg :: HeapUsage,
142 cgs_uniqs :: UniqSupply }
144 initCgState :: UniqSupply -> CgState
146 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
147 cgs_binds = emptyVarEnv,
148 cgs_stk_usg = initStkUsage,
149 cgs_hp_usg = initHpUsage,
153 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
154 if the expression is a @case@, what to do at the end of each
160 VirtualSpOffset -- Args Sp: trim the stack to this point at a
161 -- return; push arguments starting just
162 -- above this point on a tail call.
164 -- This is therefore the stk ptr as seen
165 -- by a case alternative.
168 initEobInfo = EndOfBlockInfo 0 OnStack
171 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
172 that it must survive stack pointer adjustments at the end of the
177 = OnStack -- Continuation is on the stack
178 | UpdateCode -- Continuation is update
181 CLabel -- Jump to this; if the continuation is for a vectored
182 -- case this might be the label of a return vector
184 Id -- The case binder, only used to see if it's dead
186 type SemiTaggingStuff
187 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
188 ([(ConTagZ, CmmLit)], -- Alternatives
189 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
191 type ConTagZ = Int -- A *zero-indexed* contructor tag
193 -- The case branch is executed only from a successful semitagging
194 -- venture, when a case has looked at a variable, found that it's
195 -- evaluated, and wants to load up the contents and go to the join
199 %************************************************************************
203 %************************************************************************
205 The CgStmts type is what the code generator outputs: it is a tree of
206 statements, including in-line labels. The job of flattenCgStmts is to
207 turn this into a list of basic blocks, each of which ends in a jump
208 statement (either a local branch or a non-local jump).
211 type CgStmts = OrdList CgStmt
216 | CgFork BlockId CgStmts
218 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
219 flattenCgStmts id stmts =
220 case flatten (fromOL stmts) of
221 ([],blocks) -> blocks
222 (block,blocks) -> BasicBlock id block : blocks
226 -- A label at the end of a function or fork: this label must not be reachable,
227 -- but it might be referred to from another BB that also isn't reachable.
228 -- Eliminating these has to be done with a dead-code analysis. For now,
229 -- we just make it into a well-formed block by adding a recursive jump.
231 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
233 -- A jump/branch: throw away all the code up to the next label, because
234 -- it is unreachable. Be careful to keep forks that we find on the way.
235 flatten (CgStmt stmt : stmts)
237 = case dropWhile isOrdinaryStmt stmts of
239 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
240 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
241 where (block,blocks) = flatten stmts
242 (CgFork fork_id stmts : ss) ->
243 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
247 CgStmt stmt -> (stmt:block,blocks)
248 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
249 CgFork fork_id stmts ->
250 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
251 where (fork_block, fork_blocks) = flatten (fromOL stmts)
252 where (block,blocks) = flatten ss
254 isJump (CmmJump _ _) = True
255 isJump (CmmBranch _) = True
256 isJump (CmmSwitch _ _) = True
257 isJump (CmmReturn _) = True
260 isOrdinaryStmt (CgStmt _) = True
261 isOrdinaryStmt _ = False
264 %************************************************************************
266 Stack and heap models
268 %************************************************************************
271 type VirtualHpOffset = WordOff -- Both are in
272 type VirtualSpOffset = WordOff -- units of words
276 virtSp :: VirtualSpOffset,
277 -- Virtual offset of topmost allocated slot
279 frameSp :: VirtualSpOffset,
280 -- Virtual offset of the return address of the enclosing frame.
281 -- This RA describes the liveness/pointedness of
282 -- all the stack from frameSp downwards
283 -- INVARIANT: less than or equal to virtSp
285 freeStk :: [VirtualSpOffset],
286 -- List of free slots, in *increasing* order
287 -- INVARIANT: all <= virtSp
288 -- All slots <= virtSp are taken except these ones
290 realSp :: VirtualSpOffset,
291 -- Virtual offset of real stack pointer register
293 hwSp :: VirtualSpOffset
294 } -- Highest value ever taken by virtSp
296 -- INVARIANT: The environment contains no Stable references to
297 -- stack slots below (lower offset) frameSp
298 -- It can contain volatile references to this area though.
302 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
303 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
307 The heap high water mark is the larger of virtHp and hwHp. The latter is
308 only records the high water marks of forked-off branches, so to find the
309 heap high water mark you have to take the max of virtHp and hwHp. Remember,
310 virtHp never retreats!
312 Note Jan 04: ok, so why do we only look at the virtual Hp??
315 heapHWM :: HeapUsage -> VirtualHpOffset
322 initStkUsage :: StackUsage
323 initStkUsage = StackUsage {
331 initHpUsage :: HeapUsage
332 initHpUsage = HeapUsage {
338 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
339 marks found in $e_2$.
342 stateIncUsage :: CgState -> CgState -> CgState
343 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
344 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
345 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
346 `addCodeBlocksFrom` s2
348 stateIncUsageEval :: CgState -> CgState -> CgState
349 stateIncUsageEval s1 s2
350 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
351 `addCodeBlocksFrom` s2
352 -- We don't max the heap high-watermark because stateIncUsageEval is
353 -- used only in forkEval, which in turn is only used for blocks of code
354 -- which do their own heap-check.
356 addCodeBlocksFrom :: CgState -> CgState -> CgState
357 -- Add code blocks from the latter to the former
358 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
359 s1 `addCodeBlocksFrom` s2
360 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
361 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
363 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
364 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
366 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
367 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
370 %************************************************************************
374 %************************************************************************
377 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
380 instance Monad FCode where
385 {-# INLINE thenFC #-}
386 {-# INLINE returnFC #-}
388 The Abstract~C is not in the environment so as to improve strictness.
391 initC :: DynFlags -> Module -> FCode a -> IO a
393 initC dflags mod (FCode code)
394 = do { uniqs <- mkSplitUniqSupply 'c'
395 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
396 (res, _) -> return res
399 returnFC :: a -> FCode a
400 returnFC val = FCode (\info_down state -> (val, state))
404 thenC :: Code -> FCode a -> FCode a
405 thenC (FCode m) (FCode k) =
406 FCode (\info_down state -> let (_,new_state) = m info_down state in
407 k info_down new_state)
409 listCs :: [Code] -> Code
410 listCs [] = return ()
415 mapCs :: (a -> Code) -> [a] -> Code
420 thenFC :: FCode a -> (a -> FCode c) -> FCode c
421 thenFC (FCode m) k = FCode (
424 (m_result, new_state) = m info_down state
425 (FCode kcode) = k m_result
427 kcode info_down new_state
430 listFCs :: [FCode a] -> FCode [a]
433 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
437 And the knot-tying combinator:
439 fixC :: (a -> FCode a) -> FCode a
444 result@(v,_) = fc info_down state
451 %************************************************************************
453 Operators for getting and setting the state and "info_down".
456 %************************************************************************
459 getState :: FCode CgState
460 getState = FCode $ \info_down state -> (state,state)
462 setState :: CgState -> FCode ()
463 setState state = FCode $ \info_down _ -> ((),state)
465 getStkUsage :: FCode StackUsage
468 return $ cgs_stk_usg state
470 setStkUsage :: StackUsage -> Code
471 setStkUsage new_stk_usg = do
473 setState $ state {cgs_stk_usg = new_stk_usg}
475 getHpUsage :: FCode HeapUsage
478 return $ cgs_hp_usg state
480 setHpUsage :: HeapUsage -> Code
481 setHpUsage new_hp_usg = do
483 setState $ state {cgs_hp_usg = new_hp_usg}
485 getBinds :: FCode CgBindings
488 return $ cgs_binds state
490 setBinds :: CgBindings -> FCode ()
491 setBinds new_binds = do
493 setState $ state {cgs_binds = new_binds}
495 getStaticBinds :: FCode CgBindings
498 return (cgd_statics info)
500 withState :: FCode a -> CgState -> FCode (a,CgState)
501 withState (FCode fcode) newstate = FCode $ \info_down state ->
502 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
504 newUniqSupply :: FCode UniqSupply
507 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
508 setState $ state { cgs_uniqs = us1 }
511 newUnique :: FCode Unique
514 return (uniqFromSupply us)
517 getInfoDown :: FCode CgInfoDownwards
518 getInfoDown = FCode $ \info_down state -> (info_down,state)
520 getDynFlags :: FCode DynFlags
521 getDynFlags = liftM cgd_dflags getInfoDown
523 getThisPackage :: FCode PackageId
524 getThisPackage = liftM thisPackage getDynFlags
526 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
527 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
529 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
530 doFCode (FCode fcode) info_down state = fcode info_down state
534 %************************************************************************
538 %************************************************************************
540 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
541 fresh environment, except that:
542 - compilation info and statics are passed in unchanged.
543 The current environment is passed on completely unaltered, except that
544 abstract C from the fork is incorporated.
546 @forkProc@ takes a code and compiles it in the current environment,
547 returning the basic blocks thus constructed. The current environment
548 is passed on completely unchanged. It is pretty similar to
549 @getBlocks@, except that the latter does affect the environment.
551 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
552 from the current bindings, but which is otherwise freshly initialised.
553 The Abstract~C returned is attached to the current state, but the
554 bindings and usage information is otherwise unchanged.
557 forkClosureBody :: Code -> Code
558 forkClosureBody body_code
559 = do { info <- getInfoDown
560 ; us <- newUniqSupply
562 ; let body_info_down = info { cgd_eob = initEobInfo }
563 ((),fork_state) = doFCode body_code body_info_down
565 ; ASSERT( isNilOL (cgs_stmts fork_state) )
566 setState $ state `addCodeBlocksFrom` fork_state }
568 forkStatics :: FCode a -> FCode a
569 forkStatics body_code
570 = do { info <- getInfoDown
571 ; us <- newUniqSupply
573 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
574 cgd_eob = initEobInfo }
575 (result, fork_state_out) = doFCode body_code rhs_info_down
577 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
578 setState (state `addCodeBlocksFrom` fork_state_out)
581 forkProc :: Code -> FCode CgStmts
583 = do { info_down <- getInfoDown
584 ; us <- newUniqSupply
586 ; let fork_state_in = (initCgState us)
587 { cgs_binds = cgs_binds state,
588 cgs_stk_usg = cgs_stk_usg state,
589 cgs_hp_usg = cgs_hp_usg state }
590 -- ToDo: is the hp usage necesary?
591 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
592 info_down fork_state_in
593 ; setState $ state `stateIncUsageEval` fork_state_out
596 codeOnly :: Code -> Code
597 -- Emit any code from the inner thing into the outer thing
598 -- Do not affect anything else in the outer state
599 -- Used in almost-circular code to prevent false loop dependencies
601 = do { info_down <- getInfoDown
602 ; us <- newUniqSupply
604 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
605 cgs_stk_usg = cgs_stk_usg state,
606 cgs_hp_usg = cgs_hp_usg state }
607 ((), fork_state_out) = doFCode body_code info_down fork_state_in
608 ; setState $ state `addCodeBlocksFrom` fork_state_out }
611 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
612 an fcode for the default case $d$, and compiles each in the current
613 environment. The current environment is passed on unmodified, except
615 - the worst stack high-water mark is incorporated
616 - the virtual Hp is moved on to the worst virtual Hp for the branches
619 forkAlts :: [FCode a] -> FCode [a]
621 forkAlts branch_fcodes
622 = do { info_down <- getInfoDown
623 ; us <- newUniqSupply
625 ; let compile us branch
626 = (us2, doFCode branch info_down branch_state)
628 (us1,us2) = splitUniqSupply us
629 branch_state = (initCgState us1) {
630 cgs_binds = cgs_binds state,
631 cgs_stk_usg = cgs_stk_usg state,
632 cgs_hp_usg = cgs_hp_usg state }
634 (_us, results) = mapAccumL compile us branch_fcodes
635 (branch_results, branch_out_states) = unzip results
636 ; setState $ foldl stateIncUsage state branch_out_states
637 -- NB foldl. state is the *left* argument to stateIncUsage
638 ; return branch_results }
641 @forkEval@ takes two blocks of code.
643 - The first meddles with the environment to set it up as expected by
644 the alternatives of a @case@ which does an eval (or gc-possible primop).
645 - The second block is the code for the alternatives.
646 (plus info for semi-tagging purposes)
648 @forkEval@ picks up the virtual stack pointer and returns a suitable
649 @EndOfBlockInfo@ for the caller to use, together with whatever value
650 is returned by the second block.
652 It uses @initEnvForAlternatives@ to initialise the environment, and
653 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
657 forkEval :: EndOfBlockInfo -- For the body
658 -> Code -- Code to set environment
659 -> FCode Sequel -- Semi-tagging info to store
660 -> FCode EndOfBlockInfo -- The new end of block info
662 forkEval body_eob_info env_code body_code
663 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
664 ; returnFC (EndOfBlockInfo v sequel) }
666 forkEvalHelp :: EndOfBlockInfo -- For the body
667 -> Code -- Code to set environment
668 -> FCode a -- The code to do after the eval
669 -> FCode (VirtualSpOffset, -- Sp
670 a) -- Result of the FCode
671 -- A disturbingly complicated function
672 forkEvalHelp body_eob_info env_code body_code
673 = do { info_down <- getInfoDown
674 ; us <- newUniqSupply
676 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
677 ; (_, env_state) = doFCode env_code info_down_for_body
678 (state {cgs_uniqs = us})
679 ; state_for_body = (initCgState (cgs_uniqs env_state))
680 { cgs_binds = binds_for_body,
681 cgs_stk_usg = stk_usg_for_body }
682 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
683 ; stk_usg_from_env = cgs_stk_usg env_state
684 ; virtSp_from_env = virtSp stk_usg_from_env
685 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
686 hwSp = virtSp_from_env}
687 ; (value_returned, state_at_end_return)
688 = doFCode body_code info_down_for_body state_for_body
690 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
691 -- The code coming back should consist only of nested declarations,
692 -- notably of the return vector!
693 setState $ state `stateIncUsageEval` state_at_end_return
694 ; return (virtSp_from_env, value_returned) }
697 -- ----------------------------------------------------------------------------
698 -- Combinators for emitting code
703 whenC :: Bool -> Code -> Code
704 whenC True code = code
705 whenC False code = nopC
707 stmtC :: CmmStmt -> Code
708 stmtC stmt = emitCgStmt (CgStmt stmt)
710 labelC :: BlockId -> Code
711 labelC id = emitCgStmt (CgLabel id)
713 newLabelC :: FCode BlockId
714 newLabelC = do { id <- newUnique; return (BlockId id) }
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 -> CmmFormals -> [CmmBasicBlock] -> Code
747 emitProc info lbl args blocks
748 = do { let proc_block = CmmProc info lbl args blocks
750 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
752 emitSimpleProc :: CLabel -> Code -> Code
753 -- Emit a procedure whose body is the specified code; no info table
754 emitSimpleProc lbl code
755 = do { stmts <- getCgStmts code
756 ; blks <- cgStmtsToBlocks stmts
757 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
759 getCmm :: Code -> FCode Cmm
760 -- Get all the CmmTops (there should be no stmts)
762 = do { state1 <- getState
763 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
764 ; setState $ state2 { cgs_tops = cgs_tops state1 }
765 ; return (Cmm (fromOL (cgs_tops state2))) }
767 -- ----------------------------------------------------------------------------
770 -- These functions deal in terms of CgStmts, which is an abstract type
771 -- representing the code in the current proc.
774 -- emit CgStmts into the current instruction stream
775 emitCgStmts :: CgStmts -> Code
777 = do { state <- getState
778 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
780 -- emit CgStmts outside the current instruction stream, and return a label
781 forkCgStmts :: CgStmts -> FCode BlockId
783 = do { id <- newLabelC
784 ; emitCgStmt (CgFork id stmts)
788 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
789 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
790 cgStmtsToBlocks stmts
791 = do { id <- newLabelC
792 ; return (flattenCgStmts id stmts)
795 -- collect the code emitted by an FCode computation
796 getCgStmts' :: FCode a -> FCode (a, CgStmts)
798 = do { state1 <- getState
799 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
800 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
801 ; return (a, cgs_stmts state2) }
803 getCgStmts :: FCode a -> FCode CgStmts
804 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
806 -- Simple ways to construct CgStmts:
810 oneCgStmt :: CmmStmt -> CgStmts
811 oneCgStmt stmt = unitOL (CgStmt stmt)
813 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
814 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
816 -- ----------------------------------------------------------------------------
817 -- Get the current module name
819 getModuleName :: FCode Module
820 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
822 -- ----------------------------------------------------------------------------
823 -- Get/set the end-of-block info
825 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
826 setEndOfBlockInfo eob_info code = do
828 withInfoDown code (info {cgd_eob = eob_info})
830 getEndOfBlockInfo :: FCode EndOfBlockInfo
831 getEndOfBlockInfo = do
833 return (cgd_eob info)
835 -- ----------------------------------------------------------------------------
836 -- Get/set the current SRT label
838 -- There is just one SRT for each top level binding; all the nested
839 -- bindings use sub-sections of this SRT. The label is passed down to
840 -- the nested bindings via the monad.
842 getSRTLabel :: FCode CLabel -- Used only by cgPanic
843 getSRTLabel = do info <- getInfoDown
844 return (cgd_srt_lbl info)
846 setSRTLabel :: CLabel -> FCode a -> FCode a
847 setSRTLabel srt_lbl code
848 = do info <- getInfoDown
849 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
852 getSRT = do info <- getInfoDown
853 return (cgd_srt info)
855 setSRT :: SRT -> FCode a -> FCode a
857 = do info <- getInfoDown
858 withInfoDown code (info { cgd_srt = srt})
860 -- ----------------------------------------------------------------------------
861 -- Get/set the current ticky counter label
863 getTickyCtrLabel :: FCode CLabel
864 getTickyCtrLabel = do
866 return (cgd_ticky info)
868 setTickyCtrLabel :: CLabel -> Code -> Code
869 setTickyCtrLabel ticky code = do
871 withInfoDown code (info {cgd_ticky = ticky})