New stack layout algorithm
[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, runC, 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 :: IO CgState
383 initC  = do { uniqs <- mkSplitUniqSupply 'c'
384             ; return (initCgState uniqs) }
385
386 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
387 runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
388
389 returnFC :: a -> FCode a
390 returnFC val = FCode (\_ state -> (val, state))
391 \end{code}
392
393 \begin{code}
394 thenC :: Code -> FCode a -> FCode a
395 thenC (FCode m) (FCode k) = 
396         FCode (\info_down state -> let (_,new_state) = m info_down state in 
397                 k info_down new_state)
398
399 listCs :: [Code] -> Code
400 listCs [] = return ()
401 listCs (fc:fcs) = do
402         fc
403         listCs fcs
404         
405 mapCs :: (a -> Code) -> [a] -> Code
406 mapCs = mapM_
407
408 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
409 thenFC (FCode m) k = FCode (
410         \info_down state ->
411                 let 
412                         (m_result, new_state) = m info_down state
413                         (FCode kcode) = k m_result
414                 in 
415                         kcode info_down new_state
416         )
417
418 listFCs :: [FCode a] -> FCode [a]
419 listFCs = sequence
420
421 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
422 mapFCs = mapM
423
424 -- | Knot-tying combinator for @FCode@
425 fixC :: (a -> FCode a) -> FCode a
426 fixC fcode = FCode $
427         \info_down state -> 
428                 let FCode fc     = fcode v
429                     result@(v,_) = fc info_down state
430                 in result
431
432 -- | Knot-tying combinator that throws result away
433 fixC_ :: (a -> FCode a) -> FCode ()
434 fixC_ fcode = fixC fcode >> return ()
435 \end{code}
436
437 %************************************************************************
438 %*                                                                      *
439         Operators for getting and setting the state and "info_down".
440 %*                                                                      *
441 %************************************************************************
442
443 \begin{code}
444 getState :: FCode CgState
445 getState = FCode $ \_ state -> (state,state)
446
447 setState :: CgState -> FCode ()
448 setState state = FCode $ \_ _ -> ((),state)
449
450 getStkUsage :: FCode StackUsage
451 getStkUsage = do
452         state <- getState
453         return $ cgs_stk_usg state
454
455 setStkUsage :: StackUsage -> Code
456 setStkUsage new_stk_usg = do
457         state <- getState
458         setState $ state {cgs_stk_usg = new_stk_usg}
459
460 getHpUsage :: FCode HeapUsage
461 getHpUsage = do
462         state <- getState
463         return $ cgs_hp_usg state
464         
465 setHpUsage :: HeapUsage -> Code
466 setHpUsage new_hp_usg = do
467         state <- getState
468         setState $ state {cgs_hp_usg = new_hp_usg}
469
470 getBinds :: FCode CgBindings
471 getBinds = do
472         state <- getState
473         return $ cgs_binds state
474         
475 setBinds :: CgBindings -> FCode ()
476 setBinds new_binds = do
477         state <- getState
478         setState $ state {cgs_binds = new_binds}
479
480 getStaticBinds :: FCode CgBindings
481 getStaticBinds = do
482         info  <- getInfoDown
483         return (cgd_statics info)
484
485 withState :: FCode a -> CgState -> FCode (a,CgState)
486 withState (FCode fcode) newstate = FCode $ \info_down state -> 
487         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
488
489 newUniqSupply :: FCode UniqSupply
490 newUniqSupply = do
491         state <- getState
492         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
493         setState $ state { cgs_uniqs = us1 }
494         return us2
495
496 newUnique :: FCode Unique
497 newUnique = do
498         us <- newUniqSupply
499         return (uniqFromSupply us)
500
501 getInfoDown :: FCode CgInfoDownwards
502 getInfoDown = FCode $ \info_down state -> (info_down,state)
503
504 getDynFlags :: FCode DynFlags
505 getDynFlags = liftM cgd_dflags getInfoDown
506
507 getThisPackage :: FCode PackageId
508 getThisPackage = liftM thisPackage getDynFlags
509
510 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
511 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 
512
513 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
514 doFCode (FCode fcode) info_down state = fcode info_down state
515 \end{code}
516
517
518 %************************************************************************
519 %*                                                                      *
520                 Forking
521 %*                                                                      *
522 %************************************************************************
523
524 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
525 fresh environment, except that:
526         - compilation info and statics are passed in unchanged.
527 The current environment is passed on completely unaltered, except that
528 abstract C from the fork is incorporated.
529
530 @forkProc@ takes a code and compiles it in the current environment,
531 returning the basic blocks thus constructed.  The current environment
532 is passed on completely unchanged.  It is pretty similar to
533 @getBlocks@, except that the latter does affect the environment.
534
535 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
536 from the current bindings, but which is otherwise freshly initialised.
537 The Abstract~C returned is attached to the current state, but the
538 bindings and usage information is otherwise unchanged.
539
540 \begin{code}
541 forkClosureBody :: Code -> Code
542 forkClosureBody body_code
543   = do  { info <- getInfoDown
544         ; us   <- newUniqSupply
545         ; state <- getState
546         ; let   body_info_down = info { cgd_eob = initEobInfo }
547                 ((),fork_state) = doFCode body_code body_info_down 
548                                           (initCgState us)
549         ; ASSERT( isNilOL (cgs_stmts fork_state) )
550           setState $ state `addCodeBlocksFrom` fork_state }
551         
552 forkStatics :: FCode a -> FCode a
553 forkStatics body_code
554   = do  { info  <- getInfoDown
555         ; us    <- newUniqSupply
556         ; state <- getState
557         ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
558                                        cgd_eob     = initEobInfo }
559                 (result, fork_state_out) = doFCode body_code rhs_info_down 
560                                                    (initCgState us)
561         ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
562           setState (state `addCodeBlocksFrom` fork_state_out)
563         ; return result }
564
565 forkProc :: Code -> FCode CgStmts
566 forkProc body_code
567   = do  { info_down <- getInfoDown
568         ; us    <- newUniqSupply
569         ; state <- getState
570         ; let   fork_state_in = (initCgState us) 
571                                         { cgs_binds   = cgs_binds state,
572                                           cgs_stk_usg = cgs_stk_usg state,
573                                           cgs_hp_usg  = cgs_hp_usg state }
574                         -- ToDo: is the hp usage necesary?
575                 (code_blks, fork_state_out) = doFCode (getCgStmts body_code) 
576                                                       info_down fork_state_in
577         ; setState $ state `stateIncUsageEval` fork_state_out
578         ; return code_blks }
579
580 -- Emit any code from the inner thing into the outer thing
581 -- Do not affect anything else in the outer state
582 -- Used in almost-circular code to prevent false loop dependencies
583 codeOnly :: Code -> Code
584 codeOnly body_code
585   = do  { info_down <- getInfoDown
586         ; us   <- newUniqSupply
587         ; state <- getState
588         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
589                                                    cgs_stk_usg = cgs_stk_usg state,
590                                                    cgs_hp_usg  = cgs_hp_usg state }
591                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
592         ; setState $ state `addCodeBlocksFrom` fork_state_out }
593 \end{code}
594
595 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
596 an fcode for the default case $d$, and compiles each in the current
597 environment.  The current environment is passed on unmodified, except
598 that
599         - the worst stack high-water mark is incorporated
600         - the virtual Hp is moved on to the worst virtual Hp for the branches
601
602 \begin{code}
603 forkAlts :: [FCode a] -> FCode [a]
604
605 forkAlts branch_fcodes
606   = do  { info_down <- getInfoDown
607         ; us <- newUniqSupply
608         ; state <- getState
609         ; let compile us branch 
610                 = (us2, doFCode branch info_down branch_state)
611                 where
612                   (us1,us2) = splitUniqSupply us
613                   branch_state = (initCgState us1) {
614                                         cgs_binds   = cgs_binds state,
615                                         cgs_stk_usg = cgs_stk_usg state,
616                                         cgs_hp_usg  = cgs_hp_usg state }
617
618               (_us, results) = mapAccumL compile us branch_fcodes
619               (branch_results, branch_out_states) = unzip results
620         ; setState $ foldl stateIncUsage state branch_out_states
621                 -- NB foldl.  state is the *left* argument to stateIncUsage
622         ; return branch_results }
623 \end{code}
624
625 @forkEval@ takes two blocks of code.
626
627    -  The first meddles with the environment to set it up as expected by
628       the alternatives of a @case@ which does an eval (or gc-possible primop).
629    -  The second block is the code for the alternatives.
630       (plus info for semi-tagging purposes)
631
632 @forkEval@ picks up the virtual stack pointer and returns a suitable
633 @EndOfBlockInfo@ for the caller to use, together with whatever value
634 is returned by the second block.
635
636 It uses @initEnvForAlternatives@ to initialise the environment, and
637 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
638 usage.
639
640 \begin{code}
641 forkEval :: EndOfBlockInfo              -- For the body
642          -> Code                        -- Code to set environment
643          -> FCode Sequel                -- Semi-tagging info to store
644          -> FCode EndOfBlockInfo        -- The new end of block info
645
646 forkEval body_eob_info env_code body_code
647   = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
648         ; returnFC (EndOfBlockInfo v sequel) }
649
650 forkEvalHelp :: EndOfBlockInfo  -- For the body
651              -> Code            -- Code to set environment
652              -> FCode a         -- The code to do after the eval
653              -> FCode (VirtualSpOffset, -- Sp
654                        a)               -- Result of the FCode
655         -- A disturbingly complicated function
656 forkEvalHelp body_eob_info env_code body_code
657   = do  { info_down <- getInfoDown
658         ; us   <- newUniqSupply
659         ; state <- getState
660         ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
661               ; (_, env_state) = doFCode env_code info_down_for_body 
662                                          (state {cgs_uniqs = us})
663               ; state_for_body = (initCgState (cgs_uniqs env_state)) 
664                                         { cgs_binds   = binds_for_body,
665                                           cgs_stk_usg = stk_usg_for_body }
666               ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
667               ; stk_usg_from_env = cgs_stk_usg env_state
668               ; virtSp_from_env  = virtSp stk_usg_from_env
669               ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
670                                                      hwSp   = virtSp_from_env}
671               ; (value_returned, state_at_end_return)
672                         = doFCode body_code info_down_for_body state_for_body           
673           } 
674         ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
675                  -- The code coming back should consist only of nested declarations,
676                  -- notably of the return vector!
677           setState $ state `stateIncUsageEval` state_at_end_return
678         ; return (virtSp_from_env, value_returned) }
679
680
681 -- ----------------------------------------------------------------------------
682 -- Combinators for emitting code
683
684 nopC :: Code
685 nopC = return ()
686
687 whenC :: Bool -> Code -> Code
688 whenC True  code = code
689 whenC False _    = nopC
690
691 -- Corresponds to 'emit' in new code generator with a smart constructor
692 -- from cmm/MkGraph.hs
693 stmtC :: CmmStmt -> Code
694 stmtC stmt = emitCgStmt (CgStmt stmt)
695
696 labelC :: BlockId -> Code
697 labelC id = emitCgStmt (CgLabel id)
698
699 newLabelC :: FCode BlockId
700 newLabelC = do { u <- newUnique
701                ; return $ mkBlockId u }
702
703 -- Emit code, eliminating no-ops
704 checkedAbsC :: CmmStmt -> Code
705 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
706                               else unitOL stmt)
707
708 stmtsC :: [CmmStmt] -> Code
709 stmtsC stmts = emitStmts (toOL stmts)
710
711 -- Emit code; no no-op checking
712 emitStmts :: CmmStmts -> Code
713 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
714
715 -- forkLabelledCode is for emitting a chunk of code with a label, outside
716 -- of the current instruction stream.
717 forkLabelledCode :: Code -> FCode BlockId
718 forkLabelledCode code = getCgStmts code >>= forkCgStmts
719
720 emitCgStmt :: CgStmt -> Code
721 emitCgStmt stmt
722   = do  { state <- getState
723         ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
724         }
725
726 emitDecl :: CmmDecl -> Code
727 emitDecl decl
728   = do  { state <- getState
729         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
730
731 emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
732 emitProc info lbl [] blocks
733   = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
734         ; state <- getState
735         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
736 emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
737
738 -- Emit a procedure whose body is the specified code; no info table
739 emitSimpleProc :: CLabel -> Code -> Code
740 emitSimpleProc lbl code
741   = do  { stmts <- getCgStmts code
742         ; blks <- cgStmtsToBlocks stmts
743         ; emitProc CmmNonInfoTable lbl [] blks }
744
745 -- Get all the CmmTops (there should be no stmts)
746 -- Return a single Cmm which may be split from other Cmms by
747 -- object splitting (at a later stage)
748 getCmm :: Code -> FCode CmmGroup
749 getCmm code 
750   = do  { state1 <- getState
751         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
752         ; setState $ state2 { cgs_tops = cgs_tops state1 } 
753         ; return (fromOL (cgs_tops state2))
754         }
755
756 -- ----------------------------------------------------------------------------
757 -- CgStmts
758
759 -- These functions deal in terms of CgStmts, which is an abstract type
760 -- representing the code in the current proc.
761
762
763 -- emit CgStmts into the current instruction stream
764 emitCgStmts :: CgStmts -> Code
765 emitCgStmts stmts
766   = do  { state <- getState
767         ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
768
769 -- emit CgStmts outside the current instruction stream, and return a label
770 forkCgStmts :: CgStmts -> FCode BlockId
771 forkCgStmts stmts
772   = do  { id <- newLabelC
773         ; emitCgStmt (CgFork id stmts)
774         ; return id
775         }
776
777 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
778 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
779 cgStmtsToBlocks stmts
780   = do  { id <- newLabelC
781         ; return (flattenCgStmts id stmts)
782         }       
783
784 -- collect the code emitted by an FCode computation
785 getCgStmts' :: FCode a -> FCode (a, CgStmts)
786 getCgStmts' fcode
787   = do  { state1 <- getState
788         ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
789         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
790         ; return (a, cgs_stmts state2) }
791
792 getCgStmts :: FCode a -> FCode CgStmts
793 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
794
795 -- Simple ways to construct CgStmts:
796 noCgStmts :: CgStmts
797 noCgStmts = nilOL
798
799 oneCgStmt :: CmmStmt -> CgStmts
800 oneCgStmt stmt = unitOL (CgStmt stmt)
801
802 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
803 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
804
805 -- ----------------------------------------------------------------------------
806 -- Get the current module name
807
808 getModuleName :: FCode Module
809 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
810
811 -- ----------------------------------------------------------------------------
812 -- Get/set the end-of-block info
813
814 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
815 setEndOfBlockInfo eob_info code = do
816         info  <- getInfoDown
817         withInfoDown code (info {cgd_eob = eob_info})
818
819 getEndOfBlockInfo :: FCode EndOfBlockInfo
820 getEndOfBlockInfo = do
821         info <- getInfoDown
822         return (cgd_eob info)
823
824 -- ----------------------------------------------------------------------------
825 -- Get/set the current SRT label
826
827 -- There is just one SRT for each top level binding; all the nested
828 -- bindings use sub-sections of this SRT.  The label is passed down to
829 -- the nested bindings via the monad.
830
831 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
832 getSRTLabel = do info  <- getInfoDown
833                  return (cgd_srt_lbl info)
834
835 setSRTLabel :: CLabel -> FCode a -> FCode a
836 setSRTLabel srt_lbl code
837   = do  info <- getInfoDown
838         withInfoDown code (info { cgd_srt_lbl = srt_lbl})
839
840 getSRT :: FCode SRT
841 getSRT = do info <- getInfoDown
842             return (cgd_srt info)
843
844 setSRT :: SRT -> FCode a -> FCode a
845 setSRT srt code
846   = do info <- getInfoDown
847        withInfoDown code (info { cgd_srt = srt})
848
849 -- ----------------------------------------------------------------------------
850 -- Get/set the current ticky counter label
851
852 getTickyCtrLabel :: FCode CLabel
853 getTickyCtrLabel = do
854         info <- getInfoDown
855         return (cgd_ticky info)
856
857 setTickyCtrLabel :: CLabel -> Code -> Code
858 setTickyCtrLabel ticky code = do
859         info <- getInfoDown
860         withInfoDown code (info {cgd_ticky = ticky})
861 \end{code}