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 )
83 infixr 9 `thenC` -- Right-associative!
87 %************************************************************************
89 \subsection[CgMonad-environment]{Stuff for manipulating environments}
91 %************************************************************************
93 This monadery has some information that it only passes {\em
94 downwards}, as well as some ``state'' which is modified as we go
98 data CgInfoDownwards -- information only passed *downwards* by the monad
100 cgd_dflags :: DynFlags,
101 cgd_mod :: Module, -- Module being compiled
102 cgd_statics :: CgBindings, -- [Id -> info] : static environment
103 cgd_srt_lbl :: CLabel, -- label of the current SRT
104 cgd_srt :: SRT, -- the current SRT
105 cgd_ticky :: CLabel, -- current destination for ticky counts
106 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
109 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
110 initCgInfoDown dflags mod
111 = MkCgInfoDown { cgd_dflags = dflags,
113 cgd_statics = emptyVarEnv,
114 cgd_srt_lbl = error "initC: srt_lbl",
115 cgd_srt = error "initC: srt",
116 cgd_ticky = mkTopTickyCtrLabel,
117 cgd_eob = initEobInfo }
121 cgs_stmts :: OrdList CgStmt, -- Current proc
122 cgs_tops :: OrdList CmmTop,
123 -- Other procedures and data blocks in this compilation unit
124 -- Both the latter two are ordered only so that we can
125 -- reduce forward references, when it's easy to do so
127 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
128 -- Bindings for top-level things are given in
129 -- the info-down part
131 cgs_stk_usg :: StackUsage,
132 cgs_hp_usg :: HeapUsage,
134 cgs_uniqs :: UniqSupply }
136 initCgState :: UniqSupply -> CgState
138 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
139 cgs_binds = emptyVarEnv,
140 cgs_stk_usg = initStkUsage,
141 cgs_hp_usg = initHpUsage,
145 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
146 if the expression is a @case@, what to do at the end of each
152 VirtualSpOffset -- Args Sp: trim the stack to this point at a
153 -- return; push arguments starting just
154 -- above this point on a tail call.
156 -- This is therefore the stk ptr as seen
157 -- by a case alternative.
160 initEobInfo = EndOfBlockInfo 0 OnStack
163 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
164 that it must survive stack pointer adjustments at the end of the
169 = OnStack -- Continuation is on the stack
170 | UpdateCode -- Continuation is update
173 CLabel -- Jump to this; if the continuation is for a vectored
174 -- case this might be the label of a return vector
176 Id -- The case binder, only used to see if it's dead
178 type SemiTaggingStuff
179 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
180 ([(ConTagZ, CmmLit)], -- Alternatives
181 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
183 type ConTagZ = Int -- A *zero-indexed* contructor tag
185 -- The case branch is executed only from a successful semitagging
186 -- venture, when a case has looked at a variable, found that it's
187 -- evaluated, and wants to load up the contents and go to the join
191 %************************************************************************
195 %************************************************************************
197 The CgStmts type is what the code generator outputs: it is a tree of
198 statements, including in-line labels. The job of flattenCgStmts is to
199 turn this into a list of basic blocks, each of which ends in a jump
200 statement (either a local branch or a non-local jump).
203 type CgStmts = OrdList CgStmt
208 | CgFork BlockId CgStmts
210 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
211 flattenCgStmts id stmts =
212 case flatten (fromOL stmts) of
213 ([],blocks) -> blocks
214 (block,blocks) -> BasicBlock id block : blocks
218 -- A label at the end of a function or fork: this label must not be reachable,
219 -- but it might be referred to from another BB that also isn't reachable.
220 -- Eliminating these has to be done with a dead-code analysis. For now,
221 -- we just make it into a well-formed block by adding a recursive jump.
223 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
225 -- A jump/branch: throw away all the code up to the next label, because
226 -- it is unreachable. Be careful to keep forks that we find on the way.
227 flatten (CgStmt stmt : stmts)
229 = case dropWhile isOrdinaryStmt stmts of
231 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
232 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
233 where (block,blocks) = flatten stmts
234 (CgFork fork_id stmts : ss) ->
235 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
239 CgStmt stmt -> (stmt:block,blocks)
240 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
241 CgFork fork_id stmts ->
242 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
243 where (fork_block, fork_blocks) = flatten (fromOL stmts)
244 where (block,blocks) = flatten ss
246 isJump (CmmJump _ _) = True
247 isJump (CmmBranch _) = True
248 isJump (CmmSwitch _ _) = True
251 isOrdinaryStmt (CgStmt _) = True
252 isOrdinaryStmt _ = False
255 %************************************************************************
257 Stack and heap models
259 %************************************************************************
262 type VirtualHpOffset = WordOff -- Both are in
263 type VirtualSpOffset = WordOff -- units of words
267 virtSp :: VirtualSpOffset,
268 -- Virtual offset of topmost allocated slot
270 frameSp :: VirtualSpOffset,
271 -- Virtual offset of the return address of the enclosing frame.
272 -- This RA describes the liveness/pointedness of
273 -- all the stack from frameSp downwards
274 -- INVARIANT: less than or equal to virtSp
276 freeStk :: [VirtualSpOffset],
277 -- List of free slots, in *increasing* order
278 -- INVARIANT: all <= virtSp
279 -- All slots <= virtSp are taken except these ones
281 realSp :: VirtualSpOffset,
282 -- Virtual offset of real stack pointer register
284 hwSp :: VirtualSpOffset
285 } -- Highest value ever taken by virtSp
287 -- INVARIANT: The environment contains no Stable references to
288 -- stack slots below (lower offset) frameSp
289 -- It can contain volatile references to this area though.
293 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
294 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
298 The heap high water mark is the larger of virtHp and hwHp. The latter is
299 only records the high water marks of forked-off branches, so to find the
300 heap high water mark you have to take the max of virtHp and hwHp. Remember,
301 virtHp never retreats!
303 Note Jan 04: ok, so why do we only look at the virtual Hp??
306 heapHWM :: HeapUsage -> VirtualHpOffset
313 initStkUsage :: StackUsage
314 initStkUsage = StackUsage {
322 initHpUsage :: HeapUsage
323 initHpUsage = HeapUsage {
329 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
330 marks found in $e_2$.
333 stateIncUsage :: CgState -> CgState -> CgState
334 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
335 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
336 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
337 `addCodeBlocksFrom` s2
339 stateIncUsageEval :: CgState -> CgState -> CgState
340 stateIncUsageEval s1 s2
341 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
342 `addCodeBlocksFrom` s2
343 -- We don't max the heap high-watermark because stateIncUsageEval is
344 -- used only in forkEval, which in turn is only used for blocks of code
345 -- which do their own heap-check.
347 addCodeBlocksFrom :: CgState -> CgState -> CgState
348 -- Add code blocks from the latter to the former
349 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
350 s1 `addCodeBlocksFrom` s2
351 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
352 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
354 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
355 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
357 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
358 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
361 %************************************************************************
365 %************************************************************************
368 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
371 instance Monad FCode where
376 {-# INLINE thenFC #-}
377 {-# INLINE returnFC #-}
379 The Abstract~C is not in the environment so as to improve strictness.
382 initC :: DynFlags -> Module -> FCode a -> IO a
384 initC dflags mod (FCode code)
385 = do { uniqs <- mkSplitUniqSupply 'c'
386 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
387 (res, _) -> return res
390 returnFC :: a -> FCode a
391 returnFC val = FCode (\info_down state -> (val, state))
395 thenC :: Code -> FCode a -> FCode a
396 thenC (FCode m) (FCode k) =
397 FCode (\info_down state -> let (_,new_state) = m info_down state in
398 k info_down new_state)
400 listCs :: [Code] -> Code
401 listCs [] = return ()
406 mapCs :: (a -> Code) -> [a] -> Code
411 thenFC :: FCode a -> (a -> FCode c) -> FCode c
412 thenFC (FCode m) k = FCode (
415 (m_result, new_state) = m info_down state
416 (FCode kcode) = k m_result
418 kcode info_down new_state
421 listFCs :: [FCode a] -> FCode [a]
424 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
428 And the knot-tying combinator:
430 fixC :: (a -> FCode a) -> FCode a
435 result@(v,_) = fc info_down state
442 %************************************************************************
444 Operators for getting and setting the state and "info_down".
447 %************************************************************************
450 getState :: FCode CgState
451 getState = FCode $ \info_down state -> (state,state)
453 setState :: CgState -> FCode ()
454 setState state = FCode $ \info_down _ -> ((),state)
456 getStkUsage :: FCode StackUsage
459 return $ cgs_stk_usg state
461 setStkUsage :: StackUsage -> Code
462 setStkUsage new_stk_usg = do
464 setState $ state {cgs_stk_usg = new_stk_usg}
466 getHpUsage :: FCode HeapUsage
469 return $ cgs_hp_usg state
471 setHpUsage :: HeapUsage -> Code
472 setHpUsage new_hp_usg = do
474 setState $ state {cgs_hp_usg = new_hp_usg}
476 getBinds :: FCode CgBindings
479 return $ cgs_binds state
481 setBinds :: CgBindings -> FCode ()
482 setBinds new_binds = do
484 setState $ state {cgs_binds = new_binds}
486 getStaticBinds :: FCode CgBindings
489 return (cgd_statics info)
491 withState :: FCode a -> CgState -> FCode (a,CgState)
492 withState (FCode fcode) newstate = FCode $ \info_down state ->
493 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
495 newUniqSupply :: FCode UniqSupply
498 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
499 setState $ state { cgs_uniqs = us1 }
502 newUnique :: FCode Unique
505 return (uniqFromSupply us)
508 getInfoDown :: FCode CgInfoDownwards
509 getInfoDown = FCode $ \info_down state -> (info_down,state)
511 getDynFlags :: FCode DynFlags
512 getDynFlags = liftM cgd_dflags getInfoDown
514 getThisPackage :: FCode PackageId
515 getThisPackage = liftM thisPackage getDynFlags
517 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
518 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
520 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
521 doFCode (FCode fcode) info_down state = fcode info_down state
525 %************************************************************************
529 %************************************************************************
531 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
532 fresh environment, except that:
533 - compilation info and statics are passed in unchanged.
534 The current environment is passed on completely unaltered, except that
535 abstract C from the fork is incorporated.
537 @forkProc@ takes a code and compiles it in the current environment,
538 returning the basic blocks thus constructed. The current environment
539 is passed on completely unchanged. It is pretty similar to
540 @getBlocks@, except that the latter does affect the environment.
542 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
543 from the current bindings, but which is otherwise freshly initialised.
544 The Abstract~C returned is attached to the current state, but the
545 bindings and usage information is otherwise unchanged.
548 forkClosureBody :: Code -> Code
549 forkClosureBody body_code
550 = do { info <- getInfoDown
551 ; us <- newUniqSupply
553 ; let body_info_down = info { cgd_eob = initEobInfo }
554 ((),fork_state) = doFCode body_code body_info_down
556 ; ASSERT( isNilOL (cgs_stmts fork_state) )
557 setState $ state `addCodeBlocksFrom` fork_state }
559 forkStatics :: FCode a -> FCode a
560 forkStatics body_code
561 = do { info <- getInfoDown
562 ; us <- newUniqSupply
564 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
565 cgd_eob = initEobInfo }
566 (result, fork_state_out) = doFCode body_code rhs_info_down
568 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
569 setState (state `addCodeBlocksFrom` fork_state_out)
572 forkProc :: Code -> FCode CgStmts
574 = do { info_down <- getInfoDown
575 ; us <- newUniqSupply
577 ; let fork_state_in = (initCgState us)
578 { cgs_binds = cgs_binds state,
579 cgs_stk_usg = cgs_stk_usg state,
580 cgs_hp_usg = cgs_hp_usg state }
581 -- ToDo: is the hp usage necesary?
582 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
583 info_down fork_state_in
584 ; setState $ state `stateIncUsageEval` fork_state_out
587 codeOnly :: Code -> Code
588 -- Emit any code from the inner thing into the outer thing
589 -- Do not affect anything else in the outer state
590 -- Used in almost-circular code to prevent false loop dependencies
592 = do { info_down <- getInfoDown
593 ; us <- newUniqSupply
595 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
596 cgs_stk_usg = cgs_stk_usg state,
597 cgs_hp_usg = cgs_hp_usg state }
598 ((), fork_state_out) = doFCode body_code info_down fork_state_in
599 ; setState $ state `addCodeBlocksFrom` fork_state_out }
602 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
603 an fcode for the default case $d$, and compiles each in the current
604 environment. The current environment is passed on unmodified, except
606 - the worst stack high-water mark is incorporated
607 - the virtual Hp is moved on to the worst virtual Hp for the branches
610 forkAlts :: [FCode a] -> FCode [a]
612 forkAlts branch_fcodes
613 = do { info_down <- getInfoDown
614 ; us <- newUniqSupply
616 ; let compile us branch
617 = (us2, doFCode branch info_down branch_state)
619 (us1,us2) = splitUniqSupply us
620 branch_state = (initCgState us1) {
621 cgs_binds = cgs_binds state,
622 cgs_stk_usg = cgs_stk_usg state,
623 cgs_hp_usg = cgs_hp_usg state }
625 (_us, results) = mapAccumL compile us branch_fcodes
626 (branch_results, branch_out_states) = unzip results
627 ; setState $ foldl stateIncUsage state branch_out_states
628 -- NB foldl. state is the *left* argument to stateIncUsage
629 ; return branch_results }
632 @forkEval@ takes two blocks of code.
634 - The first meddles with the environment to set it up as expected by
635 the alternatives of a @case@ which does an eval (or gc-possible primop).
636 - The second block is the code for the alternatives.
637 (plus info for semi-tagging purposes)
639 @forkEval@ picks up the virtual stack pointer and returns a suitable
640 @EndOfBlockInfo@ for the caller to use, together with whatever value
641 is returned by the second block.
643 It uses @initEnvForAlternatives@ to initialise the environment, and
644 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
648 forkEval :: EndOfBlockInfo -- For the body
649 -> Code -- Code to set environment
650 -> FCode Sequel -- Semi-tagging info to store
651 -> FCode EndOfBlockInfo -- The new end of block info
653 forkEval body_eob_info env_code body_code
654 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
655 ; returnFC (EndOfBlockInfo v sequel) }
657 forkEvalHelp :: EndOfBlockInfo -- For the body
658 -> Code -- Code to set environment
659 -> FCode a -- The code to do after the eval
660 -> FCode (VirtualSpOffset, -- Sp
661 a) -- Result of the FCode
662 -- A disturbingly complicated function
663 forkEvalHelp body_eob_info env_code body_code
664 = do { info_down <- getInfoDown
665 ; us <- newUniqSupply
667 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
668 ; (_, env_state) = doFCode env_code info_down_for_body
669 (state {cgs_uniqs = us})
670 ; state_for_body = (initCgState (cgs_uniqs env_state))
671 { cgs_binds = binds_for_body,
672 cgs_stk_usg = stk_usg_for_body }
673 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
674 ; stk_usg_from_env = cgs_stk_usg env_state
675 ; virtSp_from_env = virtSp stk_usg_from_env
676 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
677 hwSp = virtSp_from_env}
678 ; (value_returned, state_at_end_return)
679 = doFCode body_code info_down_for_body state_for_body
681 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
682 -- The code coming back should consist only of nested declarations,
683 -- notably of the return vector!
684 setState $ state `stateIncUsageEval` state_at_end_return
685 ; return (virtSp_from_env, value_returned) }
688 -- ----------------------------------------------------------------------------
689 -- Combinators for emitting code
694 whenC :: Bool -> Code -> Code
695 whenC True code = code
696 whenC False code = nopC
698 stmtC :: CmmStmt -> Code
699 stmtC stmt = emitCgStmt (CgStmt stmt)
701 labelC :: BlockId -> Code
702 labelC id = emitCgStmt (CgLabel id)
704 newLabelC :: FCode BlockId
705 newLabelC = do { id <- newUnique; return (BlockId id) }
707 checkedAbsC :: CmmStmt -> Code
708 -- Emit code, eliminating no-ops
709 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
712 stmtsC :: [CmmStmt] -> Code
713 stmtsC stmts = emitStmts (toOL stmts)
715 -- Emit code; no no-op checking
716 emitStmts :: CmmStmts -> Code
717 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
719 -- forkLabelledCode is for emitting a chunk of code with a label, outside
720 -- of the current instruction stream.
721 forkLabelledCode :: Code -> FCode BlockId
722 forkLabelledCode code = getCgStmts code >>= forkCgStmts
724 emitCgStmt :: CgStmt -> Code
726 = do { state <- getState
727 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
730 emitData :: Section -> [CmmStatic] -> Code
732 = do { state <- getState
733 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
735 data_block = CmmData sect lits
737 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
738 emitProc info lbl args blocks
739 = do { let proc_block = CmmProc info lbl args blocks
741 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
743 emitSimpleProc :: CLabel -> Code -> Code
744 -- Emit a procedure whose body is the specified code; no info table
745 emitSimpleProc lbl code
746 = do { stmts <- getCgStmts code
747 ; blks <- cgStmtsToBlocks stmts
748 ; emitProc (CmmNonInfo Nothing) lbl [] blks }
750 getCmm :: Code -> FCode Cmm
751 -- Get all the CmmTops (there should be no stmts)
753 = do { state1 <- getState
754 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
755 ; setState $ state2 { cgs_tops = cgs_tops state1 }
756 ; return (Cmm (fromOL (cgs_tops state2))) }
758 -- ----------------------------------------------------------------------------
761 -- These functions deal in terms of CgStmts, which is an abstract type
762 -- representing the code in the current proc.
765 -- emit CgStmts into the current instruction stream
766 emitCgStmts :: CgStmts -> Code
768 = do { state <- getState
769 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
771 -- emit CgStmts outside the current instruction stream, and return a label
772 forkCgStmts :: CgStmts -> FCode BlockId
774 = do { id <- newLabelC
775 ; emitCgStmt (CgFork id stmts)
779 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
780 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
781 cgStmtsToBlocks stmts
782 = do { id <- newLabelC
783 ; return (flattenCgStmts id stmts)
786 -- collect the code emitted by an FCode computation
787 getCgStmts' :: FCode a -> FCode (a, CgStmts)
789 = do { state1 <- getState
790 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
791 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
792 ; return (a, cgs_stmts state2) }
794 getCgStmts :: FCode a -> FCode CgStmts
795 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
797 -- Simple ways to construct CgStmts:
801 oneCgStmt :: CmmStmt -> CgStmts
802 oneCgStmt stmt = unitOL (CgStmt stmt)
804 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
805 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
807 -- ----------------------------------------------------------------------------
808 -- Get the current module name
810 getModuleName :: FCode Module
811 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
813 -- ----------------------------------------------------------------------------
814 -- Get/set the end-of-block info
816 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
817 setEndOfBlockInfo eob_info code = do
819 withInfoDown code (info {cgd_eob = eob_info})
821 getEndOfBlockInfo :: FCode EndOfBlockInfo
822 getEndOfBlockInfo = do
824 return (cgd_eob info)
826 -- ----------------------------------------------------------------------------
827 -- Get/set the current SRT label
829 -- There is just one SRT for each top level binding; all the nested
830 -- bindings use sub-sections of this SRT. The label is passed down to
831 -- the nested bindings via the monad.
833 getSRTLabel :: FCode CLabel -- Used only by cgPanic
834 getSRTLabel = do info <- getInfoDown
835 return (cgd_srt_lbl info)
837 setSRTLabel :: CLabel -> FCode a -> FCode a
838 setSRTLabel srt_lbl code
839 = do info <- getInfoDown
840 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
843 getSRT = do info <- getInfoDown
844 return (cgd_srt info)
846 setSRT :: SRT -> FCode a -> FCode a
848 = do info <- getInfoDown
849 withInfoDown code (info { cgd_srt = srt})
851 -- ----------------------------------------------------------------------------
852 -- Get/set the current ticky counter label
854 getTickyCtrLabel :: FCode CLabel
855 getTickyCtrLabel = do
857 return (cgd_ticky info)
859 setTickyCtrLabel :: CLabel -> Code -> Code
860 setTickyCtrLabel ticky code = do
862 withInfoDown code (info {cgd_ticky = ticky})