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 )
91 infixr 9 `thenC` -- Right-associative!
95 %************************************************************************
97 \subsection[CgMonad-environment]{Stuff for manipulating environments}
99 %************************************************************************
101 This monadery has some information that it only passes {\em
102 downwards}, as well as some ``state'' which is modified as we go
106 data CgInfoDownwards -- information only passed *downwards* by the monad
108 cgd_dflags :: DynFlags,
109 cgd_mod :: Module, -- Module being compiled
110 cgd_statics :: CgBindings, -- [Id -> info] : static environment
111 cgd_srt_lbl :: CLabel, -- label of the current SRT
112 cgd_srt :: SRT, -- the current SRT
113 cgd_ticky :: CLabel, -- current destination for ticky counts
114 cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
117 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
118 initCgInfoDown dflags mod
119 = MkCgInfoDown { cgd_dflags = dflags,
121 cgd_statics = emptyVarEnv,
122 cgd_srt_lbl = error "initC: srt_lbl",
123 cgd_srt = error "initC: srt",
124 cgd_ticky = mkTopTickyCtrLabel,
125 cgd_eob = initEobInfo }
129 cgs_stmts :: OrdList CgStmt, -- Current proc
130 cgs_tops :: OrdList CmmTop,
131 -- Other procedures and data blocks in this compilation unit
132 -- Both the latter two are ordered only so that we can
133 -- reduce forward references, when it's easy to do so
135 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
136 -- Bindings for top-level things are given in
137 -- the info-down part
139 cgs_stk_usg :: StackUsage,
140 cgs_hp_usg :: HeapUsage,
142 cgs_uniqs :: UniqSupply }
144 initCgState :: UniqSupply -> CgState
146 = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
147 cgs_binds = emptyVarEnv,
148 cgs_stk_usg = initStkUsage,
149 cgs_hp_usg = initHpUsage,
153 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
154 if the expression is a @case@, what to do at the end of each
160 VirtualSpOffset -- Args Sp: trim the stack to this point at a
161 -- return; push arguments starting just
162 -- above this point on a tail call.
164 -- This is therefore the stk ptr as seen
165 -- by a case alternative.
168 initEobInfo = EndOfBlockInfo 0 OnStack
171 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
172 that it must survive stack pointer adjustments at the end of the
177 = OnStack -- Continuation is on the stack
178 | UpdateCode -- Continuation is update
181 CLabel -- Jump to this; if the continuation is for a vectored
182 -- case this might be the label of a return vector
184 Id -- The case binder, only used to see if it's dead
186 type SemiTaggingStuff
187 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
188 ([(ConTagZ, CmmLit)], -- Alternatives
189 CmmLit) -- Default (will be a can't happen RTS label if can't happen)
191 type ConTagZ = Int -- A *zero-indexed* contructor tag
193 -- The case branch is executed only from a successful semitagging
194 -- venture, when a case has looked at a variable, found that it's
195 -- evaluated, and wants to load up the contents and go to the join
199 %************************************************************************
203 %************************************************************************
205 The CgStmts type is what the code generator outputs: it is a tree of
206 statements, including in-line labels. The job of flattenCgStmts is to
207 turn this into a list of basic blocks, each of which ends in a jump
208 statement (either a local branch or a non-local jump).
211 type CgStmts = OrdList CgStmt
216 | CgFork BlockId CgStmts
218 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
219 flattenCgStmts id stmts =
220 case flatten (fromOL stmts) of
221 ([],blocks) -> blocks
222 (block,blocks) -> BasicBlock id block : blocks
226 -- A label at the end of a function or fork: this label must not be reachable,
227 -- but it might be referred to from another BB that also isn't reachable.
228 -- Eliminating these has to be done with a dead-code analysis. For now,
229 -- we just make it into a well-formed block by adding a recursive jump.
231 = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
233 -- A jump/branch: throw away all the code up to the next label, because
234 -- it is unreachable. Be careful to keep forks that we find on the way.
235 flatten (CgStmt stmt : stmts)
237 = case dropWhile isOrdinaryStmt stmts of
239 [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]])
240 (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks )
241 where (block,blocks) = flatten stmts
242 (CgFork fork_id stmts : ss) ->
243 flatten (CgFork fork_id stmts : CgStmt stmt : ss)
244 (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
248 CgStmt stmt -> (stmt:block,blocks)
249 CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks)
250 CgFork fork_id stmts ->
251 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
252 where (fork_block, fork_blocks) = flatten (fromOL stmts)
253 where (block,blocks) = flatten ss
255 isJump (CmmJump _ _) = True
256 isJump (CmmBranch _) = True
257 isJump (CmmSwitch _ _) = True
258 isJump (CmmReturn _) = True
261 isOrdinaryStmt (CgStmt _) = True
262 isOrdinaryStmt _ = False
265 %************************************************************************
267 Stack and heap models
269 %************************************************************************
272 type VirtualHpOffset = WordOff -- Both are in
273 type VirtualSpOffset = WordOff -- units of words
277 virtSp :: VirtualSpOffset,
278 -- Virtual offset of topmost allocated slot
280 frameSp :: VirtualSpOffset,
281 -- Virtual offset of the return address of the enclosing frame.
282 -- This RA describes the liveness/pointedness of
283 -- all the stack from frameSp downwards
284 -- INVARIANT: less than or equal to virtSp
286 freeStk :: [VirtualSpOffset],
287 -- List of free slots, in *increasing* order
288 -- INVARIANT: all <= virtSp
289 -- All slots <= virtSp are taken except these ones
291 realSp :: VirtualSpOffset,
292 -- Virtual offset of real stack pointer register
294 hwSp :: VirtualSpOffset
295 } -- Highest value ever taken by virtSp
297 -- INVARIANT: The environment contains no Stable references to
298 -- stack slots below (lower offset) frameSp
299 -- It can contain volatile references to this area though.
303 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
304 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
308 The heap high water mark is the larger of virtHp and hwHp. The latter is
309 only records the high water marks of forked-off branches, so to find the
310 heap high water mark you have to take the max of virtHp and hwHp. Remember,
311 virtHp never retreats!
313 Note Jan 04: ok, so why do we only look at the virtual Hp??
316 heapHWM :: HeapUsage -> VirtualHpOffset
323 initStkUsage :: StackUsage
324 initStkUsage = StackUsage {
332 initHpUsage :: HeapUsage
333 initHpUsage = HeapUsage {
339 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
340 marks found in $e_2$.
343 stateIncUsage :: CgState -> CgState -> CgState
344 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
345 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg,
346 cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg }
347 `addCodeBlocksFrom` s2
349 stateIncUsageEval :: CgState -> CgState -> CgState
350 stateIncUsageEval s1 s2
351 = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
352 `addCodeBlocksFrom` s2
353 -- We don't max the heap high-watermark because stateIncUsageEval is
354 -- used only in forkEval, which in turn is only used for blocks of code
355 -- which do their own heap-check.
357 addCodeBlocksFrom :: CgState -> CgState -> CgState
358 -- Add code blocks from the latter to the former
359 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
360 s1 `addCodeBlocksFrom` s2
361 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
362 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
364 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
365 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
367 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
368 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
371 %************************************************************************
375 %************************************************************************
378 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
381 instance Monad FCode where
386 {-# INLINE thenFC #-}
387 {-# INLINE returnFC #-}
389 The Abstract~C is not in the environment so as to improve strictness.
392 initC :: DynFlags -> Module -> FCode a -> IO a
394 initC dflags mod (FCode code)
395 = do { uniqs <- mkSplitUniqSupply 'c'
396 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
397 (res, _) -> return res
400 returnFC :: a -> FCode a
401 returnFC val = FCode (\info_down state -> (val, state))
405 thenC :: Code -> FCode a -> FCode a
406 thenC (FCode m) (FCode k) =
407 FCode (\info_down state -> let (_,new_state) = m info_down state in
408 k info_down new_state)
410 listCs :: [Code] -> Code
411 listCs [] = return ()
416 mapCs :: (a -> Code) -> [a] -> Code
421 thenFC :: FCode a -> (a -> FCode c) -> FCode c
422 thenFC (FCode m) k = FCode (
425 (m_result, new_state) = m info_down state
426 (FCode kcode) = k m_result
428 kcode info_down new_state
431 listFCs :: [FCode a] -> FCode [a]
434 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
438 And the knot-tying combinator:
440 fixC :: (a -> FCode a) -> FCode a
445 result@(v,_) = fc info_down state
452 %************************************************************************
454 Operators for getting and setting the state and "info_down".
457 %************************************************************************
460 getState :: FCode CgState
461 getState = FCode $ \info_down state -> (state,state)
463 setState :: CgState -> FCode ()
464 setState state = FCode $ \info_down _ -> ((),state)
466 getStkUsage :: FCode StackUsage
469 return $ cgs_stk_usg state
471 setStkUsage :: StackUsage -> Code
472 setStkUsage new_stk_usg = do
474 setState $ state {cgs_stk_usg = new_stk_usg}
476 getHpUsage :: FCode HeapUsage
479 return $ cgs_hp_usg state
481 setHpUsage :: HeapUsage -> Code
482 setHpUsage new_hp_usg = do
484 setState $ state {cgs_hp_usg = new_hp_usg}
486 getBinds :: FCode CgBindings
489 return $ cgs_binds state
491 setBinds :: CgBindings -> FCode ()
492 setBinds new_binds = do
494 setState $ state {cgs_binds = new_binds}
496 getStaticBinds :: FCode CgBindings
499 return (cgd_statics info)
501 withState :: FCode a -> CgState -> FCode (a,CgState)
502 withState (FCode fcode) newstate = FCode $ \info_down state ->
503 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
505 newUniqSupply :: FCode UniqSupply
508 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
509 setState $ state { cgs_uniqs = us1 }
512 newUnique :: FCode Unique
515 return (uniqFromSupply us)
518 getInfoDown :: FCode CgInfoDownwards
519 getInfoDown = FCode $ \info_down state -> (info_down,state)
521 getDynFlags :: FCode DynFlags
522 getDynFlags = liftM cgd_dflags getInfoDown
524 getThisPackage :: FCode PackageId
525 getThisPackage = liftM thisPackage getDynFlags
527 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
528 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
530 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
531 doFCode (FCode fcode) info_down state = fcode info_down state
535 %************************************************************************
539 %************************************************************************
541 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
542 fresh environment, except that:
543 - compilation info and statics are passed in unchanged.
544 The current environment is passed on completely unaltered, except that
545 abstract C from the fork is incorporated.
547 @forkProc@ takes a code and compiles it in the current environment,
548 returning the basic blocks thus constructed. The current environment
549 is passed on completely unchanged. It is pretty similar to
550 @getBlocks@, except that the latter does affect the environment.
552 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
553 from the current bindings, but which is otherwise freshly initialised.
554 The Abstract~C returned is attached to the current state, but the
555 bindings and usage information is otherwise unchanged.
558 forkClosureBody :: Code -> Code
559 forkClosureBody body_code
560 = do { info <- getInfoDown
561 ; us <- newUniqSupply
563 ; let body_info_down = info { cgd_eob = initEobInfo }
564 ((),fork_state) = doFCode body_code body_info_down
566 ; ASSERT( isNilOL (cgs_stmts fork_state) )
567 setState $ state `addCodeBlocksFrom` fork_state }
569 forkStatics :: FCode a -> FCode a
570 forkStatics body_code
571 = do { info <- getInfoDown
572 ; us <- newUniqSupply
574 ; let rhs_info_down = info { cgd_statics = cgs_binds state,
575 cgd_eob = initEobInfo }
576 (result, fork_state_out) = doFCode body_code rhs_info_down
578 ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
579 setState (state `addCodeBlocksFrom` fork_state_out)
582 forkProc :: Code -> FCode CgStmts
584 = do { info_down <- getInfoDown
585 ; us <- newUniqSupply
587 ; let fork_state_in = (initCgState us)
588 { cgs_binds = cgs_binds state,
589 cgs_stk_usg = cgs_stk_usg state,
590 cgs_hp_usg = cgs_hp_usg state }
591 -- ToDo: is the hp usage necesary?
592 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
593 info_down fork_state_in
594 ; setState $ state `stateIncUsageEval` fork_state_out
597 codeOnly :: Code -> Code
598 -- Emit any code from the inner thing into the outer thing
599 -- Do not affect anything else in the outer state
600 -- Used in almost-circular code to prevent false loop dependencies
602 = do { info_down <- getInfoDown
603 ; us <- newUniqSupply
605 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
606 cgs_stk_usg = cgs_stk_usg state,
607 cgs_hp_usg = cgs_hp_usg state }
608 ((), fork_state_out) = doFCode body_code info_down fork_state_in
609 ; setState $ state `addCodeBlocksFrom` fork_state_out }
612 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
613 an fcode for the default case $d$, and compiles each in the current
614 environment. The current environment is passed on unmodified, except
616 - the worst stack high-water mark is incorporated
617 - the virtual Hp is moved on to the worst virtual Hp for the branches
620 forkAlts :: [FCode a] -> FCode [a]
622 forkAlts branch_fcodes
623 = do { info_down <- getInfoDown
624 ; us <- newUniqSupply
626 ; let compile us branch
627 = (us2, doFCode branch info_down branch_state)
629 (us1,us2) = splitUniqSupply us
630 branch_state = (initCgState us1) {
631 cgs_binds = cgs_binds state,
632 cgs_stk_usg = cgs_stk_usg state,
633 cgs_hp_usg = cgs_hp_usg state }
635 (_us, results) = mapAccumL compile us branch_fcodes
636 (branch_results, branch_out_states) = unzip results
637 ; setState $ foldl stateIncUsage state branch_out_states
638 -- NB foldl. state is the *left* argument to stateIncUsage
639 ; return branch_results }
642 @forkEval@ takes two blocks of code.
644 - The first meddles with the environment to set it up as expected by
645 the alternatives of a @case@ which does an eval (or gc-possible primop).
646 - The second block is the code for the alternatives.
647 (plus info for semi-tagging purposes)
649 @forkEval@ picks up the virtual stack pointer and returns a suitable
650 @EndOfBlockInfo@ for the caller to use, together with whatever value
651 is returned by the second block.
653 It uses @initEnvForAlternatives@ to initialise the environment, and
654 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
658 forkEval :: EndOfBlockInfo -- For the body
659 -> Code -- Code to set environment
660 -> FCode Sequel -- Semi-tagging info to store
661 -> FCode EndOfBlockInfo -- The new end of block info
663 forkEval body_eob_info env_code body_code
664 = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
665 ; returnFC (EndOfBlockInfo v sequel) }
667 forkEvalHelp :: EndOfBlockInfo -- For the body
668 -> Code -- Code to set environment
669 -> FCode a -- The code to do after the eval
670 -> FCode (VirtualSpOffset, -- Sp
671 a) -- Result of the FCode
672 -- A disturbingly complicated function
673 forkEvalHelp body_eob_info env_code body_code
674 = do { info_down <- getInfoDown
675 ; us <- newUniqSupply
677 ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
678 ; (_, env_state) = doFCode env_code info_down_for_body
679 (state {cgs_uniqs = us})
680 ; state_for_body = (initCgState (cgs_uniqs env_state))
681 { cgs_binds = binds_for_body,
682 cgs_stk_usg = stk_usg_for_body }
683 ; binds_for_body = nukeVolatileBinds (cgs_binds env_state)
684 ; stk_usg_from_env = cgs_stk_usg env_state
685 ; virtSp_from_env = virtSp stk_usg_from_env
686 ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
687 hwSp = virtSp_from_env}
688 ; (value_returned, state_at_end_return)
689 = doFCode body_code info_down_for_body state_for_body
691 ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
692 -- The code coming back should consist only of nested declarations,
693 -- notably of the return vector!
694 setState $ state `stateIncUsageEval` state_at_end_return
695 ; return (virtSp_from_env, value_returned) }
698 -- ----------------------------------------------------------------------------
699 -- Combinators for emitting code
704 whenC :: Bool -> Code -> Code
705 whenC True code = code
706 whenC False code = nopC
708 stmtC :: CmmStmt -> Code
709 stmtC stmt = emitCgStmt (CgStmt stmt)
711 labelC :: BlockId -> Code
712 labelC id = emitCgStmt (CgLabel id)
714 newLabelC :: FCode BlockId
715 newLabelC = do { u <- newUnique
716 ; return $ BlockId u }
718 checkedAbsC :: CmmStmt -> Code
719 -- Emit code, eliminating no-ops
720 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
723 stmtsC :: [CmmStmt] -> Code
724 stmtsC stmts = emitStmts (toOL stmts)
726 -- Emit code; no no-op checking
727 emitStmts :: CmmStmts -> Code
728 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
730 -- forkLabelledCode is for emitting a chunk of code with a label, outside
731 -- of the current instruction stream.
732 forkLabelledCode :: Code -> FCode BlockId
733 forkLabelledCode code = getCgStmts code >>= forkCgStmts
735 emitCgStmt :: CgStmt -> Code
737 = do { state <- getState
738 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
741 emitData :: Section -> [CmmStatic] -> Code
743 = do { state <- getState
744 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
746 data_block = CmmData sect lits
748 emitProc :: CmmInfo -> CLabel -> CmmFormalsWithoutKinds -> [CmmBasicBlock] -> Code
749 emitProc info lbl args blocks
750 = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
752 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
754 emitSimpleProc :: CLabel -> Code -> Code
755 -- Emit a procedure whose body is the specified code; no info table
756 emitSimpleProc lbl code
757 = do { stmts <- getCgStmts code
758 ; blks <- cgStmtsToBlocks stmts
759 ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
761 getCmm :: Code -> FCode Cmm
762 -- Get all the CmmTops (there should be no stmts)
763 -- Return a single Cmm which may be split from other Cmms by
764 -- object splitting (at a later stage)
766 = do { state1 <- getState
767 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
768 ; setState $ state2 { cgs_tops = cgs_tops state1 }
769 ; return (Cmm (fromOL (cgs_tops state2))) }
771 -- ----------------------------------------------------------------------------
774 -- These functions deal in terms of CgStmts, which is an abstract type
775 -- representing the code in the current proc.
778 -- emit CgStmts into the current instruction stream
779 emitCgStmts :: CgStmts -> Code
781 = do { state <- getState
782 ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
784 -- emit CgStmts outside the current instruction stream, and return a label
785 forkCgStmts :: CgStmts -> FCode BlockId
787 = do { id <- newLabelC
788 ; emitCgStmt (CgFork id stmts)
792 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
793 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
794 cgStmtsToBlocks stmts
795 = do { id <- newLabelC
796 ; return (flattenCgStmts id stmts)
799 -- collect the code emitted by an FCode computation
800 getCgStmts' :: FCode a -> FCode (a, CgStmts)
802 = do { state1 <- getState
803 ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
804 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
805 ; return (a, cgs_stmts state2) }
807 getCgStmts :: FCode a -> FCode CgStmts
808 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
810 -- Simple ways to construct CgStmts:
814 oneCgStmt :: CmmStmt -> CgStmts
815 oneCgStmt stmt = unitOL (CgStmt stmt)
817 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
818 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
820 -- ----------------------------------------------------------------------------
821 -- Get the current module name
823 getModuleName :: FCode Module
824 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
826 -- ----------------------------------------------------------------------------
827 -- Get/set the end-of-block info
829 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
830 setEndOfBlockInfo eob_info code = do
832 withInfoDown code (info {cgd_eob = eob_info})
834 getEndOfBlockInfo :: FCode EndOfBlockInfo
835 getEndOfBlockInfo = do
837 return (cgd_eob info)
839 -- ----------------------------------------------------------------------------
840 -- Get/set the current SRT label
842 -- There is just one SRT for each top level binding; all the nested
843 -- bindings use sub-sections of this SRT. The label is passed down to
844 -- the nested bindings via the monad.
846 getSRTLabel :: FCode CLabel -- Used only by cgPanic
847 getSRTLabel = do info <- getInfoDown
848 return (cgd_srt_lbl info)
850 setSRTLabel :: CLabel -> FCode a -> FCode a
851 setSRTLabel srt_lbl code
852 = do info <- getInfoDown
853 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
856 getSRT = do info <- getInfoDown
857 return (cgd_srt info)
859 setSRT :: SRT -> FCode a -> FCode a
861 = do info <- getInfoDown
862 withInfoDown code (info { cgd_srt = srt})
864 -- ----------------------------------------------------------------------------
865 -- Get/set the current ticky counter label
867 getTickyCtrLabel :: FCode CLabel
868 getTickyCtrLabel = do
870 return (cgd_ticky info)
872 setTickyCtrLabel :: CLabel -> Code -> Code
873 setTickyCtrLabel ticky code = do
875 withInfoDown code (info {cgd_ticky = ticky})