2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.45 2005/06/21 10:44:41 simonmar 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, 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 )
64 import DynFlags ( DynFlags(..) )
65 import PackageConfig ( PackageId )
67 import CmmUtils ( CmmStmts, isNopStmt )
69 import SMRep ( WordOff )
70 import Module ( Module )
74 import Unique ( Unique )
75 import Util ( mapAccumL )
76 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
80 import Control.Monad ( liftM )
82 infixr 9 `thenC` -- Right-associative!
86 %************************************************************************
88 \subsection[CgMonad-environment]{Stuff for manipulating environments}
90 %************************************************************************
92 This monadery has some information that it only passes {\em
93 downwards}, as well as some ``state'' which is modified as we go
97 data CgInfoDownwards -- information only passed *downwards* by the monad
99 cgd_dflags :: DynFlags,
100 cgd_mod :: Module, -- Module being compiled
101 cgd_statics :: CgBindings, -- [Id -> info] : static environment
102 cgd_srt :: CLabel, -- label of the current SRT
103 cgd_ticky :: CLabel, -- current destination for ticky counts
104 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
107 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
108 initCgInfoDown dflags mod
109 = MkCgInfoDown { cgd_dflags = dflags,
111 cgd_statics = emptyVarEnv,
112 cgd_srt = error "initC: srt",
113 cgd_ticky = mkTopTickyCtrLabel,
114 cgd_eob = initEobInfo }
118 cgs_stmts :: OrdList CgStmt, -- Current proc
119 cgs_tops :: OrdList CmmTop,
120 -- Other procedures and data blocks in this compilation unit
121 -- Both the latter two are ordered only so that we can
122 -- reduce forward references, when it's easy to do so
124 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
125 -- Bindings for top-level things are given in
126 -- the info-down part
128 cgs_stk_usg :: StackUsage,
129 cgs_hp_usg :: HeapUsage,
131 cgs_uniqs :: UniqSupply }
133 initCgState :: UniqSupply -> CgState
135 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
136 cgs_binds = emptyVarEnv,
137 cgs_stk_usg = initStkUsage,
138 cgs_hp_usg = initHpUsage,
142 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
143 if the expression is a @case@, what to do at the end of each
149 VirtualSpOffset -- Args Sp: trim the stack to this point at a
150 -- return; push arguments starting just
151 -- above this point on a tail call.
153 -- This is therefore the stk ptr as seen
154 -- by a case alternative.
157 initEobInfo = EndOfBlockInfo 0 OnStack
160 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
161 that it must survive stack pointer adjustments at the end of the
166 = OnStack -- Continuation is on the stack
167 | UpdateCode -- Continuation is update
170 CLabel -- Jump to this; if the continuation is for a vectored
171 -- case this might be the label of a return vector
173 Id -- The case binder, only used to see if it's dead
174 Bool -- True <=> polymorphic, push a SEQ frame too
176 type SemiTaggingStuff
177 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
178 ([(ConTagZ, CmmLit)], -- Alternatives
179 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
181 type ConTagZ = Int -- A *zero-indexed* contructor tag
183 -- The case branch is executed only from a successful semitagging
184 -- venture, when a case has looked at a variable, found that it's
185 -- evaluated, and wants to load up the contents and go to the join
189 %************************************************************************
193 %************************************************************************
195 The CgStmts type is what the code generator outputs: it is a tree of
196 statements, including in-line labels. The job of flattenCgStmts is to
197 turn this into a list of basic blocks, each of which ends in a jump
198 statement (either a local branch or a non-local jump).
201 type CgStmts = OrdList CgStmt
206 | CgFork BlockId CgStmts
208 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
209 flattenCgStmts id stmts =
210 case flatten (fromOL stmts) of
211 ([],blocks) -> blocks
212 (block,blocks) -> BasicBlock id block : blocks
216 -- A label at the end of a function or fork: this label must not be reachable,
217 -- but it might be referred to from another BB that also isn't reachable.
218 -- Eliminating these has to be done with a dead-code analysis. For now,
219 -- we just make it into a well-formed block by adding a recursive jump.
221 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
223 -- A jump/branch: throw away all the code up to the next label, because
224 -- it is unreachable. Be careful to keep forks that we find on the way.
225 flatten (CgStmt stmt : stmts)
227 = case dropWhile isOrdinaryStmt stmts of
229 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
230 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
231 where (block,blocks) = flatten stmts
232 (CgFork fork_id stmts : ss) ->
233 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
237 CgStmt stmt -> (stmt:block,blocks)
238 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
239 CgFork fork_id stmts ->
240 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
241 where (fork_block, fork_blocks) = flatten (fromOL stmts)
242 where (block,blocks) = flatten ss
244 isJump (CmmJump _ _) = True
245 isJump (CmmBranch _) = True
248 isOrdinaryStmt (CgStmt _) = True
249 isOrdinaryStmt _ = False
252 %************************************************************************
254 Stack and heap models
256 %************************************************************************
259 type VirtualHpOffset = WordOff -- Both are in
260 type VirtualSpOffset = WordOff -- units of words
264 virtSp :: VirtualSpOffset,
265 -- Virtual offset of topmost allocated slot
267 frameSp :: VirtualSpOffset,
268 -- Virtual offset of the return address of the enclosing frame.
269 -- This RA describes the liveness/pointedness of
270 -- all the stack from frameSp downwards
271 -- INVARIANT: less than or equal to virtSp
273 freeStk :: [VirtualSpOffset],
274 -- List of free slots, in *increasing* order
275 -- INVARIANT: all <= virtSp
276 -- All slots <= virtSp are taken except these ones
278 realSp :: VirtualSpOffset,
279 -- Virtual offset of real stack pointer register
281 hwSp :: VirtualSpOffset
282 } -- Highest value ever taken by virtSp
284 -- INVARIANT: The environment contains no Stable references to
285 -- stack slots below (lower offset) frameSp
286 -- It can contain volatile references to this area though.
290 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
291 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
295 The heap high water mark is the larger of virtHp and hwHp. The latter is
296 only records the high water marks of forked-off branches, so to find the
297 heap high water mark you have to take the max of virtHp and hwHp. Remember,
298 virtHp never retreats!
300 Note Jan 04: ok, so why do we only look at the virtual Hp??
303 heapHWM :: HeapUsage -> VirtualHpOffset
310 initStkUsage :: StackUsage
311 initStkUsage = StackUsage {
319 initHpUsage :: HeapUsage
320 initHpUsage = HeapUsage {
326 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
327 marks found in $e_2$.
330 stateIncUsage :: CgState -> CgState -> CgState
331 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
332 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
333 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
334 `addCodeBlocksFrom` s2
336 stateIncUsageEval :: CgState -> CgState -> CgState
337 stateIncUsageEval s1 s2
338 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
339 `addCodeBlocksFrom` s2
340 -- We don't max the heap high-watermark because stateIncUsageEval is
341 -- used only in forkEval, which in turn is only used for blocks of code
342 -- which do their own heap-check.
344 addCodeBlocksFrom :: CgState -> CgState -> CgState
345 -- Add code blocks from the latter to the former
346 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
347 s1 `addCodeBlocksFrom` s2
348 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
349 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
351 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
352 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
354 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
355 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
358 %************************************************************************
362 %************************************************************************
365 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
368 instance Monad FCode where
373 {-# INLINE thenFC #-}
374 {-# INLINE returnFC #-}
376 The Abstract~C is not in the environment so as to improve strictness.
379 initC :: DynFlags -> Module -> FCode a -> IO a
381 initC dflags mod (FCode code)
382 = do { uniqs <- mkSplitUniqSupply 'c'
383 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
384 (res, _) -> return res
387 returnFC :: a -> FCode a
388 returnFC val = FCode (\info_down state -> (val, state))
392 thenC :: Code -> FCode a -> FCode a
393 thenC (FCode m) (FCode k) =
394 FCode (\info_down state -> let (_,new_state) = m info_down state in
395 k info_down new_state)
397 listCs :: [Code] -> Code
398 listCs [] = return ()
403 mapCs :: (a -> Code) -> [a] -> Code
408 thenFC :: FCode a -> (a -> FCode c) -> FCode c
409 thenFC (FCode m) k = FCode (
412 (m_result, new_state) = m info_down state
413 (FCode kcode) = k m_result
415 kcode info_down new_state
418 listFCs :: [FCode a] -> FCode [a]
421 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
425 And the knot-tying combinator:
427 fixC :: (a -> FCode a) -> FCode a
432 result@(v,_) = fc info_down state
439 %************************************************************************
441 Operators for getting and setting the state and "info_down".
444 %************************************************************************
447 getState :: FCode CgState
448 getState = FCode $ \info_down state -> (state,state)
450 setState :: CgState -> FCode ()
451 setState state = FCode $ \info_down _ -> ((),state)
453 getStkUsage :: FCode StackUsage
456 return $ cgs_stk_usg state
458 setStkUsage :: StackUsage -> Code
459 setStkUsage new_stk_usg = do
461 setState $ state {cgs_stk_usg = new_stk_usg}
463 getHpUsage :: FCode HeapUsage
466 return $ cgs_hp_usg state
468 setHpUsage :: HeapUsage -> Code
469 setHpUsage new_hp_usg = do
471 setState $ state {cgs_hp_usg = new_hp_usg}
473 getBinds :: FCode CgBindings
476 return $ cgs_binds state
478 setBinds :: CgBindings -> FCode ()
479 setBinds new_binds = do
481 setState $ state {cgs_binds = new_binds}
483 getStaticBinds :: FCode CgBindings
486 return (cgd_statics info)
488 withState :: FCode a -> CgState -> FCode (a,CgState)
489 withState (FCode fcode) newstate = FCode $ \info_down state ->
490 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
492 newUniqSupply :: FCode UniqSupply
495 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
496 setState $ state { cgs_uniqs = us1 }
499 newUnique :: FCode Unique
502 return (uniqFromSupply us)
505 getInfoDown :: FCode CgInfoDownwards
506 getInfoDown = FCode $ \info_down state -> (info_down,state)
508 getDynFlags :: FCode DynFlags
509 getDynFlags = liftM cgd_dflags getInfoDown
511 getThisPackage :: FCode PackageId
512 getThisPackage = liftM thisPackage getDynFlags
514 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
515 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
517 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
518 doFCode (FCode fcode) info_down state = fcode info_down state
522 %************************************************************************
526 %************************************************************************
528 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
529 fresh environment, except that:
530 - compilation info and statics are passed in unchanged.
531 The current environment is passed on completely unaltered, except that
532 abstract C from the fork is incorporated.
534 @forkProc@ takes a code and compiles it in the current environment,
535 returning the basic blocks thus constructed. The current environment
536 is passed on completely unchanged. It is pretty similar to
537 @getBlocks@, except that the latter does affect the environment.
539 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
540 from the current bindings, but which is otherwise freshly initialised.
541 The Abstract~C returned is attached to the current state, but the
542 bindings and usage information is otherwise unchanged.
545 forkClosureBody :: Code -> Code
546 forkClosureBody body_code
547 = do { info <- getInfoDown
548 ; us <- newUniqSupply
550 ; let body_info_down = info { cgd_eob = initEobInfo }
551 ((),fork_state) = doFCode body_code body_info_down
553 ; ASSERT( isNilOL (cgs_stmts fork_state) )
554 setState $ state `addCodeBlocksFrom` fork_state }
556 forkStatics :: FCode a -> FCode a
557 forkStatics body_code
558 = do { info <- getInfoDown
559 ; us <- newUniqSupply
561 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
562 cgd_eob = initEobInfo }
563 (result, fork_state_out) = doFCode body_code rhs_info_down
565 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
566 setState (state `addCodeBlocksFrom` fork_state_out)
569 forkProc :: Code -> FCode CgStmts
571 = do { info_down <- getInfoDown
572 ; us <- newUniqSupply
574 ; let fork_state_in = (initCgState us)
575 { cgs_binds = cgs_binds state,
576 cgs_stk_usg = cgs_stk_usg state,
577 cgs_hp_usg = cgs_hp_usg state }
578 -- ToDo: is the hp usage necesary?
579 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
580 info_down fork_state_in
581 ; setState $ state `stateIncUsageEval` fork_state_out
584 codeOnly :: Code -> Code
585 -- Emit any code from the inner thing into the outer thing
586 -- Do not affect anything else in the outer state
587 -- Used in almost-circular code to prevent false loop dependencies
589 = do { info_down <- getInfoDown
590 ; us <- newUniqSupply
592 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
593 cgs_stk_usg = cgs_stk_usg state,
594 cgs_hp_usg = cgs_hp_usg state }
595 ((), fork_state_out) = doFCode body_code info_down fork_state_in
596 ; setState $ state `addCodeBlocksFrom` fork_state_out }
599 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
600 an fcode for the default case $d$, and compiles each in the current
601 environment. The current environment is passed on unmodified, except
603 - the worst stack high-water mark is incorporated
604 - the virtual Hp is moved on to the worst virtual Hp for the branches
607 forkAlts :: [FCode a] -> FCode [a]
609 forkAlts branch_fcodes
610 = do { info_down <- getInfoDown
611 ; us <- newUniqSupply
613 ; let compile us branch
614 = (us2, doFCode branch info_down branch_state)
616 (us1,us2) = splitUniqSupply us
617 branch_state = (initCgState us1) {
618 cgs_binds = cgs_binds state,
619 cgs_stk_usg = cgs_stk_usg state,
620 cgs_hp_usg = cgs_hp_usg state }
622 (_us, results) = mapAccumL compile us branch_fcodes
623 (branch_results, branch_out_states) = unzip results
624 ; setState $ foldl stateIncUsage state branch_out_states
625 -- NB foldl. state is the *left* argument to stateIncUsage
626 ; return branch_results }
629 @forkEval@ takes two blocks of code.
631 - The first meddles with the environment to set it up as expected by
632 the alternatives of a @case@ which does an eval (or gc-possible primop).
633 - The second block is the code for the alternatives.
634 (plus info for semi-tagging purposes)
636 @forkEval@ picks up the virtual stack pointer and returns a suitable
637 @EndOfBlockInfo@ for the caller to use, together with whatever value
638 is returned by the second block.
640 It uses @initEnvForAlternatives@ to initialise the environment, and
641 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
645 forkEval :: EndOfBlockInfo -- For the body
646 -> Code -- Code to set environment
647 -> FCode Sequel -- Semi-tagging info to store
648 -> FCode EndOfBlockInfo -- The new end of block info
650 forkEval body_eob_info env_code body_code
651 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
652 ; returnFC (EndOfBlockInfo v sequel) }
654 forkEvalHelp :: EndOfBlockInfo -- For the body
655 -> Code -- Code to set environment
656 -> FCode a -- The code to do after the eval
657 -> FCode (VirtualSpOffset, -- Sp
658 a) -- Result of the FCode
659 -- A disturbingly complicated function
660 forkEvalHelp body_eob_info env_code body_code
661 = do { info_down <- getInfoDown
662 ; us <- newUniqSupply
664 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
665 ; (_, env_state) = doFCode env_code info_down_for_body
666 (state {cgs_uniqs = us})
667 ; state_for_body = (initCgState (cgs_uniqs env_state))
668 { cgs_binds = binds_for_body,
669 cgs_stk_usg = stk_usg_for_body }
670 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
671 ; stk_usg_from_env = cgs_stk_usg env_state
672 ; virtSp_from_env = virtSp stk_usg_from_env
673 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
674 hwSp = virtSp_from_env}
675 ; (value_returned, state_at_end_return)
676 = doFCode body_code info_down_for_body state_for_body
678 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
679 -- The code coming back should consist only of nested declarations,
680 -- notably of the return vector!
681 setState $ state `stateIncUsageEval` state_at_end_return
682 ; return (virtSp_from_env, value_returned) }
685 -- ----------------------------------------------------------------------------
686 -- Combinators for emitting code
691 whenC :: Bool -> Code -> Code
692 whenC True code = code
693 whenC False code = nopC
695 stmtC :: CmmStmt -> Code
696 stmtC stmt = emitCgStmt (CgStmt stmt)
698 labelC :: BlockId -> Code
699 labelC id = emitCgStmt (CgLabel id)
701 newLabelC :: FCode BlockId
702 newLabelC = do { id <- newUnique; return (BlockId id) }
704 checkedAbsC :: CmmStmt -> Code
705 -- Emit code, eliminating no-ops
706 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
709 stmtsC :: [CmmStmt] -> Code
710 stmtsC stmts = emitStmts (toOL stmts)
712 -- Emit code; no no-op checking
713 emitStmts :: CmmStmts -> Code
714 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
716 -- forkLabelledCode is for emitting a chunk of code with a label, outside
717 -- of the current instruction stream.
718 forkLabelledCode :: Code -> FCode BlockId
719 forkLabelledCode code = getCgStmts code >>= forkCgStmts
721 emitCgStmt :: CgStmt -> Code
723 = do { state <- getState
724 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
727 emitData :: Section -> [CmmStatic] -> Code
729 = do { state <- getState
730 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
732 data_block = CmmData sect lits
734 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
735 emitProc lits lbl args blocks
736 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
738 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
740 emitSimpleProc :: CLabel -> Code -> Code
741 -- Emit a procedure whose body is the specified code; no info table
742 emitSimpleProc lbl code
743 = do { stmts <- getCgStmts code
744 ; blks <- cgStmtsToBlocks stmts
745 ; emitProc [] lbl [] blks }
747 getCmm :: Code -> FCode Cmm
748 -- Get all the CmmTops (there should be no stmts)
750 = do { state1 <- getState
751 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
752 ; setState $ state2 { cgs_tops = cgs_tops state1 }
753 ; return (Cmm (fromOL (cgs_tops state2))) }
755 -- ----------------------------------------------------------------------------
758 -- These functions deal in terms of CgStmts, which is an abstract type
759 -- representing the code in the current proc.
762 -- emit CgStmts into the current instruction stream
763 emitCgStmts :: CgStmts -> Code
765 = do { state <- getState
766 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
768 -- emit CgStmts outside the current instruction stream, and return a label
769 forkCgStmts :: CgStmts -> FCode BlockId
771 = do { id <- newLabelC
772 ; emitCgStmt (CgFork id stmts)
776 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
777 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
778 cgStmtsToBlocks stmts
779 = do { id <- newLabelC
780 ; return (flattenCgStmts id stmts)
783 -- collect the code emitted by an FCode computation
784 getCgStmts' :: FCode a -> FCode (a, CgStmts)
786 = do { state1 <- getState
787 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
788 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
789 ; return (a, cgs_stmts state2) }
791 getCgStmts :: FCode a -> FCode CgStmts
792 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
794 -- Simple ways to construct CgStmts:
798 oneCgStmt :: CmmStmt -> CgStmts
799 oneCgStmt stmt = unitOL (CgStmt stmt)
801 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
802 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
804 -- ----------------------------------------------------------------------------
805 -- Get the current module name
807 moduleName :: FCode Module
808 moduleName = do { info <- getInfoDown; return (cgd_mod info) }
810 -- ----------------------------------------------------------------------------
811 -- Get/set the end-of-block info
813 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
814 setEndOfBlockInfo eob_info code = do
816 withInfoDown code (info {cgd_eob = eob_info})
818 getEndOfBlockInfo :: FCode EndOfBlockInfo
819 getEndOfBlockInfo = do
821 return (cgd_eob info)
823 -- ----------------------------------------------------------------------------
824 -- Get/set the current SRT label
826 -- There is just one SRT for each top level binding; all the nested
827 -- bindings use sub-sections of this SRT. The label is passed down to
828 -- the nested bindings via the monad.
830 getSRTLabel :: FCode CLabel -- Used only by cgPanic
831 getSRTLabel = do info <- getInfoDown
832 return (cgd_srt info)
834 setSRTLabel :: CLabel -> FCode a -> FCode a
835 setSRTLabel srt_lbl code
836 = do info <- getInfoDown
837 withInfoDown code (info { cgd_srt = srt_lbl})
839 -- ----------------------------------------------------------------------------
840 -- Get/set the current ticky counter label
842 getTickyCtrLabel :: FCode CLabel
843 getTickyCtrLabel = do
845 return (cgd_ticky info)
847 setTickyCtrLabel :: CLabel -> Code -> Code
848 setTickyCtrLabel ticky code = do
850 withInfoDown code (info {cgd_ticky = ticky})