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