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.
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and fix
14 -- any warnings in the module. See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
23 returnFC, fixC, checkedAbsC,
24 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
25 newUnique, newUniqSupply,
27 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
28 getCgStmts', getCgStmts,
29 noCgStmts, oneCgStmt, consCgStmt,
32 emitData, emitProc, emitSimpleProc,
35 forkClosureBody, forkStatics, forkAlts, forkEval,
36 forkEvalHelp, forkProc, codeOnly,
37 SemiTaggingStuff, ConTagZ,
40 setEndOfBlockInfo, getEndOfBlockInfo,
43 setSRTLabel, getSRTLabel,
44 setTickyCtrLabel, getTickyCtrLabel,
46 StackUsage(..), HeapUsage(..),
47 VirtualSpOffset, VirtualHpOffset,
48 initStkUsage, initHpUsage,
49 getHpUsage, setHpUsage,
54 Sequel(..), -- ToDo: unabstract?
56 -- ideally we wouldn't export these, but some other modules access internal state
57 getState, setState, getInfoDown, getDynFlags, getThisPackage,
59 -- more localised access to monad state
60 getStkUsage, setStkUsage,
61 getBinds, setBinds, getStaticBinds,
63 -- out of general friendliness, we also export ...
64 CgInfoDownwards(..), CgState(..) -- non-abstract
67 #include "HsVersions.h"
69 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
93 infixr 9 `thenC` -- Right-associative!
97 %************************************************************************
99 \subsection[CgMonad-environment]{Stuff for manipulating environments}
101 %************************************************************************
103 This monadery has some information that it only passes {\em
104 downwards}, as well as some ``state'' which is modified as we go
108 data CgInfoDownwards -- information only passed *downwards* by the monad
110 cgd_dflags :: DynFlags,
111 cgd_mod :: Module, -- Module being compiled
112 cgd_statics :: CgBindings, -- [Id -> info] : static environment
113 cgd_srt_lbl :: CLabel, -- label of the current SRT
114 cgd_srt :: SRT, -- the current SRT
115 cgd_ticky :: CLabel, -- current destination for ticky counts
116 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
119 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
120 initCgInfoDown dflags mod
121 = MkCgInfoDown { cgd_dflags = dflags,
123 cgd_statics = emptyVarEnv,
124 cgd_srt_lbl = error "initC: srt_lbl",
125 cgd_srt = error "initC: srt",
126 cgd_ticky = mkTopTickyCtrLabel,
127 cgd_eob = initEobInfo }
131 cgs_stmts :: OrdList CgStmt, -- Current proc
132 cgs_tops :: OrdList CmmTop,
133 -- Other procedures and data blocks in this compilation unit
134 -- Both the latter two are ordered only so that we can
135 -- reduce forward references, when it's easy to do so
137 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
138 -- Bindings for top-level things are given in
139 -- the info-down part
141 cgs_stk_usg :: StackUsage,
142 cgs_hp_usg :: HeapUsage,
144 cgs_uniqs :: UniqSupply }
146 initCgState :: UniqSupply -> CgState
148 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
149 cgs_binds = emptyVarEnv,
150 cgs_stk_usg = initStkUsage,
151 cgs_hp_usg = initHpUsage,
155 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
156 if the expression is a @case@, what to do at the end of each
162 VirtualSpOffset -- Args Sp: trim the stack to this point at a
163 -- return; push arguments starting just
164 -- above this point on a tail call.
166 -- This is therefore the stk ptr as seen
167 -- by a case alternative.
170 initEobInfo = EndOfBlockInfo 0 OnStack
173 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
174 that it must survive stack pointer adjustments at the end of the
179 = OnStack -- Continuation is on the stack
180 | UpdateCode -- Continuation is update
183 CLabel -- Jump to this; if the continuation is for a vectored
184 -- case this might be the label of a return vector
186 Id -- The case binder, only used to see if it's dead
188 type SemiTaggingStuff
189 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
190 ([(ConTagZ, CmmLit)], -- Alternatives
191 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
193 type ConTagZ = Int -- A *zero-indexed* contructor tag
195 -- The case branch is executed only from a successful semitagging
196 -- venture, when a case has looked at a variable, found that it's
197 -- evaluated, and wants to load up the contents and go to the join
201 %************************************************************************
205 %************************************************************************
207 The CgStmts type is what the code generator outputs: it is a tree of
208 statements, including in-line labels. The job of flattenCgStmts is to
209 turn this into a list of basic blocks, each of which ends in a jump
210 statement (either a local branch or a non-local jump).
213 type CgStmts = OrdList CgStmt
218 | CgFork BlockId CgStmts
220 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
221 flattenCgStmts id stmts =
222 case flatten (fromOL stmts) of
223 ([],blocks) -> blocks
224 (block,blocks) -> BasicBlock id block : blocks
228 -- A label at the end of a function or fork: this label must not be reachable,
229 -- but it might be referred to from another BB that also isn't reachable.
230 -- Eliminating these has to be done with a dead-code analysis. For now,
231 -- we just make it into a well-formed block by adding a recursive jump.
233 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
235 -- A jump/branch: throw away all the code up to the next label, because
236 -- it is unreachable. Be careful to keep forks that we find on the way.
237 flatten (CgStmt stmt : stmts)
239 = case dropWhile isOrdinaryStmt stmts of
241 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
242 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
243 where (block,blocks) = flatten stmts
244 (CgFork fork_id stmts : ss) ->
245 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
246 (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
250 CgStmt stmt -> (stmt:block,blocks)
251 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
252 CgFork fork_id stmts ->
253 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
254 where (fork_block, fork_blocks) = flatten (fromOL stmts)
255 where (block,blocks) = flatten ss
257 isJump (CmmJump _ _) = True
258 isJump (CmmBranch _) = True
259 isJump (CmmSwitch _ _) = True
260 isJump (CmmReturn _) = True
263 isOrdinaryStmt (CgStmt _) = True
264 isOrdinaryStmt _ = False
267 %************************************************************************
269 Stack and heap models
271 %************************************************************************
274 type VirtualHpOffset = WordOff -- Both are in
275 type VirtualSpOffset = WordOff -- units of words
279 virtSp :: VirtualSpOffset,
280 -- Virtual offset of topmost allocated slot
282 frameSp :: VirtualSpOffset,
283 -- Virtual offset of the return address of the enclosing frame.
284 -- This RA describes the liveness/pointedness of
285 -- all the stack from frameSp downwards
286 -- INVARIANT: less than or equal to virtSp
288 freeStk :: [VirtualSpOffset],
289 -- List of free slots, in *increasing* order
290 -- INVARIANT: all <= virtSp
291 -- All slots <= virtSp are taken except these ones
293 realSp :: VirtualSpOffset,
294 -- Virtual offset of real stack pointer register
296 hwSp :: VirtualSpOffset
297 } -- Highest value ever taken by virtSp
299 -- INVARIANT: The environment contains no Stable references to
300 -- stack slots below (lower offset) frameSp
301 -- It can contain volatile references to this area though.
305 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
306 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
310 The heap high water mark is the larger of virtHp and hwHp. The latter is
311 only records the high water marks of forked-off branches, so to find the
312 heap high water mark you have to take the max of virtHp and hwHp. Remember,
313 virtHp never retreats!
315 Note Jan 04: ok, so why do we only look at the virtual Hp??
318 heapHWM :: HeapUsage -> VirtualHpOffset
325 initStkUsage :: StackUsage
326 initStkUsage = StackUsage {
334 initHpUsage :: HeapUsage
335 initHpUsage = HeapUsage {
341 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
342 marks found in $e_2$.
345 stateIncUsage :: CgState -> CgState -> CgState
346 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
347 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
348 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
349 `addCodeBlocksFrom` s2
351 stateIncUsageEval :: CgState -> CgState -> CgState
352 stateIncUsageEval s1 s2
353 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
354 `addCodeBlocksFrom` s2
355 -- We don't max the heap high-watermark because stateIncUsageEval is
356 -- used only in forkEval, which in turn is only used for blocks of code
357 -- which do their own heap-check.
359 addCodeBlocksFrom :: CgState -> CgState -> CgState
360 -- Add code blocks from the latter to the former
361 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
362 s1 `addCodeBlocksFrom` s2
363 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
364 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
366 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
367 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
369 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
370 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
373 %************************************************************************
377 %************************************************************************
380 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
383 instance Monad FCode where
388 {-# INLINE thenFC #-}
389 {-# INLINE returnFC #-}
391 The Abstract~C is not in the environment so as to improve strictness.
394 initC :: DynFlags -> Module -> FCode a -> IO a
396 initC dflags mod (FCode code)
397 = do { uniqs <- mkSplitUniqSupply 'c'
398 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
399 (res, _) -> return res
402 returnFC :: a -> FCode a
403 returnFC val = FCode (\info_down state -> (val, state))
407 thenC :: Code -> FCode a -> FCode a
408 thenC (FCode m) (FCode k) =
409 FCode (\info_down state -> let (_,new_state) = m info_down state in
410 k info_down new_state)
412 listCs :: [Code] -> Code
413 listCs [] = return ()
418 mapCs :: (a -> Code) -> [a] -> Code
423 thenFC :: FCode a -> (a -> FCode c) -> FCode c
424 thenFC (FCode m) k = FCode (
427 (m_result, new_state) = m info_down state
428 (FCode kcode) = k m_result
430 kcode info_down new_state
433 listFCs :: [FCode a] -> FCode [a]
436 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
440 And the knot-tying combinator:
442 fixC :: (a -> FCode a) -> FCode a
447 result@(v,_) = fc info_down state
454 %************************************************************************
456 Operators for getting and setting the state and "info_down".
459 %************************************************************************
462 getState :: FCode CgState
463 getState = FCode $ \info_down state -> (state,state)
465 setState :: CgState -> FCode ()
466 setState state = FCode $ \info_down _ -> ((),state)
468 getStkUsage :: FCode StackUsage
471 return $ cgs_stk_usg state
473 setStkUsage :: StackUsage -> Code
474 setStkUsage new_stk_usg = do
476 setState $ state {cgs_stk_usg = new_stk_usg}
478 getHpUsage :: FCode HeapUsage
481 return $ cgs_hp_usg state
483 setHpUsage :: HeapUsage -> Code
484 setHpUsage new_hp_usg = do
486 setState $ state {cgs_hp_usg = new_hp_usg}
488 getBinds :: FCode CgBindings
491 return $ cgs_binds state
493 setBinds :: CgBindings -> FCode ()
494 setBinds new_binds = do
496 setState $ state {cgs_binds = new_binds}
498 getStaticBinds :: FCode CgBindings
501 return (cgd_statics info)
503 withState :: FCode a -> CgState -> FCode (a,CgState)
504 withState (FCode fcode) newstate = FCode $ \info_down state ->
505 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
507 newUniqSupply :: FCode UniqSupply
510 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
511 setState $ state { cgs_uniqs = us1 }
514 newUnique :: FCode Unique
517 return (uniqFromSupply us)
520 getInfoDown :: FCode CgInfoDownwards
521 getInfoDown = FCode $ \info_down state -> (info_down,state)
523 getDynFlags :: FCode DynFlags
524 getDynFlags = liftM cgd_dflags getInfoDown
526 getThisPackage :: FCode PackageId
527 getThisPackage = liftM thisPackage getDynFlags
529 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
530 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
532 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
533 doFCode (FCode fcode) info_down state = fcode info_down state
537 %************************************************************************
541 %************************************************************************
543 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
544 fresh environment, except that:
545 - compilation info and statics are passed in unchanged.
546 The current environment is passed on completely unaltered, except that
547 abstract C from the fork is incorporated.
549 @forkProc@ takes a code and compiles it in the current environment,
550 returning the basic blocks thus constructed. The current environment
551 is passed on completely unchanged. It is pretty similar to
552 @getBlocks@, except that the latter does affect the environment.
554 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
555 from the current bindings, but which is otherwise freshly initialised.
556 The Abstract~C returned is attached to the current state, but the
557 bindings and usage information is otherwise unchanged.
560 forkClosureBody :: Code -> Code
561 forkClosureBody body_code
562 = do { info <- getInfoDown
563 ; us <- newUniqSupply
565 ; let body_info_down = info { cgd_eob = initEobInfo }
566 ((),fork_state) = doFCode body_code body_info_down
568 ; ASSERT( isNilOL (cgs_stmts fork_state) )
569 setState $ state `addCodeBlocksFrom` fork_state }
571 forkStatics :: FCode a -> FCode a
572 forkStatics body_code
573 = do { info <- getInfoDown
574 ; us <- newUniqSupply
576 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
577 cgd_eob = initEobInfo }
578 (result, fork_state_out) = doFCode body_code rhs_info_down
580 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
581 setState (state `addCodeBlocksFrom` fork_state_out)
584 forkProc :: Code -> FCode CgStmts
586 = do { info_down <- getInfoDown
587 ; us <- newUniqSupply
589 ; let fork_state_in = (initCgState us)
590 { cgs_binds = cgs_binds state,
591 cgs_stk_usg = cgs_stk_usg state,
592 cgs_hp_usg = cgs_hp_usg state }
593 -- ToDo: is the hp usage necesary?
594 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
595 info_down fork_state_in
596 ; setState $ state `stateIncUsageEval` fork_state_out
599 codeOnly :: Code -> Code
600 -- Emit any code from the inner thing into the outer thing
601 -- Do not affect anything else in the outer state
602 -- Used in almost-circular code to prevent false loop dependencies
604 = do { info_down <- getInfoDown
605 ; us <- newUniqSupply
607 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
608 cgs_stk_usg = cgs_stk_usg state,
609 cgs_hp_usg = cgs_hp_usg state }
610 ((), fork_state_out) = doFCode body_code info_down fork_state_in
611 ; setState $ state `addCodeBlocksFrom` fork_state_out }
614 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
615 an fcode for the default case $d$, and compiles each in the current
616 environment. The current environment is passed on unmodified, except
618 - the worst stack high-water mark is incorporated
619 - the virtual Hp is moved on to the worst virtual Hp for the branches
622 forkAlts :: [FCode a] -> FCode [a]
624 forkAlts branch_fcodes
625 = do { info_down <- getInfoDown
626 ; us <- newUniqSupply
628 ; let compile us branch
629 = (us2, doFCode branch info_down branch_state)
631 (us1,us2) = splitUniqSupply us
632 branch_state = (initCgState us1) {
633 cgs_binds = cgs_binds state,
634 cgs_stk_usg = cgs_stk_usg state,
635 cgs_hp_usg = cgs_hp_usg state }
637 (_us, results) = mapAccumL compile us branch_fcodes
638 (branch_results, branch_out_states) = unzip results
639 ; setState $ foldl stateIncUsage state branch_out_states
640 -- NB foldl. state is the *left* argument to stateIncUsage
641 ; return branch_results }
644 @forkEval@ takes two blocks of code.
646 - The first meddles with the environment to set it up as expected by
647 the alternatives of a @case@ which does an eval (or gc-possible primop).
648 - The second block is the code for the alternatives.
649 (plus info for semi-tagging purposes)
651 @forkEval@ picks up the virtual stack pointer and returns a suitable
652 @EndOfBlockInfo@ for the caller to use, together with whatever value
653 is returned by the second block.
655 It uses @initEnvForAlternatives@ to initialise the environment, and
656 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
660 forkEval :: EndOfBlockInfo -- For the body
661 -> Code -- Code to set environment
662 -> FCode Sequel -- Semi-tagging info to store
663 -> FCode EndOfBlockInfo -- The new end of block info
665 forkEval body_eob_info env_code body_code
666 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
667 ; returnFC (EndOfBlockInfo v sequel) }
669 forkEvalHelp :: EndOfBlockInfo -- For the body
670 -> Code -- Code to set environment
671 -> FCode a -- The code to do after the eval
672 -> FCode (VirtualSpOffset, -- Sp
673 a) -- Result of the FCode
674 -- A disturbingly complicated function
675 forkEvalHelp body_eob_info env_code body_code
676 = do { info_down <- getInfoDown
677 ; us <- newUniqSupply
679 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
680 ; (_, env_state) = doFCode env_code info_down_for_body
681 (state {cgs_uniqs = us})
682 ; state_for_body = (initCgState (cgs_uniqs env_state))
683 { cgs_binds = binds_for_body,
684 cgs_stk_usg = stk_usg_for_body }
685 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
686 ; stk_usg_from_env = cgs_stk_usg env_state
687 ; virtSp_from_env = virtSp stk_usg_from_env
688 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
689 hwSp = virtSp_from_env}
690 ; (value_returned, state_at_end_return)
691 = doFCode body_code info_down_for_body state_for_body
693 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
694 -- The code coming back should consist only of nested declarations,
695 -- notably of the return vector!
696 setState $ state `stateIncUsageEval` state_at_end_return
697 ; return (virtSp_from_env, value_returned) }
700 -- ----------------------------------------------------------------------------
701 -- Combinators for emitting code
706 whenC :: Bool -> Code -> Code
707 whenC True code = code
708 whenC False code = nopC
710 stmtC :: CmmStmt -> Code
711 stmtC stmt = emitCgStmt (CgStmt stmt)
713 labelC :: BlockId -> Code
714 labelC id = emitCgStmt (CgLabel id)
716 newLabelC :: FCode BlockId
717 newLabelC = do { u <- newUnique
718 ; return $ BlockId u }
720 checkedAbsC :: CmmStmt -> Code
721 -- Emit code, eliminating no-ops
722 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
725 stmtsC :: [CmmStmt] -> Code
726 stmtsC stmts = emitStmts (toOL stmts)
728 -- Emit code; no no-op checking
729 emitStmts :: CmmStmts -> Code
730 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
732 -- forkLabelledCode is for emitting a chunk of code with a label, outside
733 -- of the current instruction stream.
734 forkLabelledCode :: Code -> FCode BlockId
735 forkLabelledCode code = getCgStmts code >>= forkCgStmts
737 emitCgStmt :: CgStmt -> Code
739 = do { state <- getState
740 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
743 emitData :: Section -> [CmmStatic] -> Code
745 = do { state <- getState
746 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
748 data_block = CmmData sect lits
750 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
751 emitProc info lbl args blocks
752 = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
754 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
756 emitSimpleProc :: CLabel -> Code -> Code
757 -- Emit a procedure whose body is the specified code; no info table
758 emitSimpleProc lbl code
759 = do { stmts <- getCgStmts code
760 ; blks <- cgStmtsToBlocks stmts
761 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
763 getCmm :: Code -> FCode Cmm
764 -- Get all the CmmTops (there should be no stmts)
765 -- Return a single Cmm which may be split from other Cmms by
766 -- object splitting (at a later stage)
768 = do { state1 <- getState
769 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
770 ; setState $ state2 { cgs_tops = cgs_tops state1 }
771 ; return (Cmm (fromOL (cgs_tops state2)))
774 -- ----------------------------------------------------------------------------
777 -- These functions deal in terms of CgStmts, which is an abstract type
778 -- representing the code in the current proc.
781 -- emit CgStmts into the current instruction stream
782 emitCgStmts :: CgStmts -> Code
784 = do { state <- getState
785 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
787 -- emit CgStmts outside the current instruction stream, and return a label
788 forkCgStmts :: CgStmts -> FCode BlockId
790 = do { id <- newLabelC
791 ; emitCgStmt (CgFork id stmts)
795 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
796 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
797 cgStmtsToBlocks stmts
798 = do { id <- newLabelC
799 ; return (flattenCgStmts id stmts)
802 -- collect the code emitted by an FCode computation
803 getCgStmts' :: FCode a -> FCode (a, CgStmts)
805 = do { state1 <- getState
806 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
807 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
808 ; return (a, cgs_stmts state2) }
810 getCgStmts :: FCode a -> FCode CgStmts
811 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
813 -- Simple ways to construct CgStmts:
817 oneCgStmt :: CmmStmt -> CgStmts
818 oneCgStmt stmt = unitOL (CgStmt stmt)
820 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
821 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
823 -- ----------------------------------------------------------------------------
824 -- Get the current module name
826 getModuleName :: FCode Module
827 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
829 -- ----------------------------------------------------------------------------
830 -- Get/set the end-of-block info
832 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
833 setEndOfBlockInfo eob_info code = do
835 withInfoDown code (info {cgd_eob = eob_info})
837 getEndOfBlockInfo :: FCode EndOfBlockInfo
838 getEndOfBlockInfo = do
840 return (cgd_eob info)
842 -- ----------------------------------------------------------------------------
843 -- Get/set the current SRT label
845 -- There is just one SRT for each top level binding; all the nested
846 -- bindings use sub-sections of this SRT. The label is passed down to
847 -- the nested bindings via the monad.
849 getSRTLabel :: FCode CLabel -- Used only by cgPanic
850 getSRTLabel = do info <- getInfoDown
851 return (cgd_srt_lbl info)
853 setSRTLabel :: CLabel -> FCode a -> FCode a
854 setSRTLabel srt_lbl code
855 = do info <- getInfoDown
856 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
859 getSRT = do info <- getInfoDown
860 return (cgd_srt info)
862 setSRT :: SRT -> FCode a -> FCode a
864 = do info <- getInfoDown
865 withInfoDown code (info { cgd_srt = srt})
867 -- ----------------------------------------------------------------------------
868 -- Get/set the current ticky counter label
870 getTickyCtrLabel :: FCode CLabel
871 getTickyCtrLabel = do
873 return (cgd_ticky info)
875 setTickyCtrLabel :: CLabel -> Code -> Code
876 setTickyCtrLabel ticky code = do
878 withInfoDown code (info {cgd_ticky = ticky})