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