2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.43 2004/12/08 14:32:31 simonpj Exp $
6 \section[CgMonad]{The code generation monad}
8 See the beginning of the top-level @CodeGen@ module, to see how this
9 monadic stuff fits into the Big Picture.
16 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
17 returnFC, fixC, checkedAbsC,
18 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
19 newUnique, newUniqSupply,
21 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
22 getCgStmts', getCgStmts,
23 noCgStmts, oneCgStmt, consCgStmt,
26 emitData, emitProc, emitSimpleProc,
29 forkClosureBody, forkStatics, forkAlts, forkEval,
30 forkEvalHelp, forkProc, codeOnly,
31 SemiTaggingStuff, ConTagZ,
34 setEndOfBlockInfo, getEndOfBlockInfo,
36 setSRTLabel, getSRTLabel,
37 setTickyCtrLabel, getTickyCtrLabel,
39 StackUsage(..), HeapUsage(..),
40 VirtualSpOffset, VirtualHpOffset,
41 initStkUsage, initHpUsage,
42 getHpUsage, setHpUsage,
47 Sequel(..), -- ToDo: unabstract?
49 -- ideally we wouldn't export these, but some other modules access internal state
50 getState, setState, getInfoDown, getDynFlags,
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 )
64 import CmdLineOpts ( DynFlags )
66 import CmmUtils ( CmmStmts, isNopStmt )
68 import SMRep ( WordOff )
69 import Module ( Module )
73 import Unique ( Unique )
74 import Util ( mapAccumL )
75 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
79 import Control.Monad ( liftM )
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
173 Bool -- True <=> polymorphic, push a SEQ frame too
175 type SemiTaggingStuff
176 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
177 ([(ConTagZ, CmmLit)], -- Alternatives
178 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
180 type ConTagZ = Int -- A *zero-indexed* contructor tag
182 -- The case branch is executed only from a successful semitagging
183 -- venture, when a case has looked at a variable, found that it's
184 -- evaluated, and wants to load up the contents and go to the join
188 %************************************************************************
192 %************************************************************************
194 The CgStmts type is what the code generator outputs: it is a tree of
195 statements, including in-line labels. The job of flattenCgStmts is to
196 turn this into a list of basic blocks, each of which ends in a jump
197 statement (either a local branch or a non-local jump).
200 type CgStmts = OrdList CgStmt
205 | CgFork BlockId CgStmts
207 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
208 flattenCgStmts id stmts =
209 case flatten (fromOL stmts) of
210 ([],blocks) -> blocks
211 (block,blocks) -> BasicBlock id block : blocks
215 -- A label at the end of a function or fork: this label must not be reachable,
216 -- but it might be referred to from another BB that also isn't reachable.
217 -- Eliminating these has to be done with a dead-code analysis. For now,
218 -- we just make it into a well-formed block by adding a recursive jump.
220 = ( [], [BasicBlock id [CmmBranch id]] )
222 -- A jump/branch: throw away all the code up to the next label, because
223 -- it is unreachable. Be careful to keep forks that we find on the way.
224 flatten (CgStmt stmt : stmts)
226 = case dropWhile isOrdinaryStmt stmts of
228 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
229 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
230 where (block,blocks) = flatten stmts
231 (CgFork fork_id stmts : ss) ->
232 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
236 CgStmt stmt -> (stmt:block,blocks)
237 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
238 CgFork fork_id stmts ->
239 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
240 where (fork_block, fork_blocks) = flatten (fromOL stmts)
241 where (block,blocks) = flatten ss
243 isJump (CmmJump _ _) = True
244 isJump (CmmBranch _) = True
247 isOrdinaryStmt (CgStmt _) = True
248 isOrdinaryStmt _ = False
251 %************************************************************************
253 Stack and heap models
255 %************************************************************************
258 type VirtualHpOffset = WordOff -- Both are in
259 type VirtualSpOffset = WordOff -- units of words
263 virtSp :: VirtualSpOffset,
264 -- Virtual offset of topmost allocated slot
266 frameSp :: VirtualSpOffset,
267 -- Virtual offset of the return address of the enclosing frame.
268 -- This RA describes the liveness/pointedness of
269 -- all the stack from frameSp downwards
270 -- INVARIANT: less than or equal to virtSp
272 freeStk :: [VirtualSpOffset],
273 -- List of free slots, in *increasing* order
274 -- INVARIANT: all <= virtSp
275 -- All slots <= virtSp are taken except these ones
277 realSp :: VirtualSpOffset,
278 -- Virtual offset of real stack pointer register
280 hwSp :: VirtualSpOffset
281 } -- Highest value ever taken by virtSp
283 -- INVARIANT: The environment contains no Stable references to
284 -- stack slots below (lower offset) frameSp
285 -- It can contain volatile references to this area though.
289 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
290 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
294 The heap high water mark is the larger of virtHp and hwHp. The latter is
295 only records the high water marks of forked-off branches, so to find the
296 heap high water mark you have to take the max of virtHp and hwHp. Remember,
297 virtHp never retreats!
299 Note Jan 04: ok, so why do we only look at the virtual Hp??
302 heapHWM :: HeapUsage -> VirtualHpOffset
309 initStkUsage :: StackUsage
310 initStkUsage = StackUsage {
318 initHpUsage :: HeapUsage
319 initHpUsage = HeapUsage {
325 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
326 marks found in $e_2$.
329 stateIncUsage :: CgState -> CgState -> CgState
330 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
331 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
332 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
333 `addCodeBlocksFrom` s2
335 stateIncUsageEval :: CgState -> CgState -> CgState
336 stateIncUsageEval s1 s2
337 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
338 `addCodeBlocksFrom` s2
339 -- We don't max the heap high-watermark because stateIncUsageEval is
340 -- used only in forkEval, which in turn is only used for blocks of code
341 -- which do their own heap-check.
343 addCodeBlocksFrom :: CgState -> CgState -> CgState
344 -- Add code blocks from the latter to the former
345 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
346 s1 `addCodeBlocksFrom` s2
347 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
348 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
350 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
351 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
353 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
354 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
357 %************************************************************************
361 %************************************************************************
364 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
367 instance Monad FCode where
372 {-# INLINE thenFC #-}
373 {-# INLINE returnFC #-}
375 The Abstract~C is not in the environment so as to improve strictness.
378 initC :: DynFlags -> Module -> FCode a -> IO a
380 initC dflags mod (FCode code)
381 = do { uniqs <- mkSplitUniqSupply 'c'
382 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
383 (res, _) -> return res
386 returnFC :: a -> FCode a
387 returnFC val = FCode (\info_down state -> (val, state))
391 thenC :: Code -> FCode a -> FCode a
392 thenC (FCode m) (FCode k) =
393 FCode (\info_down state -> let (_,new_state) = m info_down state in
394 k info_down new_state)
396 listCs :: [Code] -> Code
397 listCs [] = return ()
402 mapCs :: (a -> Code) -> [a] -> Code
407 thenFC :: FCode a -> (a -> FCode c) -> FCode c
408 thenFC (FCode m) k = FCode (
411 (m_result, new_state) = m info_down state
412 (FCode kcode) = k m_result
414 kcode info_down new_state
417 listFCs :: [FCode a] -> FCode [a]
420 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
424 And the knot-tying combinator:
426 fixC :: (a -> FCode a) -> FCode a
431 result@(v,_) = fc info_down state
438 %************************************************************************
440 Operators for getting and setting the state and "info_down".
443 %************************************************************************
446 getState :: FCode CgState
447 getState = FCode $ \info_down state -> (state,state)
449 setState :: CgState -> FCode ()
450 setState state = FCode $ \info_down _ -> ((),state)
452 getStkUsage :: FCode StackUsage
455 return $ cgs_stk_usg state
457 setStkUsage :: StackUsage -> Code
458 setStkUsage new_stk_usg = do
460 setState $ state {cgs_stk_usg = new_stk_usg}
462 getHpUsage :: FCode HeapUsage
465 return $ cgs_hp_usg state
467 setHpUsage :: HeapUsage -> Code
468 setHpUsage new_hp_usg = do
470 setState $ state {cgs_hp_usg = new_hp_usg}
472 getBinds :: FCode CgBindings
475 return $ cgs_binds state
477 setBinds :: CgBindings -> FCode ()
478 setBinds new_binds = do
480 setState $ state {cgs_binds = new_binds}
482 getStaticBinds :: FCode CgBindings
485 return (cgd_statics info)
487 withState :: FCode a -> CgState -> FCode (a,CgState)
488 withState (FCode fcode) newstate = FCode $ \info_down state ->
489 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
491 newUniqSupply :: FCode UniqSupply
494 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
495 setState $ state { cgs_uniqs = us1 }
498 newUnique :: FCode Unique
501 return (uniqFromSupply us)
504 getInfoDown :: FCode CgInfoDownwards
505 getInfoDown = FCode $ \info_down state -> (info_down,state)
507 getDynFlags :: FCode DynFlags
508 getDynFlags = liftM cgd_dflags getInfoDown
510 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
511 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
513 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
514 doFCode (FCode fcode) info_down state = fcode info_down state
518 %************************************************************************
522 %************************************************************************
524 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
525 fresh environment, except that:
526 - compilation info and statics are passed in unchanged.
527 The current environment is passed on completely unaltered, except that
528 abstract C from the fork is incorporated.
530 @forkProc@ takes a code and compiles it in the current environment,
531 returning the basic blocks thus constructed. The current environment
532 is passed on completely unchanged. It is pretty similar to
533 @getBlocks@, except that the latter does affect the environment.
535 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
536 from the current bindings, but which is otherwise freshly initialised.
537 The Abstract~C returned is attached to the current state, but the
538 bindings and usage information is otherwise unchanged.
541 forkClosureBody :: Code -> Code
542 forkClosureBody body_code
543 = do { info <- getInfoDown
544 ; us <- newUniqSupply
546 ; let body_info_down = info { cgd_eob = initEobInfo }
547 ((),fork_state) = doFCode body_code body_info_down
549 ; ASSERT( isNilOL (cgs_stmts fork_state) )
550 setState $ state `addCodeBlocksFrom` fork_state }
552 forkStatics :: FCode a -> FCode a
553 forkStatics body_code
554 = do { info <- getInfoDown
555 ; us <- newUniqSupply
557 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
558 cgd_eob = initEobInfo }
559 (result, fork_state_out) = doFCode body_code rhs_info_down
561 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
562 setState (state `addCodeBlocksFrom` fork_state_out)
565 forkProc :: Code -> FCode CgStmts
567 = do { info_down <- getInfoDown
568 ; us <- newUniqSupply
570 ; let fork_state_in = (initCgState us)
571 { cgs_binds = cgs_binds state,
572 cgs_stk_usg = cgs_stk_usg state,
573 cgs_hp_usg = cgs_hp_usg state }
574 -- ToDo: is the hp usage necesary?
575 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
576 info_down fork_state_in
577 ; setState $ state `stateIncUsageEval` fork_state_out
580 codeOnly :: Code -> Code
581 -- Emit any code from the inner thing into the outer thing
582 -- Do not affect anything else in the outer state
583 -- Used in almost-circular code to prevent false loop dependencies
585 = do { info_down <- getInfoDown
586 ; us <- newUniqSupply
588 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
589 cgs_stk_usg = cgs_stk_usg state,
590 cgs_hp_usg = cgs_hp_usg state }
591 ((), fork_state_out) = doFCode body_code info_down fork_state_in
592 ; setState $ state `addCodeBlocksFrom` fork_state_out }
595 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
596 an fcode for the default case $d$, and compiles each in the current
597 environment. The current environment is passed on unmodified, except
599 - the worst stack high-water mark is incorporated
600 - the virtual Hp is moved on to the worst virtual Hp for the branches
603 forkAlts :: [FCode a] -> FCode [a]
605 forkAlts branch_fcodes
606 = do { info_down <- getInfoDown
607 ; us <- newUniqSupply
609 ; let compile us branch
610 = (us2, doFCode branch info_down branch_state)
612 (us1,us2) = splitUniqSupply us
613 branch_state = (initCgState us1) {
614 cgs_binds = cgs_binds state,
615 cgs_stk_usg = cgs_stk_usg state,
616 cgs_hp_usg = cgs_hp_usg state }
618 (_us, results) = mapAccumL compile us branch_fcodes
619 (branch_results, branch_out_states) = unzip results
620 ; setState $ foldl stateIncUsage state branch_out_states
621 -- NB foldl. state is the *left* argument to stateIncUsage
622 ; return branch_results }
625 @forkEval@ takes two blocks of code.
627 - The first meddles with the environment to set it up as expected by
628 the alternatives of a @case@ which does an eval (or gc-possible primop).
629 - The second block is the code for the alternatives.
630 (plus info for semi-tagging purposes)
632 @forkEval@ picks up the virtual stack pointer and returns a suitable
633 @EndOfBlockInfo@ for the caller to use, together with whatever value
634 is returned by the second block.
636 It uses @initEnvForAlternatives@ to initialise the environment, and
637 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
641 forkEval :: EndOfBlockInfo -- For the body
642 -> Code -- Code to set environment
643 -> FCode Sequel -- Semi-tagging info to store
644 -> FCode EndOfBlockInfo -- The new end of block info
646 forkEval body_eob_info env_code body_code
647 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
648 ; returnFC (EndOfBlockInfo v sequel) }
650 forkEvalHelp :: EndOfBlockInfo -- For the body
651 -> Code -- Code to set environment
652 -> FCode a -- The code to do after the eval
653 -> FCode (VirtualSpOffset, -- Sp
654 a) -- Result of the FCode
655 -- A disturbingly complicated function
656 forkEvalHelp body_eob_info env_code body_code
657 = do { info_down <- getInfoDown
658 ; us <- newUniqSupply
660 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
661 ; (_, env_state) = doFCode env_code info_down_for_body
662 (state {cgs_uniqs = us})
663 ; state_for_body = (initCgState (cgs_uniqs env_state))
664 { cgs_binds = binds_for_body,
665 cgs_stk_usg = stk_usg_for_body }
666 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
667 ; stk_usg_from_env = cgs_stk_usg env_state
668 ; virtSp_from_env = virtSp stk_usg_from_env
669 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
670 hwSp = virtSp_from_env}
671 ; (value_returned, state_at_end_return)
672 = doFCode body_code info_down_for_body state_for_body
674 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
675 -- The code coming back should consist only of nested declarations,
676 -- notably of the return vector!
677 setState $ state `stateIncUsageEval` state_at_end_return
678 ; return (virtSp_from_env, value_returned) }
681 -- ----------------------------------------------------------------------------
682 -- Combinators for emitting code
687 whenC :: Bool -> Code -> Code
688 whenC True code = code
689 whenC False code = nopC
691 stmtC :: CmmStmt -> Code
692 stmtC stmt = emitCgStmt (CgStmt stmt)
694 labelC :: BlockId -> Code
695 labelC id = emitCgStmt (CgLabel id)
697 newLabelC :: FCode BlockId
698 newLabelC = do { id <- newUnique; return (BlockId id) }
700 checkedAbsC :: CmmStmt -> Code
701 -- Emit code, eliminating no-ops
702 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
705 stmtsC :: [CmmStmt] -> Code
706 stmtsC stmts = emitStmts (toOL stmts)
708 -- Emit code; no no-op checking
709 emitStmts :: CmmStmts -> Code
710 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
712 -- forkLabelledCode is for emitting a chunk of code with a label, outside
713 -- of the current instruction stream.
714 forkLabelledCode :: Code -> FCode BlockId
715 forkLabelledCode code = getCgStmts code >>= forkCgStmts
717 emitCgStmt :: CgStmt -> Code
719 = do { state <- getState
720 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
723 emitData :: Section -> [CmmStatic] -> Code
725 = do { state <- getState
726 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
728 data_block = CmmData sect lits
730 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
731 emitProc lits lbl args blocks
732 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
734 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
736 emitSimpleProc :: CLabel -> Code -> Code
737 -- Emit a procedure whose body is the specified code; no info table
738 emitSimpleProc lbl code
739 = do { stmts <- getCgStmts code
740 ; blks <- cgStmtsToBlocks stmts
741 ; emitProc [] lbl [] blks }
743 getCmm :: Code -> FCode Cmm
744 -- Get all the CmmTops (there should be no stmts)
746 = do { state1 <- getState
747 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
748 ; setState $ state2 { cgs_tops = cgs_tops state1 }
749 ; return (Cmm (fromOL (cgs_tops state2))) }
751 -- ----------------------------------------------------------------------------
754 -- These functions deal in terms of CgStmts, which is an abstract type
755 -- representing the code in the current proc.
758 -- emit CgStmts into the current instruction stream
759 emitCgStmts :: CgStmts -> Code
761 = do { state <- getState
762 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
764 -- emit CgStmts outside the current instruction stream, and return a label
765 forkCgStmts :: CgStmts -> FCode BlockId
767 = do { id <- newLabelC
768 ; emitCgStmt (CgFork id stmts)
772 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
773 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
774 cgStmtsToBlocks stmts
775 = do { id <- newLabelC
776 ; return (flattenCgStmts id stmts)
779 -- collect the code emitted by an FCode computation
780 getCgStmts' :: FCode a -> FCode (a, CgStmts)
782 = do { state1 <- getState
783 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
784 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
785 ; return (a, cgs_stmts state2) }
787 getCgStmts :: FCode a -> FCode CgStmts
788 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
790 -- Simple ways to construct CgStmts:
794 oneCgStmt :: CmmStmt -> CgStmts
795 oneCgStmt stmt = unitOL (CgStmt stmt)
797 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
798 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
800 -- ----------------------------------------------------------------------------
801 -- Get the current module name
803 moduleName :: FCode Module
804 moduleName = do { info <- getInfoDown; return (cgd_mod info) }
806 -- ----------------------------------------------------------------------------
807 -- Get/set the end-of-block info
809 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
810 setEndOfBlockInfo eob_info code = do
812 withInfoDown code (info {cgd_eob = eob_info})
814 getEndOfBlockInfo :: FCode EndOfBlockInfo
815 getEndOfBlockInfo = do
817 return (cgd_eob info)
819 -- ----------------------------------------------------------------------------
820 -- Get/set the current SRT label
822 -- There is just one SRT for each top level binding; all the nested
823 -- bindings use sub-sections of this SRT. The label is passed down to
824 -- the nested bindings via the monad.
826 getSRTLabel :: FCode CLabel -- Used only by cgPanic
827 getSRTLabel = do info <- getInfoDown
828 return (cgd_srt info)
830 setSRTLabel :: CLabel -> FCode a -> FCode a
831 setSRTLabel srt_lbl code
832 = do info <- getInfoDown
833 withInfoDown code (info { cgd_srt = srt_lbl})
835 -- ----------------------------------------------------------------------------
836 -- Get/set the current ticky counter label
838 getTickyCtrLabel :: FCode CLabel
839 getTickyCtrLabel = do
841 return (cgd_ticky info)
843 setTickyCtrLabel :: CLabel -> Code -> Code
844 setTickyCtrLabel ticky code = do
846 withInfoDown code (info {cgd_ticky = ticky})