Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / codeGen / CgMonad.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[CgMonad]{The code generation monad}
6
7 See the beginning of the top-level @CodeGen@ module, to see how this
8 monadic stuff fits into the Big Picture.
9
10 \begin{code}
11
12 {-# LANGUAGE BangPatterns #-}
13 module CgMonad (
14         Code,
15         FCode,
16
17         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
18         returnFC, fixC, fixC_, checkedAbsC, 
19         stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
20         newUnique, newUniqSupply, 
21
22         CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
23         getCgStmts', getCgStmts,
24         noCgStmts, oneCgStmt, consCgStmt,
25
26         getCmm,
27         emitDecl, emitProc, emitSimpleProc,
28
29         forkLabelledCode,
30         forkClosureBody, forkStatics, forkAlts, forkEval,
31         forkEvalHelp, forkProc, codeOnly,
32         SemiTaggingStuff, ConTagZ,
33
34         EndOfBlockInfo(..),
35         setEndOfBlockInfo, getEndOfBlockInfo,
36
37         setSRT, getSRT,
38         setSRTLabel, getSRTLabel, 
39         setTickyCtrLabel, getTickyCtrLabel,
40
41         StackUsage(..), HeapUsage(..),
42         VirtualSpOffset, VirtualHpOffset,
43         initStkUsage, initHpUsage,
44         getHpUsage,  setHpUsage,
45         heapHWM,
46
47         getModuleName,
48
49         Sequel(..),
50
51         -- ideally we wouldn't export these, but some other modules access internal state
52         getState, setState, getInfoDown, getDynFlags, getThisPackage, 
53
54         -- more localised access to monad state 
55         getStkUsage, setStkUsage,
56         getBinds, setBinds, getStaticBinds,
57
58         -- out of general friendliness, we also export ...
59         CgInfoDownwards(..), CgState(..)
60     ) where
61
62 #include "HsVersions.h"
63
64 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
65
66 import DynFlags
67 import BlockId
68 import OldCmm
69 import OldCmmUtils
70 import CLabel
71 import StgSyn (SRT)
72 import ClosureInfo( ConTagZ )
73 import SMRep
74 import Module
75 import Id
76 import VarEnv
77 import OrdList
78 import Unique
79 import UniqSupply
80 import Outputable
81
82 import Control.Monad
83 import Data.List
84
85 infixr 9 `thenC`
86 infixr 9 `thenFC`
87 \end{code}
88
89 %************************************************************************
90 %*                                                                      *
91 \subsection[CgMonad-environment]{Stuff for manipulating environments}
92 %*                                                                      *
93 %************************************************************************
94
95 This monadery has some information that it only passes {\em
96 downwards}, as well as some ``state'' which is modified as we go
97 along.
98
99 \begin{code}
100 data CgInfoDownwards    -- information only passed *downwards* by the monad
101   = MkCgInfoDown {
102         cgd_dflags  :: DynFlags,
103         cgd_mod     :: Module,          -- Module being compiled
104         cgd_statics :: CgBindings,      -- [Id -> info] : static environment
105         cgd_srt_lbl :: CLabel,          -- label of the current SRT
106         cgd_srt     :: SRT,             -- the current SRT
107         cgd_ticky   :: CLabel,          -- current destination for ticky counts
108         cgd_eob     :: EndOfBlockInfo   -- Info for stuff to do at end of basic block:
109   }
110
111 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
112 initCgInfoDown dflags mod
113   = MkCgInfoDown {      cgd_dflags  = dflags,
114                         cgd_mod     = mod,
115                         cgd_statics = emptyVarEnv,
116                         cgd_srt_lbl = error "initC: srt_lbl",
117                         cgd_srt     = error "initC: srt",
118                         cgd_ticky   = mkTopTickyCtrLabel,
119                         cgd_eob     = initEobInfo }
120
121 data CgState
122   = MkCgState {
123      cgs_stmts :: OrdList CgStmt, -- Current proc
124      cgs_tops  :: OrdList CmmDecl,
125         -- Other procedures and data blocks in this compilation unit
126         -- Both the latter two are ordered only so that we can 
127         -- reduce forward references, when it's easy to do so
128      
129      cgs_binds :: CgBindings,     -- [Id -> info] : *local* bindings environment
130                                   -- Bindings for top-level things are given in
131                                   -- the info-down part
132      
133      cgs_stk_usg :: StackUsage,
134      cgs_hp_usg  :: HeapUsage,
135      
136      cgs_uniqs :: UniqSupply }
137
138 initCgState :: UniqSupply -> CgState
139 initCgState uniqs
140   = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
141                 cgs_binds = emptyVarEnv, 
142                 cgs_stk_usg = initStkUsage, 
143                 cgs_hp_usg = initHpUsage,
144                 cgs_uniqs = uniqs }
145 \end{code}
146
147 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
148 if the expression is a @case@, what to do at the end of each
149 alternative.
150
151 \begin{code}
152 data EndOfBlockInfo
153   = EndOfBlockInfo
154         VirtualSpOffset   -- Args Sp: trim the stack to this point at a
155                           -- return; push arguments starting just
156                           -- above this point on a tail call.
157                           
158                           -- This is therefore the stk ptr as seen
159                           -- by a case alternative.
160         Sequel
161
162 initEobInfo :: EndOfBlockInfo
163 initEobInfo = EndOfBlockInfo 0 OnStack
164 \end{code}
165
166 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
167 that it must survive stack pointer adjustments at the end of the
168 block.
169
170 \begin{code}
171 data Sequel
172   = OnStack          -- Continuation is on the stack
173
174   | CaseAlts
175           CLabel     -- Jump to this; if the continuation is for a vectored
176                      -- case this might be the label of a return vector
177           SemiTaggingStuff
178           Id          -- The case binder, only used to see if it's dead
179
180 type SemiTaggingStuff
181   = Maybe                   -- Maybe we don't have any semi-tagging stuff...
182      ([(ConTagZ, CmmLit)],  -- Alternatives
183       CmmLit)               -- Default (will be a can't happen RTS label if can't happen)
184
185 -- The case branch is executed only from a successful semitagging
186 -- venture, when a case has looked at a variable, found that it's
187 -- evaluated, and wants to load up the contents and go to the join
188 -- point.
189 \end{code}
190
191 %************************************************************************
192 %*                                                                      *
193                 CgStmt type
194 %*                                                                      *
195 %************************************************************************
196
197 The CgStmts type is what the code generator outputs: it is a tree of
198 statements, including in-line labels.  The job of flattenCgStmts is to
199 turn this into a list of basic blocks, each of which ends in a jump
200 statement (either a local branch or a non-local jump).
201
202 \begin{code}
203 type CgStmts = OrdList CgStmt
204
205 data CgStmt
206   = CgStmt  CmmStmt
207   | CgLabel BlockId
208   | CgFork  BlockId CgStmts
209
210 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
211 flattenCgStmts id stmts = 
212         case flatten (fromOL stmts) of
213           ([],blocks)    -> blocks
214           (block,blocks) -> BasicBlock id block : blocks
215  where
216   flatten [] = ([],[])
217
218   -- A label at the end of a function or fork: this label must not be reachable,
219   -- but it might be referred to from another BB that also isn't reachable.
220   -- Eliminating these has to be done with a dead-code analysis.  For now,
221   -- we just make it into a well-formed block by adding a recursive jump.
222   flatten [CgLabel id]
223     = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
224
225   -- A jump/branch: throw away all the code up to the next label, because
226   -- it is unreachable.  Be careful to keep forks that we find on the way.
227   flatten (CgStmt stmt : stmts)
228     | isJump stmt
229     = case dropWhile isOrdinaryStmt stmts of
230         []                     -> ( [stmt], [] )
231         [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
232         (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
233             where (block,blocks) = flatten stmts
234         (CgFork fork_id stmts : ss) -> 
235            flatten (CgFork fork_id stmts : CgStmt stmt : ss)
236         (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
237
238   flatten (s:ss) = 
239         case s of
240           CgStmt stmt -> (stmt:block,blocks)
241           CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
242           CgFork fork_id stmts -> 
243                 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
244                 where (fork_block, fork_blocks) = flatten (fromOL stmts)
245     where (block,blocks) = flatten ss
246
247 isJump :: CmmStmt -> Bool
248 isJump (CmmJump   _ _) = True
249 isJump (CmmBranch _  ) = True
250 isJump (CmmSwitch _ _) = True
251 isJump (CmmReturn _  ) = True
252 isJump _               = False
253
254 isOrdinaryStmt :: CgStmt -> Bool
255 isOrdinaryStmt (CgStmt _) = True
256 isOrdinaryStmt _          = False
257 \end{code}
258
259 %************************************************************************
260 %*                                                                      *
261                 Stack and heap models
262 %*                                                                      *
263 %************************************************************************
264
265 \begin{code}
266 type VirtualHpOffset = WordOff  -- Both are in
267 type VirtualSpOffset = WordOff  -- units of words
268
269 data StackUsage 
270   = StackUsage {
271         virtSp :: VirtualSpOffset,
272                 -- Virtual offset of topmost allocated slot
273
274         frameSp :: VirtualSpOffset,
275                 -- Virtual offset of the return address of the enclosing frame.
276                 -- This RA describes the liveness/pointedness of
277                 -- all the stack from frameSp downwards
278                 -- INVARIANT: less than or equal to virtSp
279
280          freeStk :: [VirtualSpOffset], 
281                 -- List of free slots, in *increasing* order
282                 -- INVARIANT: all <= virtSp
283                 -- All slots <= virtSp are taken except these ones
284
285          realSp :: VirtualSpOffset,     
286                 -- Virtual offset of real stack pointer register
287
288          hwSp :: VirtualSpOffset
289   }                -- Highest value ever taken by virtSp
290
291 -- INVARIANT: The environment contains no Stable references to
292 --            stack slots below (lower offset) frameSp
293 --            It can contain volatile references to this area though.
294
295 data HeapUsage =
296   HeapUsage {
297         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
298         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
299   }
300 \end{code}
301
302 virtHp keeps track of the next location to allocate an object at. realHp keeps
303 track of what the Hp STG register actually points to. The reason these aren't
304 always the same is that we want to be able to move the realHp in one go when
305 allocating numerous objects to save having to bump it each time. virtHp we do
306 bump each time but it doesn't create corresponding inefficient machine code.
307
308 \begin{code}
309 heapHWM :: HeapUsage -> VirtualHpOffset
310 heapHWM = virtHp
311 \end{code}
312
313 Initialisation.
314
315 \begin{code}
316 initStkUsage :: StackUsage
317 initStkUsage = StackUsage {
318                         virtSp = 0,
319                         frameSp = 0,
320                         freeStk = [],
321                         realSp = 0,
322                         hwSp = 0
323                }
324                 
325 initHpUsage :: HeapUsage 
326 initHpUsage = HeapUsage {
327                 virtHp = 0,
328                 realHp = 0
329               }
330
331 -- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to
332 -- be the max of the high water marks of $arg1$ and $arg2$.
333 stateIncUsage :: CgState -> CgState -> CgState
334 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
335      = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
336             cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
337        `addCodeBlocksFrom` s2
338                 
339 stateIncUsageEval :: CgState -> CgState -> CgState
340 stateIncUsageEval s1 s2
341      = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
342        `addCodeBlocksFrom` s2
343         -- We don't max the heap high-watermark because stateIncUsageEval is
344         -- used only in forkEval, which in turn is only used for blocks of code
345         -- which do their own heap-check.
346
347 addCodeBlocksFrom :: CgState -> CgState -> CgState
348 -- Add code blocks from the latter to the former
349 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
350 s1 `addCodeBlocksFrom` s2
351   = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
352          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
353
354 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
355 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
356
357 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
358 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
359 \end{code}
360
361 %************************************************************************
362 %*                                                                      *
363                 The FCode monad
364 %*                                                                      *
365 %************************************************************************
366
367 \begin{code}
368 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
369 type Code       = FCode ()
370
371 instance Monad FCode where
372         (>>=) = thenFC
373         return = returnFC
374
375 {-# INLINE thenC #-}
376 {-# INLINE thenFC #-}
377 {-# INLINE returnFC #-}
378 \end{code}
379 The Abstract~C is not in the environment so as to improve strictness.
380
381 \begin{code}
382 initC :: DynFlags -> Module -> FCode a -> IO a
383
384 initC dflags mod (FCode code)
385   = do  { uniqs <- mkSplitUniqSupply 'c'
386         ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
387               (res, _) -> return res
388         }
389
390 returnFC :: a -> FCode a
391 returnFC val = FCode (\_ state -> (val, state))
392 \end{code}
393
394 \begin{code}
395 thenC :: Code -> FCode a -> FCode a
396 thenC (FCode m) (FCode k) = 
397         FCode (\info_down state -> let (_,new_state) = m info_down state in 
398                 k info_down new_state)
399
400 listCs :: [Code] -> Code
401 listCs [] = return ()
402 listCs (fc:fcs) = do
403         fc
404         listCs fcs
405         
406 mapCs :: (a -> Code) -> [a] -> Code
407 mapCs = mapM_
408
409 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
410 thenFC (FCode m) k = FCode (
411         \info_down state ->
412                 let 
413                         (m_result, new_state) = m info_down state
414                         (FCode kcode) = k m_result
415                 in 
416                         kcode info_down new_state
417         )
418
419 listFCs :: [FCode a] -> FCode [a]
420 listFCs = sequence
421
422 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
423 mapFCs = mapM
424
425 -- | Knot-tying combinator for @FCode@
426 fixC :: (a -> FCode a) -> FCode a
427 fixC fcode = FCode $
428         \info_down state -> 
429                 let FCode fc     = fcode v
430                     result@(v,_) = fc info_down state
431                 in result
432
433 -- | Knot-tying combinator that throws result away
434 fixC_ :: (a -> FCode a) -> FCode ()
435 fixC_ fcode = fixC fcode >> return ()
436 \end{code}
437
438 %************************************************************************
439 %*                                                                      *
440         Operators for getting and setting the state and "info_down".
441 %*                                                                      *
442 %************************************************************************
443
444 \begin{code}
445 getState :: FCode CgState
446 getState = FCode $ \_ state -> (state,state)
447
448 setState :: CgState -> FCode ()
449 setState state = FCode $ \_ _ -> ((),state)
450
451 getStkUsage :: FCode StackUsage
452 getStkUsage = do
453         state <- getState
454         return $ cgs_stk_usg state
455
456 setStkUsage :: StackUsage -> Code
457 setStkUsage new_stk_usg = do
458         state <- getState
459         setState $ state {cgs_stk_usg = new_stk_usg}
460
461 getHpUsage :: FCode HeapUsage
462 getHpUsage = do
463         state <- getState
464         return $ cgs_hp_usg state
465         
466 setHpUsage :: HeapUsage -> Code
467 setHpUsage new_hp_usg = do
468         state <- getState
469         setState $ state {cgs_hp_usg = new_hp_usg}
470
471 getBinds :: FCode CgBindings
472 getBinds = do
473         state <- getState
474         return $ cgs_binds state
475         
476 setBinds :: CgBindings -> FCode ()
477 setBinds new_binds = do
478         state <- getState
479         setState $ state {cgs_binds = new_binds}
480
481 getStaticBinds :: FCode CgBindings
482 getStaticBinds = do
483         info  <- getInfoDown
484         return (cgd_statics info)
485
486 withState :: FCode a -> CgState -> FCode (a,CgState)
487 withState (FCode fcode) newstate = FCode $ \info_down state -> 
488         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
489
490 newUniqSupply :: FCode UniqSupply
491 newUniqSupply = do
492         state <- getState
493         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
494         setState $ state { cgs_uniqs = us1 }
495         return us2
496
497 newUnique :: FCode Unique
498 newUnique = do
499         us <- newUniqSupply
500         return (uniqFromSupply us)
501
502 getInfoDown :: FCode CgInfoDownwards
503 getInfoDown = FCode $ \info_down state -> (info_down,state)
504
505 instance HasDynFlags FCode where
506     getDynFlags = liftM cgd_dflags getInfoDown
507
508 getThisPackage :: FCode PackageId
509 getThisPackage = liftM thisPackage getDynFlags
510
511 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
512 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 
513
514 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
515 doFCode (FCode fcode) info_down state = fcode info_down state
516 \end{code}
517
518
519 %************************************************************************
520 %*                                                                      *
521                 Forking
522 %*                                                                      *
523 %************************************************************************
524
525 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
526 fresh environment, except that:
527         - compilation info and statics are passed in unchanged.
528 The current environment is passed on completely unaltered, except that
529 abstract C from the fork is incorporated.
530
531 @forkProc@ takes a code and compiles it in the current environment,
532 returning the basic blocks thus constructed.  The current environment
533 is passed on completely unchanged.  It is pretty similar to
534 @getBlocks@, except that the latter does affect the environment.
535
536 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
537 from the current bindings, but which is otherwise freshly initialised.
538 The Abstract~C returned is attached to the current state, but the
539 bindings and usage information is otherwise unchanged.
540
541 \begin{code}
542 forkClosureBody :: Code -> Code
543 forkClosureBody body_code
544   = do  { info <- getInfoDown
545         ; us   <- newUniqSupply
546         ; state <- getState
547         ; let   body_info_down = info { cgd_eob = initEobInfo }
548                 ((),fork_state) = doFCode body_code body_info_down 
549                                           (initCgState us)
550         ; ASSERT( isNilOL (cgs_stmts fork_state) )
551           setState $ state `addCodeBlocksFrom` fork_state }
552         
553 forkStatics :: FCode a -> FCode a
554 forkStatics body_code
555   = do  { info  <- getInfoDown
556         ; us    <- newUniqSupply
557         ; state <- getState
558         ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
559                                        cgd_eob     = initEobInfo }
560                 (result, fork_state_out) = doFCode body_code rhs_info_down 
561                                                    (initCgState us)
562         ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
563           setState (state `addCodeBlocksFrom` fork_state_out)
564         ; return result }
565
566 forkProc :: Code -> FCode CgStmts
567 forkProc body_code
568   = do  { info_down <- getInfoDown
569         ; us    <- newUniqSupply
570         ; state <- getState
571         ; let   fork_state_in = (initCgState us) 
572                                         { cgs_binds   = cgs_binds state,
573                                           cgs_stk_usg = cgs_stk_usg state,
574                                           cgs_hp_usg  = cgs_hp_usg state }
575                         -- ToDo: is the hp usage necesary?
576                 (code_blks, fork_state_out) = doFCode (getCgStmts body_code) 
577                                                       info_down fork_state_in
578         ; setState $ state `stateIncUsageEval` fork_state_out
579         ; return code_blks }
580
581 -- Emit any code from the inner thing into the outer thing
582 -- Do not affect anything else in the outer state
583 -- Used in almost-circular code to prevent false loop dependencies
584 codeOnly :: Code -> Code
585 codeOnly body_code
586   = do  { info_down <- getInfoDown
587         ; us   <- newUniqSupply
588         ; state <- getState
589         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
590                                                    cgs_stk_usg = cgs_stk_usg state,
591                                                    cgs_hp_usg  = cgs_hp_usg state }
592                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
593         ; setState $ state `addCodeBlocksFrom` fork_state_out }
594 \end{code}
595
596 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
597 an fcode for the default case $d$, and compiles each in the current
598 environment.  The current environment is passed on unmodified, except
599 that
600         - the worst stack high-water mark is incorporated
601         - the virtual Hp is moved on to the worst virtual Hp for the branches
602
603 \begin{code}
604 forkAlts :: [FCode a] -> FCode [a]
605
606 forkAlts branch_fcodes
607   = do  { info_down <- getInfoDown
608         ; us <- newUniqSupply
609         ; state <- getState
610         ; let compile us branch 
611                 = (us2, doFCode branch info_down branch_state)
612                 where
613                   (us1,us2) = splitUniqSupply us
614                   branch_state = (initCgState us1) {
615                                         cgs_binds   = cgs_binds state,
616                                         cgs_stk_usg = cgs_stk_usg state,
617                                         cgs_hp_usg  = cgs_hp_usg state }
618
619               (_us, results) = mapAccumL compile us branch_fcodes
620               (branch_results, branch_out_states) = unzip results
621         ; setState $ foldl stateIncUsage state branch_out_states
622                 -- NB foldl.  state is the *left* argument to stateIncUsage
623         ; return branch_results }
624 \end{code}
625
626 @forkEval@ takes two blocks of code.
627
628    -  The first meddles with the environment to set it up as expected by
629       the alternatives of a @case@ which does an eval (or gc-possible primop).
630    -  The second block is the code for the alternatives.
631       (plus info for semi-tagging purposes)
632
633 @forkEval@ picks up the virtual stack pointer and returns a suitable
634 @EndOfBlockInfo@ for the caller to use, together with whatever value
635 is returned by the second block.
636
637 It uses @initEnvForAlternatives@ to initialise the environment, and
638 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
639 usage.
640
641 \begin{code}
642 forkEval :: EndOfBlockInfo              -- For the body
643          -> Code                        -- Code to set environment
644          -> FCode Sequel                -- Semi-tagging info to store
645          -> FCode EndOfBlockInfo        -- The new end of block info
646
647 forkEval body_eob_info env_code body_code
648   = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
649         ; returnFC (EndOfBlockInfo v sequel) }
650
651 forkEvalHelp :: EndOfBlockInfo  -- For the body
652              -> Code            -- Code to set environment
653              -> FCode a         -- The code to do after the eval
654              -> FCode (VirtualSpOffset, -- Sp
655                        a)               -- Result of the FCode
656         -- A disturbingly complicated function
657 forkEvalHelp body_eob_info env_code body_code
658   = do  { info_down <- getInfoDown
659         ; us   <- newUniqSupply
660         ; state <- getState
661         ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
662               ; (_, env_state) = doFCode env_code info_down_for_body 
663                                          (state {cgs_uniqs = us})
664               ; state_for_body = (initCgState (cgs_uniqs env_state)) 
665                                         { cgs_binds   = binds_for_body,
666                                           cgs_stk_usg = stk_usg_for_body }
667               ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
668               ; stk_usg_from_env = cgs_stk_usg env_state
669               ; virtSp_from_env  = virtSp stk_usg_from_env
670               ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
671                                                      hwSp   = virtSp_from_env}
672               ; (value_returned, state_at_end_return)
673                         = doFCode body_code info_down_for_body state_for_body           
674           } 
675         ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
676                  -- The code coming back should consist only of nested declarations,
677                  -- notably of the return vector!
678           setState $ state `stateIncUsageEval` state_at_end_return
679         ; return (virtSp_from_env, value_returned) }
680
681
682 -- ----------------------------------------------------------------------------
683 -- Combinators for emitting code
684
685 nopC :: Code
686 nopC = return ()
687
688 whenC :: Bool -> Code -> Code
689 whenC True  code = code
690 whenC False _    = nopC
691
692 -- Corresponds to 'emit' in new code generator with a smart constructor
693 -- from cmm/MkGraph.hs
694 stmtC :: CmmStmt -> Code
695 stmtC stmt = emitCgStmt (CgStmt stmt)
696
697 labelC :: BlockId -> Code
698 labelC id = emitCgStmt (CgLabel id)
699
700 newLabelC :: FCode BlockId
701 newLabelC = do { u <- newUnique
702                ; return $ mkBlockId u }
703
704 -- Emit code, eliminating no-ops
705 checkedAbsC :: CmmStmt -> Code
706 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
707                               else unitOL stmt)
708
709 stmtsC :: [CmmStmt] -> Code
710 stmtsC stmts = emitStmts (toOL stmts)
711
712 -- Emit code; no no-op checking
713 emitStmts :: CmmStmts -> Code
714 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
715
716 -- forkLabelledCode is for emitting a chunk of code with a label, outside
717 -- of the current instruction stream.
718 forkLabelledCode :: Code -> FCode BlockId
719 forkLabelledCode code = getCgStmts code >>= forkCgStmts
720
721 emitCgStmt :: CgStmt -> Code
722 emitCgStmt stmt
723   = do  { state <- getState
724         ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
725         }
726
727 emitDecl :: CmmDecl -> Code
728 emitDecl decl
729   = do  { state <- getState
730         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
731
732 emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
733 emitProc info lbl [] blocks
734   = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
735         ; state <- getState
736         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
737 emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
738
739 -- Emit a procedure whose body is the specified code; no info table
740 emitSimpleProc :: CLabel -> Code -> Code
741 emitSimpleProc lbl code
742   = do  { stmts <- getCgStmts code
743         ; blks <- cgStmtsToBlocks stmts
744         ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
745
746 -- Get all the CmmTops (there should be no stmts)
747 -- Return a single Cmm which may be split from other Cmms by
748 -- object splitting (at a later stage)
749 getCmm :: Code -> FCode CmmGroup
750 getCmm code 
751   = do  { state1 <- getState
752         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
753         ; setState $ state2 { cgs_tops = cgs_tops state1 } 
754         ; return (fromOL (cgs_tops state2))
755         }
756
757 -- ----------------------------------------------------------------------------
758 -- CgStmts
759
760 -- These functions deal in terms of CgStmts, which is an abstract type
761 -- representing the code in the current proc.
762
763
764 -- emit CgStmts into the current instruction stream
765 emitCgStmts :: CgStmts -> Code
766 emitCgStmts stmts
767   = do  { state <- getState
768         ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
769
770 -- emit CgStmts outside the current instruction stream, and return a label
771 forkCgStmts :: CgStmts -> FCode BlockId
772 forkCgStmts stmts
773   = do  { id <- newLabelC
774         ; emitCgStmt (CgFork id stmts)
775         ; return id
776         }
777
778 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
779 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
780 cgStmtsToBlocks stmts
781   = do  { id <- newLabelC
782         ; return (flattenCgStmts id stmts)
783         }       
784
785 -- collect the code emitted by an FCode computation
786 getCgStmts' :: FCode a -> FCode (a, CgStmts)
787 getCgStmts' fcode
788   = do  { state1 <- getState
789         ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
790         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
791         ; return (a, cgs_stmts state2) }
792
793 getCgStmts :: FCode a -> FCode CgStmts
794 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
795
796 -- Simple ways to construct CgStmts:
797 noCgStmts :: CgStmts
798 noCgStmts = nilOL
799
800 oneCgStmt :: CmmStmt -> CgStmts
801 oneCgStmt stmt = unitOL (CgStmt stmt)
802
803 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
804 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
805
806 -- ----------------------------------------------------------------------------
807 -- Get the current module name
808
809 getModuleName :: FCode Module
810 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
811
812 -- ----------------------------------------------------------------------------
813 -- Get/set the end-of-block info
814
815 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
816 setEndOfBlockInfo eob_info code = do
817         info  <- getInfoDown
818         withInfoDown code (info {cgd_eob = eob_info})
819
820 getEndOfBlockInfo :: FCode EndOfBlockInfo
821 getEndOfBlockInfo = do
822         info <- getInfoDown
823         return (cgd_eob info)
824
825 -- ----------------------------------------------------------------------------
826 -- Get/set the current SRT label
827
828 -- There is just one SRT for each top level binding; all the nested
829 -- bindings use sub-sections of this SRT.  The label is passed down to
830 -- the nested bindings via the monad.
831
832 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
833 getSRTLabel = do info  <- getInfoDown
834                  return (cgd_srt_lbl info)
835
836 setSRTLabel :: CLabel -> FCode a -> FCode a
837 setSRTLabel srt_lbl code
838   = do  info <- getInfoDown
839         withInfoDown code (info { cgd_srt_lbl = srt_lbl})
840
841 getSRT :: FCode SRT
842 getSRT = do info <- getInfoDown
843             return (cgd_srt info)
844
845 setSRT :: SRT -> FCode a -> FCode a
846 setSRT srt code
847   = do info <- getInfoDown
848        withInfoDown code (info { cgd_srt = srt})
849
850 -- ----------------------------------------------------------------------------
851 -- Get/set the current ticky counter label
852
853 getTickyCtrLabel :: FCode CLabel
854 getTickyCtrLabel = do
855         info <- getInfoDown
856         return (cgd_ticky info)
857
858 setTickyCtrLabel :: CLabel -> Code -> Code
859 setTickyCtrLabel ticky code = do
860         info <- getInfoDown
861         withInfoDown code (info {cgd_ticky = ticky})
862 \end{code}