2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[CgMonad]{The code generation monad}
7 See the beginning of the top-level @CodeGen@ module, to see how this
8 monadic stuff fits into the Big Picture.
15 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
16 returnFC, fixC, fixC_, checkedAbsC,
17 stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
18 newUnique, newUniqSupply,
20 CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
21 getCgStmts', getCgStmts,
22 noCgStmts, oneCgStmt, consCgStmt,
25 emitData, emitProc, emitSimpleProc,
28 forkClosureBody, forkStatics, forkAlts, forkEval,
29 forkEvalHelp, forkProc, codeOnly,
30 SemiTaggingStuff, ConTagZ,
33 setEndOfBlockInfo, getEndOfBlockInfo,
36 setSRTLabel, getSRTLabel,
37 setTickyCtrLabel, getTickyCtrLabel,
39 StackUsage(..), HeapUsage(..),
40 VirtualSpOffset, VirtualHpOffset,
41 initStkUsage, initHpUsage,
42 getHpUsage, setHpUsage,
47 Sequel(..), -- ToDo: unabstract?
49 -- ideally we wouldn't export these, but some other modules access internal state
50 getState, setState, getInfoDown, getDynFlags, getThisPackage,
52 -- more localised access to monad state
53 getStkUsage, setStkUsage,
54 getBinds, setBinds, getStaticBinds,
56 -- out of general friendliness, we also export ...
57 CgInfoDownwards(..), CgState(..) -- non-abstract
60 #include "HsVersions.h"
62 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
84 infixr 9 `thenC` -- Right-associative!
88 %************************************************************************
90 \subsection[CgMonad-environment]{Stuff for manipulating environments}
92 %************************************************************************
94 This monadery has some information that it only passes {\em
95 downwards}, as well as some ``state'' which is modified as we go
99 data CgInfoDownwards -- information only passed *downwards* by the monad
101 cgd_dflags :: DynFlags,
102 cgd_mod :: Module, -- Module being compiled
103 cgd_statics :: CgBindings, -- [Id -> info] : static environment
104 cgd_srt_lbl :: CLabel, -- label of the current SRT
105 cgd_srt :: SRT, -- the current SRT
106 cgd_ticky :: CLabel, -- current destination for ticky counts
107 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
110 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
111 initCgInfoDown dflags mod
112 = MkCgInfoDown { cgd_dflags = dflags,
114 cgd_statics = emptyVarEnv,
115 cgd_srt_lbl = error "initC: srt_lbl",
116 cgd_srt = error "initC: srt",
117 cgd_ticky = mkTopTickyCtrLabel,
118 cgd_eob = initEobInfo }
122 cgs_stmts :: OrdList CgStmt, -- Current proc
123 cgs_tops :: OrdList CmmTop,
124 -- Other procedures and data blocks in this compilation unit
125 -- Both the latter two are ordered only so that we can
126 -- reduce forward references, when it's easy to do so
128 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
129 -- Bindings for top-level things are given in
130 -- the info-down part
132 cgs_stk_usg :: StackUsage,
133 cgs_hp_usg :: HeapUsage,
135 cgs_uniqs :: UniqSupply }
137 initCgState :: UniqSupply -> CgState
139 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
140 cgs_binds = emptyVarEnv,
141 cgs_stk_usg = initStkUsage,
142 cgs_hp_usg = initHpUsage,
146 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
147 if the expression is a @case@, what to do at the end of each
153 VirtualSpOffset -- Args Sp: trim the stack to this point at a
154 -- return; push arguments starting just
155 -- above this point on a tail call.
157 -- This is therefore the stk ptr as seen
158 -- by a case alternative.
161 initEobInfo :: EndOfBlockInfo
162 initEobInfo = EndOfBlockInfo 0 OnStack
165 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
166 that it must survive stack pointer adjustments at the end of the
171 = OnStack -- Continuation is on the stack
174 CLabel -- Jump to this; if the continuation is for a vectored
175 -- case this might be the label of a return vector
177 Id -- The case binder, only used to see if it's dead
179 type SemiTaggingStuff
180 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
181 ([(ConTagZ, CmmLit)], -- Alternatives
182 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
184 type ConTagZ = Int -- A *zero-indexed* contructor tag
186 -- The case branch is executed only from a successful semitagging
187 -- venture, when a case has looked at a variable, found that it's
188 -- evaluated, and wants to load up the contents and go to the join
192 %************************************************************************
196 %************************************************************************
198 The CgStmts type is what the code generator outputs: it is a tree of
199 statements, including in-line labels. The job of flattenCgStmts is to
200 turn this into a list of basic blocks, each of which ends in a jump
201 statement (either a local branch or a non-local jump).
204 type CgStmts = OrdList CgStmt
209 | CgFork BlockId CgStmts
211 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
212 flattenCgStmts id stmts =
213 case flatten (fromOL stmts) of
214 ([],blocks) -> blocks
215 (block,blocks) -> BasicBlock id block : blocks
219 -- A label at the end of a function or fork: this label must not be reachable,
220 -- but it might be referred to from another BB that also isn't reachable.
221 -- Eliminating these has to be done with a dead-code analysis. For now,
222 -- we just make it into a well-formed block by adding a recursive jump.
224 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
226 -- A jump/branch: throw away all the code up to the next label, because
227 -- it is unreachable. Be careful to keep forks that we find on the way.
228 flatten (CgStmt stmt : stmts)
230 = case dropWhile isOrdinaryStmt stmts of
232 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
233 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
234 where (block,blocks) = flatten stmts
235 (CgFork fork_id stmts : ss) ->
236 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
237 (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
241 CgStmt stmt -> (stmt:block,blocks)
242 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
243 CgFork fork_id stmts ->
244 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
245 where (fork_block, fork_blocks) = flatten (fromOL stmts)
246 where (block,blocks) = flatten ss
248 isJump :: CmmStmt -> Bool
249 isJump (CmmJump _ _) = True
250 isJump (CmmBranch _) = True
251 isJump (CmmSwitch _ _) = True
252 isJump (CmmReturn _) = True
255 isOrdinaryStmt :: CgStmt -> Bool
256 isOrdinaryStmt (CgStmt _) = True
257 isOrdinaryStmt _ = False
260 %************************************************************************
262 Stack and heap models
264 %************************************************************************
267 type VirtualHpOffset = WordOff -- Both are in
268 type VirtualSpOffset = WordOff -- units of words
272 virtSp :: VirtualSpOffset,
273 -- Virtual offset of topmost allocated slot
275 frameSp :: VirtualSpOffset,
276 -- Virtual offset of the return address of the enclosing frame.
277 -- This RA describes the liveness/pointedness of
278 -- all the stack from frameSp downwards
279 -- INVARIANT: less than or equal to virtSp
281 freeStk :: [VirtualSpOffset],
282 -- List of free slots, in *increasing* order
283 -- INVARIANT: all <= virtSp
284 -- All slots <= virtSp are taken except these ones
286 realSp :: VirtualSpOffset,
287 -- Virtual offset of real stack pointer register
289 hwSp :: VirtualSpOffset
290 } -- Highest value ever taken by virtSp
292 -- INVARIANT: The environment contains no Stable references to
293 -- stack slots below (lower offset) frameSp
294 -- It can contain volatile references to this area though.
298 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
299 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
303 The heap high water mark is the larger of virtHp and hwHp. The latter is
304 only records the high water marks of forked-off branches, so to find the
305 heap high water mark you have to take the max of virtHp and hwHp. Remember,
306 virtHp never retreats!
308 Note Jan 04: ok, so why do we only look at the virtual Hp??
311 heapHWM :: HeapUsage -> VirtualHpOffset
318 initStkUsage :: StackUsage
319 initStkUsage = StackUsage {
327 initHpUsage :: HeapUsage
328 initHpUsage = HeapUsage {
334 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
335 marks found in $e_2$.
338 stateIncUsage :: CgState -> CgState -> CgState
339 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
340 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
341 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
342 `addCodeBlocksFrom` s2
344 stateIncUsageEval :: CgState -> CgState -> CgState
345 stateIncUsageEval s1 s2
346 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
347 `addCodeBlocksFrom` s2
348 -- We don't max the heap high-watermark because stateIncUsageEval is
349 -- used only in forkEval, which in turn is only used for blocks of code
350 -- which do their own heap-check.
352 addCodeBlocksFrom :: CgState -> CgState -> CgState
353 -- Add code blocks from the latter to the former
354 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
355 s1 `addCodeBlocksFrom` s2
356 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
357 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
359 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
360 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
362 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
363 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
366 %************************************************************************
370 %************************************************************************
373 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
376 instance Monad FCode where
381 {-# INLINE thenFC #-}
382 {-# INLINE returnFC #-}
384 The Abstract~C is not in the environment so as to improve strictness.
387 initC :: DynFlags -> Module -> FCode a -> IO a
389 initC dflags mod (FCode code)
390 = do { uniqs <- mkSplitUniqSupply 'c'
391 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
392 (res, _) -> return res
395 returnFC :: a -> FCode a
396 returnFC val = FCode (\_ state -> (val, state))
400 thenC :: Code -> FCode a -> FCode a
401 thenC (FCode m) (FCode k) =
402 FCode (\info_down state -> let (_,new_state) = m info_down state in
403 k info_down new_state)
405 listCs :: [Code] -> Code
406 listCs [] = return ()
411 mapCs :: (a -> Code) -> [a] -> Code
416 thenFC :: FCode a -> (a -> FCode c) -> FCode c
417 thenFC (FCode m) k = FCode (
420 (m_result, new_state) = m info_down state
421 (FCode kcode) = k m_result
423 kcode info_down new_state
426 listFCs :: [FCode a] -> FCode [a]
429 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
433 And the knot-tying combinator:
435 fixC :: (a -> FCode a) -> FCode a
440 result@(v,_) = fc info_down state
446 fixC_ :: (a -> FCode a) -> FCode ()
447 fixC_ fcode = fixC fcode >> return ()
450 %************************************************************************
452 Operators for getting and setting the state and "info_down".
455 %************************************************************************
458 getState :: FCode CgState
459 getState = FCode $ \_ state -> (state,state)
461 setState :: CgState -> FCode ()
462 setState state = FCode $ \_ _ -> ((),state)
464 getStkUsage :: FCode StackUsage
467 return $ cgs_stk_usg state
469 setStkUsage :: StackUsage -> Code
470 setStkUsage new_stk_usg = do
472 setState $ state {cgs_stk_usg = new_stk_usg}
474 getHpUsage :: FCode HeapUsage
477 return $ cgs_hp_usg state
479 setHpUsage :: HeapUsage -> Code
480 setHpUsage new_hp_usg = do
482 setState $ state {cgs_hp_usg = new_hp_usg}
484 getBinds :: FCode CgBindings
487 return $ cgs_binds state
489 setBinds :: CgBindings -> FCode ()
490 setBinds new_binds = do
492 setState $ state {cgs_binds = new_binds}
494 getStaticBinds :: FCode CgBindings
497 return (cgd_statics info)
499 withState :: FCode a -> CgState -> FCode (a,CgState)
500 withState (FCode fcode) newstate = FCode $ \info_down state ->
501 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
503 newUniqSupply :: FCode UniqSupply
506 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
507 setState $ state { cgs_uniqs = us1 }
510 newUnique :: FCode Unique
513 return (uniqFromSupply us)
516 getInfoDown :: FCode CgInfoDownwards
517 getInfoDown = FCode $ \info_down state -> (info_down,state)
519 getDynFlags :: FCode DynFlags
520 getDynFlags = liftM cgd_dflags getInfoDown
522 getThisPackage :: FCode PackageId
523 getThisPackage = liftM thisPackage getDynFlags
525 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
526 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
528 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
529 doFCode (FCode fcode) info_down state = fcode info_down state
533 %************************************************************************
537 %************************************************************************
539 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
540 fresh environment, except that:
541 - compilation info and statics are passed in unchanged.
542 The current environment is passed on completely unaltered, except that
543 abstract C from the fork is incorporated.
545 @forkProc@ takes a code and compiles it in the current environment,
546 returning the basic blocks thus constructed. The current environment
547 is passed on completely unchanged. It is pretty similar to
548 @getBlocks@, except that the latter does affect the environment.
550 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
551 from the current bindings, but which is otherwise freshly initialised.
552 The Abstract~C returned is attached to the current state, but the
553 bindings and usage information is otherwise unchanged.
556 forkClosureBody :: Code -> Code
557 forkClosureBody body_code
558 = do { info <- getInfoDown
559 ; us <- newUniqSupply
561 ; let body_info_down = info { cgd_eob = initEobInfo }
562 ((),fork_state) = doFCode body_code body_info_down
564 ; ASSERT( isNilOL (cgs_stmts fork_state) )
565 setState $ state `addCodeBlocksFrom` fork_state }
567 forkStatics :: FCode a -> FCode a
568 forkStatics body_code
569 = do { info <- getInfoDown
570 ; us <- newUniqSupply
572 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
573 cgd_eob = initEobInfo }
574 (result, fork_state_out) = doFCode body_code rhs_info_down
576 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
577 setState (state `addCodeBlocksFrom` fork_state_out)
580 forkProc :: Code -> FCode CgStmts
582 = do { info_down <- getInfoDown
583 ; us <- newUniqSupply
585 ; let fork_state_in = (initCgState us)
586 { cgs_binds = cgs_binds state,
587 cgs_stk_usg = cgs_stk_usg state,
588 cgs_hp_usg = cgs_hp_usg state }
589 -- ToDo: is the hp usage necesary?
590 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
591 info_down fork_state_in
592 ; setState $ state `stateIncUsageEval` fork_state_out
595 codeOnly :: Code -> Code
596 -- Emit any code from the inner thing into the outer thing
597 -- Do not affect anything else in the outer state
598 -- Used in almost-circular code to prevent false loop dependencies
600 = do { info_down <- getInfoDown
601 ; us <- newUniqSupply
603 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
604 cgs_stk_usg = cgs_stk_usg state,
605 cgs_hp_usg = cgs_hp_usg state }
606 ((), fork_state_out) = doFCode body_code info_down fork_state_in
607 ; setState $ state `addCodeBlocksFrom` fork_state_out }
610 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
611 an fcode for the default case $d$, and compiles each in the current
612 environment. The current environment is passed on unmodified, except
614 - the worst stack high-water mark is incorporated
615 - the virtual Hp is moved on to the worst virtual Hp for the branches
618 forkAlts :: [FCode a] -> FCode [a]
620 forkAlts branch_fcodes
621 = do { info_down <- getInfoDown
622 ; us <- newUniqSupply
624 ; let compile us branch
625 = (us2, doFCode branch info_down branch_state)
627 (us1,us2) = splitUniqSupply us
628 branch_state = (initCgState us1) {
629 cgs_binds = cgs_binds state,
630 cgs_stk_usg = cgs_stk_usg state,
631 cgs_hp_usg = cgs_hp_usg state }
633 (_us, results) = mapAccumL compile us branch_fcodes
634 (branch_results, branch_out_states) = unzip results
635 ; setState $ foldl stateIncUsage state branch_out_states
636 -- NB foldl. state is the *left* argument to stateIncUsage
637 ; return branch_results }
640 @forkEval@ takes two blocks of code.
642 - The first meddles with the environment to set it up as expected by
643 the alternatives of a @case@ which does an eval (or gc-possible primop).
644 - The second block is the code for the alternatives.
645 (plus info for semi-tagging purposes)
647 @forkEval@ picks up the virtual stack pointer and returns a suitable
648 @EndOfBlockInfo@ for the caller to use, together with whatever value
649 is returned by the second block.
651 It uses @initEnvForAlternatives@ to initialise the environment, and
652 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
656 forkEval :: EndOfBlockInfo -- For the body
657 -> Code -- Code to set environment
658 -> FCode Sequel -- Semi-tagging info to store
659 -> FCode EndOfBlockInfo -- The new end of block info
661 forkEval body_eob_info env_code body_code
662 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
663 ; returnFC (EndOfBlockInfo v sequel) }
665 forkEvalHelp :: EndOfBlockInfo -- For the body
666 -> Code -- Code to set environment
667 -> FCode a -- The code to do after the eval
668 -> FCode (VirtualSpOffset, -- Sp
669 a) -- Result of the FCode
670 -- A disturbingly complicated function
671 forkEvalHelp body_eob_info env_code body_code
672 = do { info_down <- getInfoDown
673 ; us <- newUniqSupply
675 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
676 ; (_, env_state) = doFCode env_code info_down_for_body
677 (state {cgs_uniqs = us})
678 ; state_for_body = (initCgState (cgs_uniqs env_state))
679 { cgs_binds = binds_for_body,
680 cgs_stk_usg = stk_usg_for_body }
681 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
682 ; stk_usg_from_env = cgs_stk_usg env_state
683 ; virtSp_from_env = virtSp stk_usg_from_env
684 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
685 hwSp = virtSp_from_env}
686 ; (value_returned, state_at_end_return)
687 = doFCode body_code info_down_for_body state_for_body
689 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
690 -- The code coming back should consist only of nested declarations,
691 -- notably of the return vector!
692 setState $ state `stateIncUsageEval` state_at_end_return
693 ; return (virtSp_from_env, value_returned) }
696 -- ----------------------------------------------------------------------------
697 -- Combinators for emitting code
702 whenC :: Bool -> Code -> Code
703 whenC True code = code
706 stmtC :: CmmStmt -> Code
707 stmtC stmt = emitCgStmt (CgStmt stmt)
709 labelC :: BlockId -> Code
710 labelC id = emitCgStmt (CgLabel id)
712 newLabelC :: FCode BlockId
713 newLabelC = do { u <- newUnique
714 ; return $ BlockId u }
716 checkedAbsC :: CmmStmt -> Code
717 -- Emit code, eliminating no-ops
718 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
721 stmtsC :: [CmmStmt] -> Code
722 stmtsC stmts = emitStmts (toOL stmts)
724 -- Emit code; no no-op checking
725 emitStmts :: CmmStmts -> Code
726 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
728 -- forkLabelledCode is for emitting a chunk of code with a label, outside
729 -- of the current instruction stream.
730 forkLabelledCode :: Code -> FCode BlockId
731 forkLabelledCode code = getCgStmts code >>= forkCgStmts
733 emitCgStmt :: CgStmt -> Code
735 = do { state <- getState
736 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
739 emitData :: Section -> [CmmStatic] -> Code
741 = do { state <- getState
742 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
744 data_block = CmmData sect lits
746 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
747 emitProc info lbl args blocks
748 = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
750 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
752 emitSimpleProc :: CLabel -> Code -> Code
753 -- Emit a procedure whose body is the specified code; no info table
754 emitSimpleProc lbl code
755 = do { stmts <- getCgStmts code
756 ; blks <- cgStmtsToBlocks stmts
757 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
759 getCmm :: Code -> FCode Cmm
760 -- Get all the CmmTops (there should be no stmts)
761 -- Return a single Cmm which may be split from other Cmms by
762 -- object splitting (at a later stage)
764 = do { state1 <- getState
765 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
766 ; setState $ state2 { cgs_tops = cgs_tops state1 }
767 ; return (Cmm (fromOL (cgs_tops state2)))
770 -- ----------------------------------------------------------------------------
773 -- These functions deal in terms of CgStmts, which is an abstract type
774 -- representing the code in the current proc.
777 -- emit CgStmts into the current instruction stream
778 emitCgStmts :: CgStmts -> Code
780 = do { state <- getState
781 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
783 -- emit CgStmts outside the current instruction stream, and return a label
784 forkCgStmts :: CgStmts -> FCode BlockId
786 = do { id <- newLabelC
787 ; emitCgStmt (CgFork id stmts)
791 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
792 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
793 cgStmtsToBlocks stmts
794 = do { id <- newLabelC
795 ; return (flattenCgStmts id stmts)
798 -- collect the code emitted by an FCode computation
799 getCgStmts' :: FCode a -> FCode (a, CgStmts)
801 = do { state1 <- getState
802 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
803 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
804 ; return (a, cgs_stmts state2) }
806 getCgStmts :: FCode a -> FCode CgStmts
807 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
809 -- Simple ways to construct CgStmts:
813 oneCgStmt :: CmmStmt -> CgStmts
814 oneCgStmt stmt = unitOL (CgStmt stmt)
816 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
817 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
819 -- ----------------------------------------------------------------------------
820 -- Get the current module name
822 getModuleName :: FCode Module
823 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
825 -- ----------------------------------------------------------------------------
826 -- Get/set the end-of-block info
828 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
829 setEndOfBlockInfo eob_info code = do
831 withInfoDown code (info {cgd_eob = eob_info})
833 getEndOfBlockInfo :: FCode EndOfBlockInfo
834 getEndOfBlockInfo = do
836 return (cgd_eob info)
838 -- ----------------------------------------------------------------------------
839 -- Get/set the current SRT label
841 -- There is just one SRT for each top level binding; all the nested
842 -- bindings use sub-sections of this SRT. The label is passed down to
843 -- the nested bindings via the monad.
845 getSRTLabel :: FCode CLabel -- Used only by cgPanic
846 getSRTLabel = do info <- getInfoDown
847 return (cgd_srt_lbl info)
849 setSRTLabel :: CLabel -> FCode a -> FCode a
850 setSRTLabel srt_lbl code
851 = do info <- getInfoDown
852 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
855 getSRT = do info <- getInfoDown
856 return (cgd_srt info)
858 setSRT :: SRT -> FCode a -> FCode a
860 = do info <- getInfoDown
861 withInfoDown code (info { cgd_srt = srt})
863 -- ----------------------------------------------------------------------------
864 -- Get/set the current ticky counter label
866 getTickyCtrLabel :: FCode CLabel
867 getTickyCtrLabel = do
869 return (cgd_ticky info)
871 setTickyCtrLabel :: CLabel -> Code -> Code
872 setTickyCtrLabel ticky code = do
874 withInfoDown code (info {cgd_ticky = ticky})