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, getHomeModules,
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 Packages ( HomeModules )
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_hmods :: HomeModules, -- Packages we depend on
101 cgd_mod :: Module, -- Module being compiled
102 cgd_statics :: CgBindings, -- [Id -> info] : static environment
103 cgd_srt :: CLabel, -- label of the current SRT
104 cgd_ticky :: CLabel, -- current destination for ticky counts
105 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
108 initCgInfoDown :: DynFlags -> HomeModules -> Module -> CgInfoDownwards
109 initCgInfoDown dflags hmods mod
110 = MkCgInfoDown { cgd_dflags = dflags,
113 cgd_statics = emptyVarEnv,
114 cgd_srt = error "initC: srt",
115 cgd_ticky = mkTopTickyCtrLabel,
116 cgd_eob = initEobInfo }
120 cgs_stmts :: OrdList CgStmt, -- Current proc
121 cgs_tops :: OrdList CmmTop,
122 -- Other procedures and data blocks in this compilation unit
123 -- Both the latter two are ordered only so that we can
124 -- reduce forward references, when it's easy to do so
126 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
127 -- Bindings for top-level things are given in
128 -- the info-down part
130 cgs_stk_usg :: StackUsage,
131 cgs_hp_usg :: HeapUsage,
133 cgs_uniqs :: UniqSupply }
135 initCgState :: UniqSupply -> CgState
137 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
138 cgs_binds = emptyVarEnv,
139 cgs_stk_usg = initStkUsage,
140 cgs_hp_usg = initHpUsage,
144 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
145 if the expression is a @case@, what to do at the end of each
151 VirtualSpOffset -- Args Sp: trim the stack to this point at a
152 -- return; push arguments starting just
153 -- above this point on a tail call.
155 -- This is therefore the stk ptr as seen
156 -- by a case alternative.
159 initEobInfo = EndOfBlockInfo 0 OnStack
162 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
163 that it must survive stack pointer adjustments at the end of the
168 = OnStack -- Continuation is on the stack
169 | UpdateCode -- Continuation is update
172 CLabel -- Jump to this; if the continuation is for a vectored
173 -- case this might be the label of a return vector
175 Id -- The case binder, only used to see if it's dead
176 Bool -- True <=> polymorphic, push a SEQ frame too
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 = ( [], [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
250 isOrdinaryStmt (CgStmt _) = True
251 isOrdinaryStmt _ = False
254 %************************************************************************
256 Stack and heap models
258 %************************************************************************
261 type VirtualHpOffset = WordOff -- Both are in
262 type VirtualSpOffset = WordOff -- units of words
266 virtSp :: VirtualSpOffset,
267 -- Virtual offset of topmost allocated slot
269 frameSp :: VirtualSpOffset,
270 -- Virtual offset of the return address of the enclosing frame.
271 -- This RA describes the liveness/pointedness of
272 -- all the stack from frameSp downwards
273 -- INVARIANT: less than or equal to virtSp
275 freeStk :: [VirtualSpOffset],
276 -- List of free slots, in *increasing* order
277 -- INVARIANT: all <= virtSp
278 -- All slots <= virtSp are taken except these ones
280 realSp :: VirtualSpOffset,
281 -- Virtual offset of real stack pointer register
283 hwSp :: VirtualSpOffset
284 } -- Highest value ever taken by virtSp
286 -- INVARIANT: The environment contains no Stable references to
287 -- stack slots below (lower offset) frameSp
288 -- It can contain volatile references to this area though.
292 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
293 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
297 The heap high water mark is the larger of virtHp and hwHp. The latter is
298 only records the high water marks of forked-off branches, so to find the
299 heap high water mark you have to take the max of virtHp and hwHp. Remember,
300 virtHp never retreats!
302 Note Jan 04: ok, so why do we only look at the virtual Hp??
305 heapHWM :: HeapUsage -> VirtualHpOffset
312 initStkUsage :: StackUsage
313 initStkUsage = StackUsage {
321 initHpUsage :: HeapUsage
322 initHpUsage = HeapUsage {
328 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
329 marks found in $e_2$.
332 stateIncUsage :: CgState -> CgState -> CgState
333 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
334 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
335 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
336 `addCodeBlocksFrom` s2
338 stateIncUsageEval :: CgState -> CgState -> CgState
339 stateIncUsageEval s1 s2
340 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
341 `addCodeBlocksFrom` s2
342 -- We don't max the heap high-watermark because stateIncUsageEval is
343 -- used only in forkEval, which in turn is only used for blocks of code
344 -- which do their own heap-check.
346 addCodeBlocksFrom :: CgState -> CgState -> CgState
347 -- Add code blocks from the latter to the former
348 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
349 s1 `addCodeBlocksFrom` s2
350 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
351 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
353 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
354 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
356 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
357 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
360 %************************************************************************
364 %************************************************************************
367 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
370 instance Monad FCode where
375 {-# INLINE thenFC #-}
376 {-# INLINE returnFC #-}
378 The Abstract~C is not in the environment so as to improve strictness.
381 initC :: DynFlags -> HomeModules -> Module -> FCode a -> IO a
383 initC dflags hmods mod (FCode code)
384 = do { uniqs <- mkSplitUniqSupply 'c'
385 ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of
386 (res, _) -> return res
389 returnFC :: a -> FCode a
390 returnFC val = FCode (\info_down state -> (val, state))
394 thenC :: Code -> FCode a -> FCode a
395 thenC (FCode m) (FCode k) =
396 FCode (\info_down state -> let (_,new_state) = m info_down state in
397 k info_down new_state)
399 listCs :: [Code] -> Code
400 listCs [] = return ()
405 mapCs :: (a -> Code) -> [a] -> Code
410 thenFC :: FCode a -> (a -> FCode c) -> FCode c
411 thenFC (FCode m) k = FCode (
414 (m_result, new_state) = m info_down state
415 (FCode kcode) = k m_result
417 kcode info_down new_state
420 listFCs :: [FCode a] -> FCode [a]
423 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
427 And the knot-tying combinator:
429 fixC :: (a -> FCode a) -> FCode a
434 result@(v,_) = fc info_down state
441 %************************************************************************
443 Operators for getting and setting the state and "info_down".
446 %************************************************************************
449 getState :: FCode CgState
450 getState = FCode $ \info_down state -> (state,state)
452 setState :: CgState -> FCode ()
453 setState state = FCode $ \info_down _ -> ((),state)
455 getStkUsage :: FCode StackUsage
458 return $ cgs_stk_usg state
460 setStkUsage :: StackUsage -> Code
461 setStkUsage new_stk_usg = do
463 setState $ state {cgs_stk_usg = new_stk_usg}
465 getHpUsage :: FCode HeapUsage
468 return $ cgs_hp_usg state
470 setHpUsage :: HeapUsage -> Code
471 setHpUsage new_hp_usg = do
473 setState $ state {cgs_hp_usg = new_hp_usg}
475 getBinds :: FCode CgBindings
478 return $ cgs_binds state
480 setBinds :: CgBindings -> FCode ()
481 setBinds new_binds = do
483 setState $ state {cgs_binds = new_binds}
485 getStaticBinds :: FCode CgBindings
488 return (cgd_statics info)
490 withState :: FCode a -> CgState -> FCode (a,CgState)
491 withState (FCode fcode) newstate = FCode $ \info_down state ->
492 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
494 newUniqSupply :: FCode UniqSupply
497 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
498 setState $ state { cgs_uniqs = us1 }
501 newUnique :: FCode Unique
504 return (uniqFromSupply us)
507 getInfoDown :: FCode CgInfoDownwards
508 getInfoDown = FCode $ \info_down state -> (info_down,state)
510 getDynFlags :: FCode DynFlags
511 getDynFlags = liftM cgd_dflags getInfoDown
513 getHomeModules :: FCode HomeModules
514 getHomeModules = liftM cgd_hmods getInfoDown
516 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
517 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
519 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
520 doFCode (FCode fcode) info_down state = fcode info_down state
524 %************************************************************************
528 %************************************************************************
530 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
531 fresh environment, except that:
532 - compilation info and statics are passed in unchanged.
533 The current environment is passed on completely unaltered, except that
534 abstract C from the fork is incorporated.
536 @forkProc@ takes a code and compiles it in the current environment,
537 returning the basic blocks thus constructed. The current environment
538 is passed on completely unchanged. It is pretty similar to
539 @getBlocks@, except that the latter does affect the environment.
541 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
542 from the current bindings, but which is otherwise freshly initialised.
543 The Abstract~C returned is attached to the current state, but the
544 bindings and usage information is otherwise unchanged.
547 forkClosureBody :: Code -> Code
548 forkClosureBody body_code
549 = do { info <- getInfoDown
550 ; us <- newUniqSupply
552 ; let body_info_down = info { cgd_eob = initEobInfo }
553 ((),fork_state) = doFCode body_code body_info_down
555 ; ASSERT( isNilOL (cgs_stmts fork_state) )
556 setState $ state `addCodeBlocksFrom` fork_state }
558 forkStatics :: FCode a -> FCode a
559 forkStatics body_code
560 = do { info <- getInfoDown
561 ; us <- newUniqSupply
563 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
564 cgd_eob = initEobInfo }
565 (result, fork_state_out) = doFCode body_code rhs_info_down
567 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
568 setState (state `addCodeBlocksFrom` fork_state_out)
571 forkProc :: Code -> FCode CgStmts
573 = do { info_down <- getInfoDown
574 ; us <- newUniqSupply
576 ; let fork_state_in = (initCgState us)
577 { cgs_binds = cgs_binds state,
578 cgs_stk_usg = cgs_stk_usg state,
579 cgs_hp_usg = cgs_hp_usg state }
580 -- ToDo: is the hp usage necesary?
581 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
582 info_down fork_state_in
583 ; setState $ state `stateIncUsageEval` fork_state_out
586 codeOnly :: Code -> Code
587 -- Emit any code from the inner thing into the outer thing
588 -- Do not affect anything else in the outer state
589 -- Used in almost-circular code to prevent false loop dependencies
591 = do { info_down <- getInfoDown
592 ; us <- newUniqSupply
594 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
595 cgs_stk_usg = cgs_stk_usg state,
596 cgs_hp_usg = cgs_hp_usg state }
597 ((), fork_state_out) = doFCode body_code info_down fork_state_in
598 ; setState $ state `addCodeBlocksFrom` fork_state_out }
601 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
602 an fcode for the default case $d$, and compiles each in the current
603 environment. The current environment is passed on unmodified, except
605 - the worst stack high-water mark is incorporated
606 - the virtual Hp is moved on to the worst virtual Hp for the branches
609 forkAlts :: [FCode a] -> FCode [a]
611 forkAlts branch_fcodes
612 = do { info_down <- getInfoDown
613 ; us <- newUniqSupply
615 ; let compile us branch
616 = (us2, doFCode branch info_down branch_state)
618 (us1,us2) = splitUniqSupply us
619 branch_state = (initCgState us1) {
620 cgs_binds = cgs_binds state,
621 cgs_stk_usg = cgs_stk_usg state,
622 cgs_hp_usg = cgs_hp_usg state }
624 (_us, results) = mapAccumL compile us branch_fcodes
625 (branch_results, branch_out_states) = unzip results
626 ; setState $ foldl stateIncUsage state branch_out_states
627 -- NB foldl. state is the *left* argument to stateIncUsage
628 ; return branch_results }
631 @forkEval@ takes two blocks of code.
633 - The first meddles with the environment to set it up as expected by
634 the alternatives of a @case@ which does an eval (or gc-possible primop).
635 - The second block is the code for the alternatives.
636 (plus info for semi-tagging purposes)
638 @forkEval@ picks up the virtual stack pointer and returns a suitable
639 @EndOfBlockInfo@ for the caller to use, together with whatever value
640 is returned by the second block.
642 It uses @initEnvForAlternatives@ to initialise the environment, and
643 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
647 forkEval :: EndOfBlockInfo -- For the body
648 -> Code -- Code to set environment
649 -> FCode Sequel -- Semi-tagging info to store
650 -> FCode EndOfBlockInfo -- The new end of block info
652 forkEval body_eob_info env_code body_code
653 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
654 ; returnFC (EndOfBlockInfo v sequel) }
656 forkEvalHelp :: EndOfBlockInfo -- For the body
657 -> Code -- Code to set environment
658 -> FCode a -- The code to do after the eval
659 -> FCode (VirtualSpOffset, -- Sp
660 a) -- Result of the FCode
661 -- A disturbingly complicated function
662 forkEvalHelp body_eob_info env_code body_code
663 = do { info_down <- getInfoDown
664 ; us <- newUniqSupply
666 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
667 ; (_, env_state) = doFCode env_code info_down_for_body
668 (state {cgs_uniqs = us})
669 ; state_for_body = (initCgState (cgs_uniqs env_state))
670 { cgs_binds = binds_for_body,
671 cgs_stk_usg = stk_usg_for_body }
672 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
673 ; stk_usg_from_env = cgs_stk_usg env_state
674 ; virtSp_from_env = virtSp stk_usg_from_env
675 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
676 hwSp = virtSp_from_env}
677 ; (value_returned, state_at_end_return)
678 = doFCode body_code info_down_for_body state_for_body
680 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
681 -- The code coming back should consist only of nested declarations,
682 -- notably of the return vector!
683 setState $ state `stateIncUsageEval` state_at_end_return
684 ; return (virtSp_from_env, value_returned) }
687 -- ----------------------------------------------------------------------------
688 -- Combinators for emitting code
693 whenC :: Bool -> Code -> Code
694 whenC True code = code
695 whenC False code = nopC
697 stmtC :: CmmStmt -> Code
698 stmtC stmt = emitCgStmt (CgStmt stmt)
700 labelC :: BlockId -> Code
701 labelC id = emitCgStmt (CgLabel id)
703 newLabelC :: FCode BlockId
704 newLabelC = do { id <- newUnique; return (BlockId id) }
706 checkedAbsC :: CmmStmt -> Code
707 -- Emit code, eliminating no-ops
708 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
711 stmtsC :: [CmmStmt] -> Code
712 stmtsC stmts = emitStmts (toOL stmts)
714 -- Emit code; no no-op checking
715 emitStmts :: CmmStmts -> Code
716 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
718 -- forkLabelledCode is for emitting a chunk of code with a label, outside
719 -- of the current instruction stream.
720 forkLabelledCode :: Code -> FCode BlockId
721 forkLabelledCode code = getCgStmts code >>= forkCgStmts
723 emitCgStmt :: CgStmt -> Code
725 = do { state <- getState
726 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
729 emitData :: Section -> [CmmStatic] -> Code
731 = do { state <- getState
732 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
734 data_block = CmmData sect lits
736 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
737 emitProc lits lbl args blocks
738 = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
740 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
742 emitSimpleProc :: CLabel -> Code -> Code
743 -- Emit a procedure whose body is the specified code; no info table
744 emitSimpleProc lbl code
745 = do { stmts <- getCgStmts code
746 ; blks <- cgStmtsToBlocks stmts
747 ; emitProc [] lbl [] blks }
749 getCmm :: Code -> FCode Cmm
750 -- Get all the CmmTops (there should be no stmts)
752 = do { state1 <- getState
753 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
754 ; setState $ state2 { cgs_tops = cgs_tops state1 }
755 ; return (Cmm (fromOL (cgs_tops state2))) }
757 -- ----------------------------------------------------------------------------
760 -- These functions deal in terms of CgStmts, which is an abstract type
761 -- representing the code in the current proc.
764 -- emit CgStmts into the current instruction stream
765 emitCgStmts :: CgStmts -> Code
767 = do { state <- getState
768 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
770 -- emit CgStmts outside the current instruction stream, and return a label
771 forkCgStmts :: CgStmts -> FCode BlockId
773 = do { id <- newLabelC
774 ; emitCgStmt (CgFork id stmts)
778 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
779 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
780 cgStmtsToBlocks stmts
781 = do { id <- newLabelC
782 ; return (flattenCgStmts id stmts)
785 -- collect the code emitted by an FCode computation
786 getCgStmts' :: FCode a -> FCode (a, CgStmts)
788 = do { state1 <- getState
789 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
790 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
791 ; return (a, cgs_stmts state2) }
793 getCgStmts :: FCode a -> FCode CgStmts
794 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
796 -- Simple ways to construct CgStmts:
800 oneCgStmt :: CmmStmt -> CgStmts
801 oneCgStmt stmt = unitOL (CgStmt stmt)
803 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
804 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
806 -- ----------------------------------------------------------------------------
807 -- Get the current module name
809 moduleName :: FCode Module
810 moduleName = do { info <- getInfoDown; return (cgd_mod info) }
812 -- ----------------------------------------------------------------------------
813 -- Get/set the end-of-block info
815 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
816 setEndOfBlockInfo eob_info code = do
818 withInfoDown code (info {cgd_eob = eob_info})
820 getEndOfBlockInfo :: FCode EndOfBlockInfo
821 getEndOfBlockInfo = do
823 return (cgd_eob info)
825 -- ----------------------------------------------------------------------------
826 -- Get/set the current SRT label
828 -- There is just one SRT for each top level binding; all the nested
829 -- bindings use sub-sections of this SRT. The label is passed down to
830 -- the nested bindings via the monad.
832 getSRTLabel :: FCode CLabel -- Used only by cgPanic
833 getSRTLabel = do info <- getInfoDown
834 return (cgd_srt info)
836 setSRTLabel :: CLabel -> FCode a -> FCode a
837 setSRTLabel srt_lbl code
838 = do info <- getInfoDown
839 withInfoDown code (info { cgd_srt = srt_lbl})
841 -- ----------------------------------------------------------------------------
842 -- Get/set the current ticky counter label
844 getTickyCtrLabel :: FCode CLabel
845 getTickyCtrLabel = do
847 return (cgd_ticky info)
849 setTickyCtrLabel :: CLabel -> Code -> Code
850 setTickyCtrLabel ticky code = do
852 withInfoDown code (info {cgd_ticky = ticky})