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
174 type SemiTaggingStuff
175 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
176 ([(ConTagZ, CmmLit)], -- Alternatives
177 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
179 type ConTagZ = Int -- A *zero-indexed* contructor tag
181 -- The case branch is executed only from a successful semitagging
182 -- venture, when a case has looked at a variable, found that it's
183 -- evaluated, and wants to load up the contents and go to the join
187 %************************************************************************
191 %************************************************************************
193 The CgStmts type is what the code generator outputs: it is a tree of
194 statements, including in-line labels. The job of flattenCgStmts is to
195 turn this into a list of basic blocks, each of which ends in a jump
196 statement (either a local branch or a non-local jump).
199 type CgStmts = OrdList CgStmt
204 | CgFork BlockId CgStmts
206 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
207 flattenCgStmts id stmts =
208 case flatten (fromOL stmts) of
209 ([],blocks) -> blocks
210 (block,blocks) -> BasicBlock id block : blocks
214 -- A label at the end of a function or fork: this label must not be reachable,
215 -- but it might be referred to from another BB that also isn't reachable.
216 -- Eliminating these has to be done with a dead-code analysis. For now,
217 -- we just make it into a well-formed block by adding a recursive jump.
219 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
221 -- A jump/branch: throw away all the code up to the next label, because
222 -- it is unreachable. Be careful to keep forks that we find on the way.
223 flatten (CgStmt stmt : stmts)
225 = case dropWhile isOrdinaryStmt stmts of
227 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
228 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
229 where (block,blocks) = flatten stmts
230 (CgFork fork_id stmts : ss) ->
231 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
235 CgStmt stmt -> (stmt:block,blocks)
236 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
237 CgFork fork_id stmts ->
238 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
239 where (fork_block, fork_blocks) = flatten (fromOL stmts)
240 where (block,blocks) = flatten ss
242 isJump (CmmJump _ _) = True
243 isJump (CmmBranch _) = True
246 isOrdinaryStmt (CgStmt _) = True
247 isOrdinaryStmt _ = False
250 %************************************************************************
252 Stack and heap models
254 %************************************************************************
257 type VirtualHpOffset = WordOff -- Both are in
258 type VirtualSpOffset = WordOff -- units of words
262 virtSp :: VirtualSpOffset,
263 -- Virtual offset of topmost allocated slot
265 frameSp :: VirtualSpOffset,
266 -- Virtual offset of the return address of the enclosing frame.
267 -- This RA describes the liveness/pointedness of
268 -- all the stack from frameSp downwards
269 -- INVARIANT: less than or equal to virtSp
271 freeStk :: [VirtualSpOffset],
272 -- List of free slots, in *increasing* order
273 -- INVARIANT: all <= virtSp
274 -- All slots <= virtSp are taken except these ones
276 realSp :: VirtualSpOffset,
277 -- Virtual offset of real stack pointer register
279 hwSp :: VirtualSpOffset
280 } -- Highest value ever taken by virtSp
282 -- INVARIANT: The environment contains no Stable references to
283 -- stack slots below (lower offset) frameSp
284 -- It can contain volatile references to this area though.
288 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
289 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
293 The heap high water mark is the larger of virtHp and hwHp. The latter is
294 only records the high water marks of forked-off branches, so to find the
295 heap high water mark you have to take the max of virtHp and hwHp. Remember,
296 virtHp never retreats!
298 Note Jan 04: ok, so why do we only look at the virtual Hp??
301 heapHWM :: HeapUsage -> VirtualHpOffset
308 initStkUsage :: StackUsage
309 initStkUsage = StackUsage {
317 initHpUsage :: HeapUsage
318 initHpUsage = HeapUsage {
324 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
325 marks found in $e_2$.
328 stateIncUsage :: CgState -> CgState -> CgState
329 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
330 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
331 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
332 `addCodeBlocksFrom` s2
334 stateIncUsageEval :: CgState -> CgState -> CgState
335 stateIncUsageEval s1 s2
336 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
337 `addCodeBlocksFrom` s2
338 -- We don't max the heap high-watermark because stateIncUsageEval is
339 -- used only in forkEval, which in turn is only used for blocks of code
340 -- which do their own heap-check.
342 addCodeBlocksFrom :: CgState -> CgState -> CgState
343 -- Add code blocks from the latter to the former
344 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
345 s1 `addCodeBlocksFrom` s2
346 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
347 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
349 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
350 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
352 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
353 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
356 %************************************************************************
360 %************************************************************************
363 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
366 instance Monad FCode where
371 {-# INLINE thenFC #-}
372 {-# INLINE returnFC #-}
374 The Abstract~C is not in the environment so as to improve strictness.
377 initC :: DynFlags -> Module -> FCode a -> IO a
379 initC dflags mod (FCode code)
380 = do { uniqs <- mkSplitUniqSupply 'c'
381 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
382 (res, _) -> return res
385 returnFC :: a -> FCode a
386 returnFC val = FCode (\info_down state -> (val, state))
390 thenC :: Code -> FCode a -> FCode a
391 thenC (FCode m) (FCode k) =
392 FCode (\info_down state -> let (_,new_state) = m info_down state in
393 k info_down new_state)
395 listCs :: [Code] -> Code
396 listCs [] = return ()
401 mapCs :: (a -> Code) -> [a] -> Code
406 thenFC :: FCode a -> (a -> FCode c) -> FCode c
407 thenFC (FCode m) k = FCode (
410 (m_result, new_state) = m info_down state
411 (FCode kcode) = k m_result
413 kcode info_down new_state
416 listFCs :: [FCode a] -> FCode [a]
419 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
423 And the knot-tying combinator:
425 fixC :: (a -> FCode a) -> FCode a
430 result@(v,_) = fc info_down state
437 %************************************************************************
439 Operators for getting and setting the state and "info_down".
442 %************************************************************************
445 getState :: FCode CgState
446 getState = FCode $ \info_down state -> (state,state)
448 setState :: CgState -> FCode ()
449 setState state = FCode $ \info_down _ -> ((),state)
451 getStkUsage :: FCode StackUsage
454 return $ cgs_stk_usg state
456 setStkUsage :: StackUsage -> Code
457 setStkUsage new_stk_usg = do
459 setState $ state {cgs_stk_usg = new_stk_usg}
461 getHpUsage :: FCode HeapUsage
464 return $ cgs_hp_usg state
466 setHpUsage :: HeapUsage -> Code
467 setHpUsage new_hp_usg = do
469 setState $ state {cgs_hp_usg = new_hp_usg}
471 getBinds :: FCode CgBindings
474 return $ cgs_binds state
476 setBinds :: CgBindings -> FCode ()
477 setBinds new_binds = do
479 setState $ state {cgs_binds = new_binds}
481 getStaticBinds :: FCode CgBindings
484 return (cgd_statics info)
486 withState :: FCode a -> CgState -> FCode (a,CgState)
487 withState (FCode fcode) newstate = FCode $ \info_down state ->
488 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
490 newUniqSupply :: FCode UniqSupply
493 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
494 setState $ state { cgs_uniqs = us1 }
497 newUnique :: FCode Unique
500 return (uniqFromSupply us)
503 getInfoDown :: FCode CgInfoDownwards
504 getInfoDown = FCode $ \info_down state -> (info_down,state)
506 getDynFlags :: FCode DynFlags
507 getDynFlags = liftM cgd_dflags getInfoDown
509 getThisPackage :: FCode PackageId
510 getThisPackage = liftM thisPackage getDynFlags
512 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
513 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
515 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
516 doFCode (FCode fcode) info_down state = fcode info_down state
520 %************************************************************************
524 %************************************************************************
526 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
527 fresh environment, except that:
528 - compilation info and statics are passed in unchanged.
529 The current environment is passed on completely unaltered, except that
530 abstract C from the fork is incorporated.
532 @forkProc@ takes a code and compiles it in the current environment,
533 returning the basic blocks thus constructed. The current environment
534 is passed on completely unchanged. It is pretty similar to
535 @getBlocks@, except that the latter does affect the environment.
537 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
538 from the current bindings, but which is otherwise freshly initialised.
539 The Abstract~C returned is attached to the current state, but the
540 bindings and usage information is otherwise unchanged.
543 forkClosureBody :: Code -> Code
544 forkClosureBody body_code
545 = do { info <- getInfoDown
546 ; us <- newUniqSupply
548 ; let body_info_down = info { cgd_eob = initEobInfo }
549 ((),fork_state) = doFCode body_code body_info_down
551 ; ASSERT( isNilOL (cgs_stmts fork_state) )
552 setState $ state `addCodeBlocksFrom` fork_state }
554 forkStatics :: FCode a -> FCode a
555 forkStatics body_code
556 = do { info <- getInfoDown
557 ; us <- newUniqSupply
559 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
560 cgd_eob = initEobInfo }
561 (result, fork_state_out) = doFCode body_code rhs_info_down
563 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
564 setState (state `addCodeBlocksFrom` fork_state_out)
567 forkProc :: Code -> FCode CgStmts
569 = do { info_down <- getInfoDown
570 ; us <- newUniqSupply
572 ; let fork_state_in = (initCgState us)
573 { cgs_binds = cgs_binds state,
574 cgs_stk_usg = cgs_stk_usg state,
575 cgs_hp_usg = cgs_hp_usg state }
576 -- ToDo: is the hp usage necesary?
577 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
578 info_down fork_state_in
579 ; setState $ state `stateIncUsageEval` fork_state_out
582 codeOnly :: Code -> Code
583 -- Emit any code from the inner thing into the outer thing
584 -- Do not affect anything else in the outer state
585 -- Used in almost-circular code to prevent false loop dependencies
587 = do { info_down <- getInfoDown
588 ; us <- newUniqSupply
590 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
591 cgs_stk_usg = cgs_stk_usg state,
592 cgs_hp_usg = cgs_hp_usg state }
593 ((), fork_state_out) = doFCode body_code info_down fork_state_in
594 ; setState $ state `addCodeBlocksFrom` fork_state_out }
597 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
598 an fcode for the default case $d$, and compiles each in the current
599 environment. The current environment is passed on unmodified, except
601 - the worst stack high-water mark is incorporated
602 - the virtual Hp is moved on to the worst virtual Hp for the branches
605 forkAlts :: [FCode a] -> FCode [a]
607 forkAlts branch_fcodes
608 = do { info_down <- getInfoDown
609 ; us <- newUniqSupply
611 ; let compile us branch
612 = (us2, doFCode branch info_down branch_state)
614 (us1,us2) = splitUniqSupply us
615 branch_state = (initCgState us1) {
616 cgs_binds = cgs_binds state,
617 cgs_stk_usg = cgs_stk_usg state,
618 cgs_hp_usg = cgs_hp_usg state }
620 (_us, results) = mapAccumL compile us branch_fcodes
621 (branch_results, branch_out_states) = unzip results
622 ; setState $ foldl stateIncUsage state branch_out_states
623 -- NB foldl. state is the *left* argument to stateIncUsage
624 ; return branch_results }
627 @forkEval@ takes two blocks of code.
629 - The first meddles with the environment to set it up as expected by
630 the alternatives of a @case@ which does an eval (or gc-possible primop).
631 - The second block is the code for the alternatives.
632 (plus info for semi-tagging purposes)
634 @forkEval@ picks up the virtual stack pointer and returns a suitable
635 @EndOfBlockInfo@ for the caller to use, together with whatever value
636 is returned by the second block.
638 It uses @initEnvForAlternatives@ to initialise the environment, and
639 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
643 forkEval :: EndOfBlockInfo -- For the body
644 -> Code -- Code to set environment
645 -> FCode Sequel -- Semi-tagging info to store
646 -> FCode EndOfBlockInfo -- The new end of block info
648 forkEval body_eob_info env_code body_code
649 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
650 ; returnFC (EndOfBlockInfo v sequel) }
652 forkEvalHelp :: EndOfBlockInfo -- For the body
653 -> Code -- Code to set environment
654 -> FCode a -- The code to do after the eval
655 -> FCode (VirtualSpOffset, -- Sp
656 a) -- Result of the FCode
657 -- A disturbingly complicated function
658 forkEvalHelp body_eob_info env_code body_code
659 = do { info_down <- getInfoDown
660 ; us <- newUniqSupply
662 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
663 ; (_, env_state) = doFCode env_code info_down_for_body
664 (state {cgs_uniqs = us})
665 ; state_for_body = (initCgState (cgs_uniqs env_state))
666 { cgs_binds = binds_for_body,
667 cgs_stk_usg = stk_usg_for_body }
668 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
669 ; stk_usg_from_env = cgs_stk_usg env_state
670 ; virtSp_from_env = virtSp stk_usg_from_env
671 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
672 hwSp = virtSp_from_env}
673 ; (value_returned, state_at_end_return)
674 = doFCode body_code info_down_for_body state_for_body
676 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
677 -- The code coming back should consist only of nested declarations,
678 -- notably of the return vector!
679 setState $ state `stateIncUsageEval` state_at_end_return
680 ; return (virtSp_from_env, value_returned) }
683 -- ----------------------------------------------------------------------------
684 -- Combinators for emitting code
689 whenC :: Bool -> Code -> Code
690 whenC True code = code
691 whenC False code = nopC
693 stmtC :: CmmStmt -> Code
694 stmtC stmt = emitCgStmt (CgStmt stmt)
696 labelC :: BlockId -> Code
697 labelC id = emitCgStmt (CgLabel id)
699 newLabelC :: FCode BlockId
700 newLabelC = do { id <- newUnique; return (BlockId id) }
702 checkedAbsC :: CmmStmt -> Code
703 -- Emit code, eliminating no-ops
704 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
707 stmtsC :: [CmmStmt] -> Code
708 stmtsC stmts = emitStmts (toOL stmts)
710 -- Emit code; no no-op checking
711 emitStmts :: CmmStmts -> Code
712 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
714 -- forkLabelledCode is for emitting a chunk of code with a label, outside
715 -- of the current instruction stream.
716 forkLabelledCode :: Code -> FCode BlockId
717 forkLabelledCode code = getCgStmts code >>= forkCgStmts
719 emitCgStmt :: CgStmt -> Code
721 = do { state <- getState
722 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
725 emitData :: Section -> [CmmStatic] -> Code
727 = do { state <- getState
728 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
730 data_block = CmmData sect lits
732 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
733 emitProc lits lbl args blocks
734 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
736 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
738 emitSimpleProc :: CLabel -> Code -> Code
739 -- Emit a procedure whose body is the specified code; no info table
740 emitSimpleProc lbl code
741 = do { stmts <- getCgStmts code
742 ; blks <- cgStmtsToBlocks stmts
743 ; emitProc [] lbl [] blks }
745 getCmm :: Code -> FCode Cmm
746 -- Get all the CmmTops (there should be no stmts)
748 = do { state1 <- getState
749 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
750 ; setState $ state2 { cgs_tops = cgs_tops state1 }
751 ; return (Cmm (fromOL (cgs_tops state2))) }
753 -- ----------------------------------------------------------------------------
756 -- These functions deal in terms of CgStmts, which is an abstract type
757 -- representing the code in the current proc.
760 -- emit CgStmts into the current instruction stream
761 emitCgStmts :: CgStmts -> Code
763 = do { state <- getState
764 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
766 -- emit CgStmts outside the current instruction stream, and return a label
767 forkCgStmts :: CgStmts -> FCode BlockId
769 = do { id <- newLabelC
770 ; emitCgStmt (CgFork id stmts)
774 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
775 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
776 cgStmtsToBlocks stmts
777 = do { id <- newLabelC
778 ; return (flattenCgStmts id stmts)
781 -- collect the code emitted by an FCode computation
782 getCgStmts' :: FCode a -> FCode (a, CgStmts)
784 = do { state1 <- getState
785 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
786 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
787 ; return (a, cgs_stmts state2) }
789 getCgStmts :: FCode a -> FCode CgStmts
790 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
792 -- Simple ways to construct CgStmts:
796 oneCgStmt :: CmmStmt -> CgStmts
797 oneCgStmt stmt = unitOL (CgStmt stmt)
799 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
800 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
802 -- ----------------------------------------------------------------------------
803 -- Get the current module name
805 getModuleName :: FCode Module
806 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
808 -- ----------------------------------------------------------------------------
809 -- Get/set the end-of-block info
811 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
812 setEndOfBlockInfo eob_info code = do
814 withInfoDown code (info {cgd_eob = eob_info})
816 getEndOfBlockInfo :: FCode EndOfBlockInfo
817 getEndOfBlockInfo = do
819 return (cgd_eob info)
821 -- ----------------------------------------------------------------------------
822 -- Get/set the current SRT label
824 -- There is just one SRT for each top level binding; all the nested
825 -- bindings use sub-sections of this SRT. The label is passed down to
826 -- the nested bindings via the monad.
828 getSRTLabel :: FCode CLabel -- Used only by cgPanic
829 getSRTLabel = do info <- getInfoDown
830 return (cgd_srt info)
832 setSRTLabel :: CLabel -> FCode a -> FCode a
833 setSRTLabel srt_lbl code
834 = do info <- getInfoDown
835 withInfoDown code (info { cgd_srt = srt_lbl})
837 -- ----------------------------------------------------------------------------
838 -- Get/set the current ticky counter label
840 getTickyCtrLabel :: FCode CLabel
841 getTickyCtrLabel = do
843 return (cgd_ticky info)
845 setTickyCtrLabel :: CLabel -> Code -> Code
846 setTickyCtrLabel ticky code = do
848 withInfoDown code (info {cgd_ticky = ticky})