ghc/compiler/codeGen/CgMonad.lhs

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