ghc/compiler/codeGen/CgMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgMonad.lhs,v 1.42 2004/11/26 16:20:10 simonmar Exp $
   5 %
   6 \section[CgMonad]{The code generation monad}
   7
   8 See the beginning of the top-level @CodeGen@ module, to see how this
   9 monadic stuff fits into the Big Picture.
  10
  11 \begin{code}
  12 module CgMonad (
  13         Code,   -- type
  14         FCode,  -- type
  15
  16         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  17         returnFC, 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         emitData, 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         setSRTLabel, getSRTLabel,
  37         setTickyCtrLabel, getTickyCtrLabel,
  38
  39         StackUsage(..), HeapUsage(..),
  40         VirtualSpOffset, VirtualHpOffset,
  41         initStkUsage, initHpUsage,
  42         getHpUsage,  setHpUsage,
  43         heapHWM,
  44
  45         moduleName,
  46
  47         Sequel(..), -- ToDo: unabstract?
  48
  49         -- ideally we wouldn't export these, but some other modules access internal state
  50         getState, setState, getInfoDown, getDynFlags,
  51
  52         -- more localised access to monad state
  53         getStkUsage, setStkUsage,
  54         getBinds, setBinds, getStaticBinds,
  55
  56         -- out of general friendliness, we also export ...
  57         CgInfoDownwards(..), CgState(..)        -- non-abstract
  58     ) where
  59
  60 #include "HsVersions.h"
  61
  62 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
  63
  64 import CmdLineOpts      ( DynFlags )
  65 import Cmm
  66 import CmmUtils         ( CmmStmts, isNopStmt )
  67 import CLabel
  68 import SMRep            ( WordOff )
  69 import Module           ( Module )
  70 import Id               ( Id )
  71 import VarEnv
  72 import OrdList
  73 import Unique           ( Unique )
  74 import Util             ( mapAccumL )
  75 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
  76 import FastString
  77 import Outputable
  78
  79 import Control.Monad    ( liftM )
  80
  81 infixr 9 `thenC`        -- Right-associative!
  82 infixr 9 `thenFC`
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection[CgMonad-environment]{Stuff for manipulating environments}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 This monadery has some information that it only passes {\em
  92 downwards}, as well as some ``state'' which is modified as we go
  93 along.
  94
  95 \begin{code}
  96 data CgInfoDownwards    -- information only passed *downwards* by the monad
  97   = MkCgInfoDown {
  98         cgd_dflags  :: DynFlags,
  99         cgd_mod     :: Module,          -- Module being compiled
 100         cgd_statics :: CgBindings,      -- [Id -> info] : static environment
 101         cgd_srt     :: CLabel,          -- label of the current SRT
 102         cgd_ticky   :: CLabel,          -- current destination for ticky counts
 103         cgd_eob     :: EndOfBlockInfo   -- Info for stuff to do at end of basic block:
 104   }
 105
 106 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 107 initCgInfoDown dflags mod
 108   = MkCgInfoDown {      cgd_dflags  = dflags,
 109                         cgd_mod     = mod,
 110                         cgd_statics = emptyVarEnv,
 111                         cgd_srt     = error "initC: srt",
 112                         cgd_ticky   = mkTopTickyCtrLabel,
 113                         cgd_eob     = initEobInfo }
 114
 115 data CgState
 116   = MkCgState {
 117      cgs_stmts :: OrdList CgStmt,         -- Current proc
 118      cgs_tops  :: OrdList CmmTop,
 119         -- Other procedures and data blocks in this compilation unit
 120         -- Both the latter two are ordered only so that we can
 121         -- reduce forward references, when it's easy to do so
 122
 123      cgs_binds :: CgBindings,   -- [Id -> info] : *local* bindings environment
 124                                 -- Bindings for top-level things are given in
 125                                 -- the info-down part
 126
 127      cgs_stk_usg :: StackUsage,
 128      cgs_hp_usg  :: HeapUsage,
 129
 130      cgs_uniqs :: UniqSupply }
 131
 132 initCgState :: UniqSupply -> CgState
 133 initCgState uniqs
 134   = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
 135                 cgs_binds = emptyVarEnv,
 136                 cgs_stk_usg = initStkUsage,
 137                 cgs_hp_usg = initHpUsage,
 138                 cgs_uniqs = uniqs }
 139 \end{code}
 140
 141 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
 142 if the expression is a @case@, what to do at the end of each
 143 alternative.
 144
 145 \begin{code}
 146 data EndOfBlockInfo
 147   = EndOfBlockInfo
 148         VirtualSpOffset   -- Args Sp: trim the stack to this point at a
 149                           -- return; push arguments starting just
 150                           -- above this point on a tail call.
 151
 152                           -- This is therefore the stk ptr as seen
 153                           -- by a case alternative.
 154         Sequel
 155
 156 initEobInfo = EndOfBlockInfo 0 OnStack
 157 \end{code}
 158
 159 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 160 that it must survive stack pointer adjustments at the end of the
 161 block.
 162
 163 \begin{code}
 164 data Sequel
 165   = OnStack             -- Continuation is on the stack
 166   | UpdateCode          -- Continuation is update
 167
 168   | CaseAlts
 169           CLabel     -- Jump to this; if the continuation is for a vectored
 170                      -- case this might be the label of a return vector
 171           SemiTaggingStuff
 172           Id          -- The case binder, only used to see if it's dead
 173           Bool        -- True <=> polymorphic, push a SEQ frame too
 174
 175 type SemiTaggingStuff
 176   = Maybe                       -- Maybe[1] we don't have any semi-tagging stuff...
 177      ([(ConTagZ, CmmLit)],      -- Alternatives
 178       CmmLit)                   -- Default (will be a can't happen RTS label if can't happen)
 179
 180 type ConTagZ = Int      -- A *zero-indexed* contructor tag
 181
 182 -- The case branch is executed only from a successful semitagging
 183 -- venture, when a case has looked at a variable, found that it's
 184 -- evaluated, and wants to load up the contents and go to the join
 185 -- point.
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190                 CgStmt type
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 The CgStmts type is what the code generator outputs: it is a tree of
 195 statements, including in-line labels.  The job of flattenCgStmts is to
 196 turn this into a list of basic blocks, each of which ends in a jump
 197 statement (either a local branch or a non-local jump).
 198
 199 \begin{code}
 200 type CgStmts = OrdList CgStmt
 201
 202 data CgStmt
 203   = CgStmt  CmmStmt
 204   | CgLabel BlockId
 205   | CgFork  BlockId CgStmts
 206
 207 flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
 208 flattenCgStmts id stmts =
 209         case flatten (fromOL stmts) of
 210           ([],blocks)    -> blocks
 211           (block,blocks) -> BasicBlock id block : blocks
 212  where
 213   flatten [] = ([],[])
 214
 215   -- A label at the end of a function or fork: this label must not be reachable,
 216   -- but it might be referred to from another BB that also isn't reachable.
 217   -- Eliminating these has to be done with a dead-code analysis.  For now,
 218   -- we just make it into a well-formed block by adding a recursive jump.
 219   flatten [CgLabel id]
 220     = ( [], [BasicBlock id [CmmBranch id]] )
 221
 222   -- A jump/branch: throw away all the code up to the next label, because
 223   -- it is unreachable.  Be careful to keep forks that we find on the way.
 224   flatten (CgStmt stmt : stmts)
 225     | isJump stmt
 226     = case dropWhile isOrdinaryStmt stmts of
 227         []                     -> ( [stmt], [] )
 228         [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
 229         (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
 230             where (block,blocks) = flatten stmts
 231         (CgFork fork_id stmts : ss) ->
 232            flatten (CgFork fork_id stmts : CgStmt stmt : ss)
 233
 234   flatten (s:ss) =
 235         case s of
 236           CgStmt stmt -> (stmt:block,blocks)
 237           CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
 238           CgFork fork_id stmts ->
 239                 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
 240                 where (fork_block, fork_blocks) = flatten (fromOL stmts)
 241     where (block,blocks) = flatten ss
 242
 243 isJump (CmmJump _ _) = True
 244 isJump (CmmBranch _) = True
 245 isJump _ = False
 246
 247 isOrdinaryStmt (CgStmt _) = True
 248 isOrdinaryStmt _ = False
 249 \end{code}
 250
 251 %************************************************************************
 252 %*                                                                      *
 253                 Stack and heap models
 254 %*                                                                      *
 255 %************************************************************************
 256
 257 \begin{code}
 258 type VirtualHpOffset = WordOff  -- Both are in
 259 type VirtualSpOffset = WordOff  -- units of words
 260
 261 data StackUsage
 262   = StackUsage {
 263         virtSp :: VirtualSpOffset,
 264                 -- Virtual offset of topmost allocated slot
 265
 266         frameSp :: VirtualSpOffset,
 267                 -- Virtual offset of the return address of the enclosing frame.
 268                 -- This RA describes the liveness/pointedness of
 269                 -- all the stack from frameSp downwards
 270                 -- INVARIANT: less than or equal to virtSp
 271
 272          freeStk :: [VirtualSpOffset],
 273                 -- List of free slots, in *increasing* order
 274                 -- INVARIANT: all <= virtSp
 275                 -- All slots <= virtSp are taken except these ones
 276
 277          realSp :: VirtualSpOffset,
 278                 -- Virtual offset of real stack pointer register
 279
 280          hwSp :: VirtualSpOffset
 281   }                -- Highest value ever taken by virtSp
 282
 283 -- INVARAINT: The environment contains no Stable references to
 284 --            stack slots below (lower offset) frameSp
 285 --            It can contain volatile references to this area though.
 286
 287 data HeapUsage =
 288   HeapUsage {
 289         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
 290         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
 291   }
 292 \end{code}
 293
 294 The heap high water mark is the larger of virtHp and hwHp.  The latter is
 295 only records the high water marks of forked-off branches, so to find the
 296 heap high water mark you have to take the max of virtHp and hwHp.  Remember,
 297 virtHp never retreats!
 298
 299 Note Jan 04: ok, so why do we only look at the virtual Hp??
 300
 301 \begin{code}
 302 heapHWM :: HeapUsage -> VirtualHpOffset
 303 heapHWM = virtHp
 304 \end{code}
 305
 306 Initialisation.
 307
 308 \begin{code}
 309 initStkUsage :: StackUsage
 310 initStkUsage = StackUsage {
 311                         virtSp = 0,
 312                         frameSp = 0,
 313                         freeStk = [],
 314                         realSp = 0,
 315                         hwSp = 0
 316                }
 317
 318 initHpUsage :: HeapUsage
 319 initHpUsage = HeapUsage {
 320                 virtHp = 0,
 321                 realHp = 0
 322               }
 323 \end{code}
 324
 325 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 326 marks found in $e_2$.
 327
 328 \begin{code}
 329 stateIncUsage :: CgState -> CgState -> CgState
 330 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
 331      = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
 332             cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
 333        `addCodeBlocksFrom` s2
 334
 335 stateIncUsageEval :: CgState -> CgState -> CgState
 336 stateIncUsageEval s1 s2
 337      = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
 338        `addCodeBlocksFrom` s2
 339         -- We don't max the heap high-watermark because stateIncUsageEval is
 340         -- used only in forkEval, which in turn is only used for blocks of code
 341         -- which do their own heap-check.
 342
 343 addCodeBlocksFrom :: CgState -> CgState -> CgState
 344 -- Add code blocks from the latter to the former
 345 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 346 s1 `addCodeBlocksFrom` s2
 347   = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
 348          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 349
 350 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
 351 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 352
 353 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
 354 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
 355 \end{code}
 356
 357 %************************************************************************
 358 %*                                                                      *
 359                 The FCode monad
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 \begin{code}
 364 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
 365 type Code       = FCode ()
 366
 367 instance Monad FCode where
 368         (>>=) = thenFC
 369         return = returnFC
 370
 371 {-# INLINE thenC #-}
 372 {-# INLINE thenFC #-}
 373 {-# INLINE returnFC #-}
 374 \end{code}
 375 The Abstract~C is not in the environment so as to improve strictness.
 376
 377 \begin{code}
 378 initC :: DynFlags -> Module -> FCode a -> IO a
 379
 380 initC dflags mod (FCode code)
 381   = do  { uniqs <- mkSplitUniqSupply 'c'
 382         ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
 383               (res, _) -> return res
 384         }
 385
 386 returnFC :: a -> FCode a
 387 returnFC val = FCode (\info_down state -> (val, state))
 388 \end{code}
 389
 390 \begin{code}
 391 thenC :: Code -> FCode a -> FCode a
 392 thenC (FCode m) (FCode k) =
 393         FCode (\info_down state -> let (_,new_state) = m info_down state in
 394                 k info_down new_state)
 395
 396 listCs :: [Code] -> Code
 397 listCs [] = return ()
 398 listCs (fc:fcs) = do
 399         fc
 400         listCs fcs
 401
 402 mapCs :: (a -> Code) -> [a] -> Code
 403 mapCs = mapM_
 404 \end{code}
 405
 406 \begin{code}
 407 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
 408 thenFC (FCode m) k = FCode (
 409         \info_down state ->
 410                 let
 411                         (m_result, new_state) = m info_down state
 412                         (FCode kcode) = k m_result
 413                 in
 414                         kcode info_down new_state
 415         )
 416
 417 listFCs :: [FCode a] -> FCode [a]
 418 listFCs = sequence
 419
 420 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 421 mapFCs = mapM
 422 \end{code}
 423
 424 And the knot-tying combinator:
 425 \begin{code}
 426 fixC :: (a -> FCode a) -> FCode a
 427 fixC fcode = FCode (
 428         \info_down state ->
 429                 let
 430                         FCode fc = fcode v
 431                         result@(v,_) = fc info_down state
 432                         --          ^--------^
 433                 in
 434                         result
 435         )
 436 \end{code}
 437
 438 %************************************************************************
 439 %*                                                                      *
 440         Operators for getting and setting the state and "info_down".
 441
 442 %*                                                                      *
 443 %************************************************************************
 444
 445 \begin{code}
 446 getState :: FCode CgState
 447 getState = FCode $ \info_down state -> (state,state)
 448
 449 setState :: CgState -> FCode ()
 450 setState state = FCode $ \info_down _ -> ((),state)
 451
 452 getStkUsage :: FCode StackUsage
 453 getStkUsage = do
 454         state <- getState
 455         return $ cgs_stk_usg state
 456
 457 setStkUsage :: StackUsage -> Code
 458 setStkUsage new_stk_usg = do
 459         state <- getState
 460         setState $ state {cgs_stk_usg = new_stk_usg}
 461
 462 getHpUsage :: FCode HeapUsage
 463 getHpUsage = do
 464         state <- getState
 465         return $ cgs_hp_usg state
 466
 467 setHpUsage :: HeapUsage -> Code
 468 setHpUsage new_hp_usg = do
 469         state <- getState
 470         setState $ state {cgs_hp_usg = new_hp_usg}
 471
 472 getBinds :: FCode CgBindings
 473 getBinds = do
 474         state <- getState
 475         return $ cgs_binds state
 476
 477 setBinds :: CgBindings -> FCode ()
 478 setBinds new_binds = do
 479         state <- getState
 480         setState $ state {cgs_binds = new_binds}
 481
 482 getStaticBinds :: FCode CgBindings
 483 getStaticBinds = do
 484         info  <- getInfoDown
 485         return (cgd_statics info)
 486
 487 withState :: FCode a -> CgState -> FCode (a,CgState)
 488 withState (FCode fcode) newstate = FCode $ \info_down state ->
 489         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
 490
 491 newUniqSupply :: FCode UniqSupply
 492 newUniqSupply = do
 493         state <- getState
 494         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
 495         setState $ state { cgs_uniqs = us1 }
 496         return us2
 497
 498 newUnique :: FCode Unique
 499 newUnique = do
 500         us <- newUniqSupply
 501         return (uniqFromSupply us)
 502
 503 ------------------
 504 getInfoDown :: FCode CgInfoDownwards
 505 getInfoDown = FCode $ \info_down state -> (info_down,state)
 506
 507 getDynFlags :: FCode DynFlags
 508 getDynFlags = liftM cgd_dflags getInfoDown
 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 codeOnly :: Code -> Code
 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 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 code = nopC
 690
 691 stmtC :: CmmStmt -> Code
 692 stmtC stmt = emitCgStmt (CgStmt stmt)
 693
 694 labelC :: BlockId -> Code
 695 labelC id = emitCgStmt (CgLabel id)
 696
 697 newLabelC :: FCode BlockId
 698 newLabelC = do { id <- newUnique; return (BlockId id) }
 699
 700 checkedAbsC :: CmmStmt -> Code
 701 -- Emit code, eliminating no-ops
 702 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
 703                               else unitOL stmt)
 704
 705 stmtsC :: [CmmStmt] -> Code
 706 stmtsC stmts = emitStmts (toOL stmts)
 707
 708 -- Emit code; no no-op checking
 709 emitStmts :: CmmStmts -> Code
 710 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
 711
 712 -- forkLabelledCode is for emitting a chunk of code with a label, outside
 713 -- of the current instruction stream.
 714 forkLabelledCode :: Code -> FCode BlockId
 715 forkLabelledCode code = getCgStmts code >>= forkCgStmts
 716
 717 emitCgStmt :: CgStmt -> Code
 718 emitCgStmt stmt
 719   = do  { state <- getState
 720         ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
 721         }
 722
 723 emitData :: Section -> [CmmStatic] -> Code
 724 emitData sect lits
 725   = do  { state <- getState
 726         ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
 727   where
 728     data_block = CmmData sect lits
 729
 730 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
 731 emitProc lits lbl args blocks
 732   = do  { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
 733         ; state <- getState
 734         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 735
 736 emitSimpleProc :: CLabel -> Code -> Code
 737 -- Emit a procedure whose body is the specified code; no info table
 738 emitSimpleProc lbl code
 739   = do  { stmts <- getCgStmts code
 740         ; blks <- cgStmtsToBlocks stmts
 741         ; emitProc [] lbl [] blks }
 742
 743 getCmm :: Code -> FCode Cmm
 744 -- Get all the CmmTops (there should be no stmts)
 745 getCmm code
 746   = do  { state1 <- getState
 747         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
 748         ; setState $ state2 { cgs_tops = cgs_tops state1 }
 749         ; return (Cmm (fromOL (cgs_tops state2))) }
 750
 751 -- ----------------------------------------------------------------------------
 752 -- CgStmts
 753
 754 -- These functions deal in terms of CgStmts, which is an abstract type
 755 -- representing the code in the current proc.
 756
 757
 758 -- emit CgStmts into the current instruction stream
 759 emitCgStmts :: CgStmts -> Code
 760 emitCgStmts stmts
 761   = do  { state <- getState
 762         ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
 763
 764 -- emit CgStmts outside the current instruction stream, and return a label
 765 forkCgStmts :: CgStmts -> FCode BlockId
 766 forkCgStmts stmts
 767   = do  { id <- newLabelC
 768         ; emitCgStmt (CgFork id stmts)
 769         ; return id
 770         }
 771
 772 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 773 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
 774 cgStmtsToBlocks stmts
 775   = do  { id <- newLabelC
 776         ; return (flattenCgStmts id stmts)
 777         }
 778
 779 -- collect the code emitted by an FCode computation
 780 getCgStmts' :: FCode a -> FCode (a, CgStmts)
 781 getCgStmts' fcode
 782   = do  { state1 <- getState
 783         ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
 784         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
 785         ; return (a, cgs_stmts state2) }
 786
 787 getCgStmts :: FCode a -> FCode CgStmts
 788 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
 789
 790 -- Simple ways to construct CgStmts:
 791 noCgStmts :: CgStmts
 792 noCgStmts = nilOL
 793
 794 oneCgStmt :: CmmStmt -> CgStmts
 795 oneCgStmt stmt = unitOL (CgStmt stmt)
 796
 797 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
 798 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
 799
 800 -- ----------------------------------------------------------------------------
 801 -- Get the current module name
 802
 803 moduleName :: FCode Module
 804 moduleName = do { info <- getInfoDown; return (cgd_mod info) }
 805
 806 -- ----------------------------------------------------------------------------
 807 -- Get/set the end-of-block info
 808
 809 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 810 setEndOfBlockInfo eob_info code = do
 811         info  <- getInfoDown
 812         withInfoDown code (info {cgd_eob = eob_info})
 813
 814 getEndOfBlockInfo :: FCode EndOfBlockInfo
 815 getEndOfBlockInfo = do
 816         info <- getInfoDown
 817         return (cgd_eob info)
 818
 819 -- ----------------------------------------------------------------------------
 820 -- Get/set the current SRT label
 821
 822 -- There is just one SRT for each top level binding; all the nested
 823 -- bindings use sub-sections of this SRT.  The label is passed down to
 824 -- the nested bindings via the monad.
 825
 826 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 827 getSRTLabel = do info  <- getInfoDown
 828                  return (cgd_srt info)
 829
 830 setSRTLabel :: CLabel -> FCode a -> FCode a
 831 setSRTLabel srt_lbl code
 832   = do  info <- getInfoDown
 833         withInfoDown code (info { cgd_srt = srt_lbl})
 834
 835 -- ----------------------------------------------------------------------------
 836 -- Get/set the current ticky counter label
 837
 838 getTickyCtrLabel :: FCode CLabel
 839 getTickyCtrLabel = do
 840         info <- getInfoDown
 841         return (cgd_ticky info)
 842
 843 setTickyCtrLabel :: CLabel -> Code -> Code
 844 setTickyCtrLabel ticky code = do
 845         info <- getInfoDown
 846         withInfoDown code (info {cgd_ticky = ticky})
 847 \end{code}