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 )
92 infixr 9 `thenC` -- Right-associative!
96 %************************************************************************
98 \subsection[CgMonad-environment]{Stuff for manipulating environments}
100 %************************************************************************
102 This monadery has some information that it only passes {\em
103 downwards}, as well as some ``state'' which is modified as we go
107 data CgInfoDownwards -- information only passed *downwards* by the monad
109 cgd_dflags :: DynFlags,
110 cgd_mod :: Module, -- Module being compiled
111 cgd_statics :: CgBindings, -- [Id -> info] : static environment
112 cgd_srt_lbl :: CLabel, -- label of the current SRT
113 cgd_srt :: SRT, -- the current SRT
114 cgd_ticky :: CLabel, -- current destination for ticky counts
115 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
118 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
119 initCgInfoDown dflags mod
120 = MkCgInfoDown { cgd_dflags = dflags,
122 cgd_statics = emptyVarEnv,
123 cgd_srt_lbl = error "initC: srt_lbl",
124 cgd_srt = error "initC: srt",
125 cgd_ticky = mkTopTickyCtrLabel,
126 cgd_eob = initEobInfo }
130 cgs_stmts :: OrdList CgStmt, -- Current proc
131 cgs_tops :: OrdList CmmTop,
132 -- Other procedures and data blocks in this compilation unit
133 -- Both the latter two are ordered only so that we can
134 -- reduce forward references, when it's easy to do so
136 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
137 -- Bindings for top-level things are given in
138 -- the info-down part
140 cgs_stk_usg :: StackUsage,
141 cgs_hp_usg :: HeapUsage,
143 cgs_uniqs :: UniqSupply }
145 initCgState :: UniqSupply -> CgState
147 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
148 cgs_binds = emptyVarEnv,
149 cgs_stk_usg = initStkUsage,
150 cgs_hp_usg = initHpUsage,
154 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
155 if the expression is a @case@, what to do at the end of each
161 VirtualSpOffset -- Args Sp: trim the stack to this point at a
162 -- return; push arguments starting just
163 -- above this point on a tail call.
165 -- This is therefore the stk ptr as seen
166 -- by a case alternative.
169 initEobInfo = EndOfBlockInfo 0 OnStack
172 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
173 that it must survive stack pointer adjustments at the end of the
178 = OnStack -- Continuation is on the stack
179 | UpdateCode -- Continuation is update
182 CLabel -- Jump to this; if the continuation is for a vectored
183 -- case this might be the label of a return vector
185 Id -- The case binder, only used to see if it's dead
187 type SemiTaggingStuff
188 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
189 ([(ConTagZ, CmmLit)], -- Alternatives
190 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
192 type ConTagZ = Int -- A *zero-indexed* contructor tag
194 -- The case branch is executed only from a successful semitagging
195 -- venture, when a case has looked at a variable, found that it's
196 -- evaluated, and wants to load up the contents and go to the join
200 %************************************************************************
204 %************************************************************************
206 The CgStmts type is what the code generator outputs: it is a tree of
207 statements, including in-line labels. The job of flattenCgStmts is to
208 turn this into a list of basic blocks, each of which ends in a jump
209 statement (either a local branch or a non-local jump).
212 type CgStmts = OrdList CgStmt
217 | CgFork BlockId CgStmts
219 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
220 flattenCgStmts id stmts =
221 case flatten (fromOL stmts) of
222 ([],blocks) -> blocks
223 (block,blocks) -> BasicBlock id block : blocks
227 -- A label at the end of a function or fork: this label must not be reachable,
228 -- but it might be referred to from another BB that also isn't reachable.
229 -- Eliminating these has to be done with a dead-code analysis. For now,
230 -- we just make it into a well-formed block by adding a recursive jump.
232 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
234 -- A jump/branch: throw away all the code up to the next label, because
235 -- it is unreachable. Be careful to keep forks that we find on the way.
236 flatten (CgStmt stmt : stmts)
238 = case dropWhile isOrdinaryStmt stmts of
240 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
241 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
242 where (block,blocks) = flatten stmts
243 (CgFork fork_id stmts : ss) ->
244 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
245 (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
249 CgStmt stmt -> (stmt:block,blocks)
250 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
251 CgFork fork_id stmts ->
252 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
253 where (fork_block, fork_blocks) = flatten (fromOL stmts)
254 where (block,blocks) = flatten ss
256 isJump (CmmJump _ _) = True
257 isJump (CmmBranch _) = True
258 isJump (CmmSwitch _ _) = True
259 isJump (CmmReturn _) = True
262 isOrdinaryStmt (CgStmt _) = True
263 isOrdinaryStmt _ = False
266 %************************************************************************
268 Stack and heap models
270 %************************************************************************
273 type VirtualHpOffset = WordOff -- Both are in
274 type VirtualSpOffset = WordOff -- units of words
278 virtSp :: VirtualSpOffset,
279 -- Virtual offset of topmost allocated slot
281 frameSp :: VirtualSpOffset,
282 -- Virtual offset of the return address of the enclosing frame.
283 -- This RA describes the liveness/pointedness of
284 -- all the stack from frameSp downwards
285 -- INVARIANT: less than or equal to virtSp
287 freeStk :: [VirtualSpOffset],
288 -- List of free slots, in *increasing* order
289 -- INVARIANT: all <= virtSp
290 -- All slots <= virtSp are taken except these ones
292 realSp :: VirtualSpOffset,
293 -- Virtual offset of real stack pointer register
295 hwSp :: VirtualSpOffset
296 } -- Highest value ever taken by virtSp
298 -- INVARIANT: The environment contains no Stable references to
299 -- stack slots below (lower offset) frameSp
300 -- It can contain volatile references to this area though.
304 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
305 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
309 The heap high water mark is the larger of virtHp and hwHp. The latter is
310 only records the high water marks of forked-off branches, so to find the
311 heap high water mark you have to take the max of virtHp and hwHp. Remember,
312 virtHp never retreats!
314 Note Jan 04: ok, so why do we only look at the virtual Hp??
317 heapHWM :: HeapUsage -> VirtualHpOffset
324 initStkUsage :: StackUsage
325 initStkUsage = StackUsage {
333 initHpUsage :: HeapUsage
334 initHpUsage = HeapUsage {
340 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
341 marks found in $e_2$.
344 stateIncUsage :: CgState -> CgState -> CgState
345 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
346 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
347 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
348 `addCodeBlocksFrom` s2
350 stateIncUsageEval :: CgState -> CgState -> CgState
351 stateIncUsageEval s1 s2
352 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
353 `addCodeBlocksFrom` s2
354 -- We don't max the heap high-watermark because stateIncUsageEval is
355 -- used only in forkEval, which in turn is only used for blocks of code
356 -- which do their own heap-check.
358 addCodeBlocksFrom :: CgState -> CgState -> CgState
359 -- Add code blocks from the latter to the former
360 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
361 s1 `addCodeBlocksFrom` s2
362 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
363 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
365 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
366 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
368 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
369 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
372 %************************************************************************
376 %************************************************************************
379 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
382 instance Monad FCode where
387 {-# INLINE thenFC #-}
388 {-# INLINE returnFC #-}
390 The Abstract~C is not in the environment so as to improve strictness.
393 initC :: DynFlags -> Module -> FCode a -> IO a
395 initC dflags mod (FCode code)
396 = do { uniqs <- mkSplitUniqSupply 'c'
397 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
398 (res, _) -> return res
401 returnFC :: a -> FCode a
402 returnFC val = FCode (\info_down state -> (val, state))
406 thenC :: Code -> FCode a -> FCode a
407 thenC (FCode m) (FCode k) =
408 FCode (\info_down state -> let (_,new_state) = m info_down state in
409 k info_down new_state)
411 listCs :: [Code] -> Code
412 listCs [] = return ()
417 mapCs :: (a -> Code) -> [a] -> Code
422 thenFC :: FCode a -> (a -> FCode c) -> FCode c
423 thenFC (FCode m) k = FCode (
426 (m_result, new_state) = m info_down state
427 (FCode kcode) = k m_result
429 kcode info_down new_state
432 listFCs :: [FCode a] -> FCode [a]
435 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
439 And the knot-tying combinator:
441 fixC :: (a -> FCode a) -> FCode a
446 result@(v,_) = fc info_down state
453 %************************************************************************
455 Operators for getting and setting the state and "info_down".
458 %************************************************************************
461 getState :: FCode CgState
462 getState = FCode $ \info_down state -> (state,state)
464 setState :: CgState -> FCode ()
465 setState state = FCode $ \info_down _ -> ((),state)
467 getStkUsage :: FCode StackUsage
470 return $ cgs_stk_usg state
472 setStkUsage :: StackUsage -> Code
473 setStkUsage new_stk_usg = do
475 setState $ state {cgs_stk_usg = new_stk_usg}
477 getHpUsage :: FCode HeapUsage
480 return $ cgs_hp_usg state
482 setHpUsage :: HeapUsage -> Code
483 setHpUsage new_hp_usg = do
485 setState $ state {cgs_hp_usg = new_hp_usg}
487 getBinds :: FCode CgBindings
490 return $ cgs_binds state
492 setBinds :: CgBindings -> FCode ()
493 setBinds new_binds = do
495 setState $ state {cgs_binds = new_binds}
497 getStaticBinds :: FCode CgBindings
500 return (cgd_statics info)
502 withState :: FCode a -> CgState -> FCode (a,CgState)
503 withState (FCode fcode) newstate = FCode $ \info_down state ->
504 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
506 newUniqSupply :: FCode UniqSupply
509 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
510 setState $ state { cgs_uniqs = us1 }
513 newUnique :: FCode Unique
516 return (uniqFromSupply us)
519 getInfoDown :: FCode CgInfoDownwards
520 getInfoDown = FCode $ \info_down state -> (info_down,state)
522 getDynFlags :: FCode DynFlags
523 getDynFlags = liftM cgd_dflags getInfoDown
525 getThisPackage :: FCode PackageId
526 getThisPackage = liftM thisPackage getDynFlags
528 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
529 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
531 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
532 doFCode (FCode fcode) info_down state = fcode info_down state
536 %************************************************************************
540 %************************************************************************
542 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
543 fresh environment, except that:
544 - compilation info and statics are passed in unchanged.
545 The current environment is passed on completely unaltered, except that
546 abstract C from the fork is incorporated.
548 @forkProc@ takes a code and compiles it in the current environment,
549 returning the basic blocks thus constructed. The current environment
550 is passed on completely unchanged. It is pretty similar to
551 @getBlocks@, except that the latter does affect the environment.
553 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
554 from the current bindings, but which is otherwise freshly initialised.
555 The Abstract~C returned is attached to the current state, but the
556 bindings and usage information is otherwise unchanged.
559 forkClosureBody :: Code -> Code
560 forkClosureBody body_code
561 = do { info <- getInfoDown
562 ; us <- newUniqSupply
564 ; let body_info_down = info { cgd_eob = initEobInfo }
565 ((),fork_state) = doFCode body_code body_info_down
567 ; ASSERT( isNilOL (cgs_stmts fork_state) )
568 setState $ state `addCodeBlocksFrom` fork_state }
570 forkStatics :: FCode a -> FCode a
571 forkStatics body_code
572 = do { info <- getInfoDown
573 ; us <- newUniqSupply
575 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
576 cgd_eob = initEobInfo }
577 (result, fork_state_out) = doFCode body_code rhs_info_down
579 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
580 setState (state `addCodeBlocksFrom` fork_state_out)
583 forkProc :: Code -> FCode CgStmts
585 = do { info_down <- getInfoDown
586 ; us <- newUniqSupply
588 ; let fork_state_in = (initCgState us)
589 { cgs_binds = cgs_binds state,
590 cgs_stk_usg = cgs_stk_usg state,
591 cgs_hp_usg = cgs_hp_usg state }
592 -- ToDo: is the hp usage necesary?
593 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
594 info_down fork_state_in
595 ; setState $ state `stateIncUsageEval` fork_state_out
598 codeOnly :: Code -> Code
599 -- Emit any code from the inner thing into the outer thing
600 -- Do not affect anything else in the outer state
601 -- Used in almost-circular code to prevent false loop dependencies
603 = do { info_down <- getInfoDown
604 ; us <- newUniqSupply
606 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
607 cgs_stk_usg = cgs_stk_usg state,
608 cgs_hp_usg = cgs_hp_usg state }
609 ((), fork_state_out) = doFCode body_code info_down fork_state_in
610 ; setState $ state `addCodeBlocksFrom` fork_state_out }
613 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
614 an fcode for the default case $d$, and compiles each in the current
615 environment. The current environment is passed on unmodified, except
617 - the worst stack high-water mark is incorporated
618 - the virtual Hp is moved on to the worst virtual Hp for the branches
621 forkAlts :: [FCode a] -> FCode [a]
623 forkAlts branch_fcodes
624 = do { info_down <- getInfoDown
625 ; us <- newUniqSupply
627 ; let compile us branch
628 = (us2, doFCode branch info_down branch_state)
630 (us1,us2) = splitUniqSupply us
631 branch_state = (initCgState us1) {
632 cgs_binds = cgs_binds state,
633 cgs_stk_usg = cgs_stk_usg state,
634 cgs_hp_usg = cgs_hp_usg state }
636 (_us, results) = mapAccumL compile us branch_fcodes
637 (branch_results, branch_out_states) = unzip results
638 ; setState $ foldl stateIncUsage state branch_out_states
639 -- NB foldl. state is the *left* argument to stateIncUsage
640 ; return branch_results }
643 @forkEval@ takes two blocks of code.
645 - The first meddles with the environment to set it up as expected by
646 the alternatives of a @case@ which does an eval (or gc-possible primop).
647 - The second block is the code for the alternatives.
648 (plus info for semi-tagging purposes)
650 @forkEval@ picks up the virtual stack pointer and returns a suitable
651 @EndOfBlockInfo@ for the caller to use, together with whatever value
652 is returned by the second block.
654 It uses @initEnvForAlternatives@ to initialise the environment, and
655 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
659 forkEval :: EndOfBlockInfo -- For the body
660 -> Code -- Code to set environment
661 -> FCode Sequel -- Semi-tagging info to store
662 -> FCode EndOfBlockInfo -- The new end of block info
664 forkEval body_eob_info env_code body_code
665 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
666 ; returnFC (EndOfBlockInfo v sequel) }
668 forkEvalHelp :: EndOfBlockInfo -- For the body
669 -> Code -- Code to set environment
670 -> FCode a -- The code to do after the eval
671 -> FCode (VirtualSpOffset, -- Sp
672 a) -- Result of the FCode
673 -- A disturbingly complicated function
674 forkEvalHelp body_eob_info env_code body_code
675 = do { info_down <- getInfoDown
676 ; us <- newUniqSupply
678 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
679 ; (_, env_state) = doFCode env_code info_down_for_body
680 (state {cgs_uniqs = us})
681 ; state_for_body = (initCgState (cgs_uniqs env_state))
682 { cgs_binds = binds_for_body,
683 cgs_stk_usg = stk_usg_for_body }
684 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
685 ; stk_usg_from_env = cgs_stk_usg env_state
686 ; virtSp_from_env = virtSp stk_usg_from_env
687 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
688 hwSp = virtSp_from_env}
689 ; (value_returned, state_at_end_return)
690 = doFCode body_code info_down_for_body state_for_body
692 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
693 -- The code coming back should consist only of nested declarations,
694 -- notably of the return vector!
695 setState $ state `stateIncUsageEval` state_at_end_return
696 ; return (virtSp_from_env, value_returned) }
699 -- ----------------------------------------------------------------------------
700 -- Combinators for emitting code
705 whenC :: Bool -> Code -> Code
706 whenC True code = code
707 whenC False code = nopC
709 stmtC :: CmmStmt -> Code
710 stmtC stmt = emitCgStmt (CgStmt stmt)
712 labelC :: BlockId -> Code
713 labelC id = emitCgStmt (CgLabel id)
715 newLabelC :: FCode BlockId
716 newLabelC = do { u <- newUnique
717 ; return $ BlockId u }
719 checkedAbsC :: CmmStmt -> Code
720 -- Emit code, eliminating no-ops
721 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
724 stmtsC :: [CmmStmt] -> Code
725 stmtsC stmts = emitStmts (toOL stmts)
727 -- Emit code; no no-op checking
728 emitStmts :: CmmStmts -> Code
729 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
731 -- forkLabelledCode is for emitting a chunk of code with a label, outside
732 -- of the current instruction stream.
733 forkLabelledCode :: Code -> FCode BlockId
734 forkLabelledCode code = getCgStmts code >>= forkCgStmts
736 emitCgStmt :: CgStmt -> Code
738 = do { state <- getState
739 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
742 emitData :: Section -> [CmmStatic] -> Code
744 = do { state <- getState
745 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
747 data_block = CmmData sect lits
749 emitProc :: CmmInfo -> CLabel -> CmmFormalsWithoutKinds -> [CmmBasicBlock] -> Code
750 emitProc info lbl args blocks
751 = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
753 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
755 emitSimpleProc :: CLabel -> Code -> Code
756 -- Emit a procedure whose body is the specified code; no info table
757 emitSimpleProc lbl code
758 = do { stmts <- getCgStmts code
759 ; blks <- cgStmtsToBlocks stmts
760 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
762 getCmm :: Code -> FCode Cmm
763 -- Get all the CmmTops (there should be no stmts)
764 -- Return a single Cmm which may be split from other Cmms by
765 -- object splitting (at a later stage)
767 = do { state1 <- getState
768 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
769 ; setState $ state2 { cgs_tops = cgs_tops state1 }
770 ; return (Cmm (fromOL (cgs_tops state2))) }
772 -- ----------------------------------------------------------------------------
775 -- These functions deal in terms of CgStmts, which is an abstract type
776 -- representing the code in the current proc.
779 -- emit CgStmts into the current instruction stream
780 emitCgStmts :: CgStmts -> Code
782 = do { state <- getState
783 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
785 -- emit CgStmts outside the current instruction stream, and return a label
786 forkCgStmts :: CgStmts -> FCode BlockId
788 = do { id <- newLabelC
789 ; emitCgStmt (CgFork id stmts)
793 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
794 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
795 cgStmtsToBlocks stmts
796 = do { id <- newLabelC
797 ; return (flattenCgStmts id stmts)
800 -- collect the code emitted by an FCode computation
801 getCgStmts' :: FCode a -> FCode (a, CgStmts)
803 = do { state1 <- getState
804 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
805 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
806 ; return (a, cgs_stmts state2) }
808 getCgStmts :: FCode a -> FCode CgStmts
809 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
811 -- Simple ways to construct CgStmts:
815 oneCgStmt :: CmmStmt -> CgStmts
816 oneCgStmt stmt = unitOL (CgStmt stmt)
818 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
819 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
821 -- ----------------------------------------------------------------------------
822 -- Get the current module name
824 getModuleName :: FCode Module
825 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
827 -- ----------------------------------------------------------------------------
828 -- Get/set the end-of-block info
830 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
831 setEndOfBlockInfo eob_info code = do
833 withInfoDown code (info {cgd_eob = eob_info})
835 getEndOfBlockInfo :: FCode EndOfBlockInfo
836 getEndOfBlockInfo = do
838 return (cgd_eob info)
840 -- ----------------------------------------------------------------------------
841 -- Get/set the current SRT label
843 -- There is just one SRT for each top level binding; all the nested
844 -- bindings use sub-sections of this SRT. The label is passed down to
845 -- the nested bindings via the monad.
847 getSRTLabel :: FCode CLabel -- Used only by cgPanic
848 getSRTLabel = do info <- getInfoDown
849 return (cgd_srt_lbl info)
851 setSRTLabel :: CLabel -> FCode a -> FCode a
852 setSRTLabel srt_lbl code
853 = do info <- getInfoDown
854 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
857 getSRT = do info <- getInfoDown
858 return (cgd_srt info)
860 setSRT :: SRT -> FCode a -> FCode a
862 = do info <- getInfoDown
863 withInfoDown code (info { cgd_srt = srt})
865 -- ----------------------------------------------------------------------------
866 -- Get/set the current ticky counter label
868 getTickyCtrLabel :: FCode CLabel
869 getTickyCtrLabel = do
871 return (cgd_ticky info)
873 setTickyCtrLabel :: CLabel -> Code -> Code
874 setTickyCtrLabel ticky code = do
876 withInfoDown code (info {cgd_ticky = ticky})