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 module CgMonad (
  12         Code,   -- type
  13         FCode,  -- type
  14
  15         initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
  16         returnFC, fixC, checkedAbsC,
  17         stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
  18         newUnique, newUniqSupply,
  19
  20         CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
  21         getCgStmts', getCgStmts,
  22         noCgStmts, oneCgStmt, consCgStmt,
  23
  24         getCmm,
  25         emitData, emitProc, emitSimpleProc,
  26
  27         forkLabelledCode,
  28         forkClosureBody, forkStatics, forkAlts, forkEval,
  29         forkEvalHelp, forkProc, codeOnly,
  30         SemiTaggingStuff, ConTagZ,
  31
  32         EndOfBlockInfo(..),
  33         setEndOfBlockInfo, getEndOfBlockInfo,
  34
  35         setSRTLabel, getSRTLabel,
  36         setTickyCtrLabel, getTickyCtrLabel,
  37
  38         StackUsage(..), HeapUsage(..),
  39         VirtualSpOffset, VirtualHpOffset,
  40         initStkUsage, initHpUsage,
  41         getHpUsage,  setHpUsage,
  42         heapHWM,
  43
  44         getModuleName,
  45
  46         Sequel(..), -- ToDo: unabstract?
  47
  48         -- ideally we wouldn't export these, but some other modules access internal state
  49         getState, setState, getInfoDown, getDynFlags, getThisPackage,
  50
  51         -- more localised access to monad state
  52         getStkUsage, setStkUsage,
  53         getBinds, setBinds, getStaticBinds,
  54
  55         -- out of general friendliness, we also export ...
  56         CgInfoDownwards(..), CgState(..)        -- non-abstract
  57     ) where
  58
  59 #include "HsVersions.h"
  60
  61 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
  62
  63 import DynFlags
  64 import PackageConfig
  65 import Cmm
  66 import CmmUtils
  67 import CLabel
  68 import SMRep
  69 import Module
  70 import Id
  71 import VarEnv
  72 import OrdList
  73 import Unique
  74 import Util
  75 import UniqSupply
  76 import FastString
  77 import Outputable
  78
  79 import Control.Monad
  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     = ( [CmmBranch id], [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 -- INVARIANT: 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 getThisPackage :: FCode PackageId
 511 getThisPackage = liftM thisPackage getDynFlags
 512
 513 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 514 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 515
 516 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 517 doFCode (FCode fcode) info_down state = fcode info_down state
 518 \end{code}
 519
 520
 521 %************************************************************************
 522 %*                                                                      *
 523                 Forking
 524 %*                                                                      *
 525 %************************************************************************
 526
 527 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 528 fresh environment, except that:
 529         - compilation info and statics are passed in unchanged.
 530 The current environment is passed on completely unaltered, except that
 531 abstract C from the fork is incorporated.
 532
 533 @forkProc@ takes a code and compiles it in the current environment,
 534 returning the basic blocks thus constructed.  The current environment
 535 is passed on completely unchanged.  It is pretty similar to
 536 @getBlocks@, except that the latter does affect the environment.
 537
 538 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 539 from the current bindings, but which is otherwise freshly initialised.
 540 The Abstract~C returned is attached to the current state, but the
 541 bindings and usage information is otherwise unchanged.
 542
 543 \begin{code}
 544 forkClosureBody :: Code -> Code
 545 forkClosureBody body_code
 546   = do  { info <- getInfoDown
 547         ; us   <- newUniqSupply
 548         ; state <- getState
 549         ; let   body_info_down = info { cgd_eob = initEobInfo }
 550                 ((),fork_state) = doFCode body_code body_info_down
 551                                           (initCgState us)
 552         ; ASSERT( isNilOL (cgs_stmts fork_state) )
 553           setState $ state `addCodeBlocksFrom` fork_state }
 554
 555 forkStatics :: FCode a -> FCode a
 556 forkStatics body_code
 557   = do  { info  <- getInfoDown
 558         ; us    <- newUniqSupply
 559         ; state <- getState
 560         ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
 561                                        cgd_eob     = initEobInfo }
 562                 (result, fork_state_out) = doFCode body_code rhs_info_down
 563                                                    (initCgState us)
 564         ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
 565           setState (state `addCodeBlocksFrom` fork_state_out)
 566         ; return result }
 567
 568 forkProc :: Code -> FCode CgStmts
 569 forkProc body_code
 570   = do  { info_down <- getInfoDown
 571         ; us    <- newUniqSupply
 572         ; state <- getState
 573         ; let   fork_state_in = (initCgState us)
 574                                         { cgs_binds   = cgs_binds state,
 575                                           cgs_stk_usg = cgs_stk_usg state,
 576                                           cgs_hp_usg  = cgs_hp_usg state }
 577                         -- ToDo: is the hp usage necesary?
 578                 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
 579                                                       info_down fork_state_in
 580         ; setState $ state `stateIncUsageEval` fork_state_out
 581         ; return code_blks }
 582
 583 codeOnly :: Code -> Code
 584 -- Emit any code from the inner thing into the outer thing
 585 -- Do not affect anything else in the outer state
 586 -- Used in almost-circular code to prevent false loop dependencies
 587 codeOnly body_code
 588   = do  { info_down <- getInfoDown
 589         ; us   <- newUniqSupply
 590         ; state <- getState
 591         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
 592                                                    cgs_stk_usg = cgs_stk_usg state,
 593                                                    cgs_hp_usg  = cgs_hp_usg state }
 594                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
 595         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 596 \end{code}
 597
 598 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 599 an fcode for the default case $d$, and compiles each in the current
 600 environment.  The current environment is passed on unmodified, except
 601 that
 602         - the worst stack high-water mark is incorporated
 603         - the virtual Hp is moved on to the worst virtual Hp for the branches
 604
 605 \begin{code}
 606 forkAlts :: [FCode a] -> FCode [a]
 607
 608 forkAlts branch_fcodes
 609   = do  { info_down <- getInfoDown
 610         ; us <- newUniqSupply
 611         ; state <- getState
 612         ; let compile us branch
 613                 = (us2, doFCode branch info_down branch_state)
 614                 where
 615                   (us1,us2) = splitUniqSupply us
 616                   branch_state = (initCgState us1) {
 617                                         cgs_binds   = cgs_binds state,
 618                                         cgs_stk_usg = cgs_stk_usg state,
 619                                         cgs_hp_usg  = cgs_hp_usg state }
 620
 621               (_us, results) = mapAccumL compile us branch_fcodes
 622               (branch_results, branch_out_states) = unzip results
 623         ; setState $ foldl stateIncUsage state branch_out_states
 624                 -- NB foldl.  state is the *left* argument to stateIncUsage
 625         ; return branch_results }
 626 \end{code}
 627
 628 @forkEval@ takes two blocks of code.
 629
 630    -  The first meddles with the environment to set it up as expected by
 631       the alternatives of a @case@ which does an eval (or gc-possible primop).
 632    -  The second block is the code for the alternatives.
 633       (plus info for semi-tagging purposes)
 634
 635 @forkEval@ picks up the virtual stack pointer and returns a suitable
 636 @EndOfBlockInfo@ for the caller to use, together with whatever value
 637 is returned by the second block.
 638
 639 It uses @initEnvForAlternatives@ to initialise the environment, and
 640 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 641 usage.
 642
 643 \begin{code}
 644 forkEval :: EndOfBlockInfo              -- For the body
 645          -> Code                        -- Code to set environment
 646          -> FCode Sequel                -- Semi-tagging info to store
 647          -> FCode EndOfBlockInfo        -- The new end of block info
 648
 649 forkEval body_eob_info env_code body_code
 650   = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
 651         ; returnFC (EndOfBlockInfo v sequel) }
 652
 653 forkEvalHelp :: EndOfBlockInfo  -- For the body
 654              -> Code            -- Code to set environment
 655              -> FCode a         -- The code to do after the eval
 656              -> FCode (VirtualSpOffset, -- Sp
 657                        a)               -- Result of the FCode
 658         -- A disturbingly complicated function
 659 forkEvalHelp body_eob_info env_code body_code
 660   = do  { info_down <- getInfoDown
 661         ; us   <- newUniqSupply
 662         ; state <- getState
 663         ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
 664               ; (_, env_state) = doFCode env_code info_down_for_body
 665                                          (state {cgs_uniqs = us})
 666               ; state_for_body = (initCgState (cgs_uniqs env_state))
 667                                         { cgs_binds   = binds_for_body,
 668                                           cgs_stk_usg = stk_usg_for_body }
 669               ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
 670               ; stk_usg_from_env = cgs_stk_usg env_state
 671               ; virtSp_from_env  = virtSp stk_usg_from_env
 672               ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
 673                                                      hwSp   = virtSp_from_env}
 674               ; (value_returned, state_at_end_return)
 675                         = doFCode body_code info_down_for_body state_for_body
 676           }
 677         ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
 678                  -- The code coming back should consist only of nested declarations,
 679                  -- notably of the return vector!
 680           setState $ state `stateIncUsageEval` state_at_end_return
 681         ; return (virtSp_from_env, value_returned) }
 682
 683
 684 -- ----------------------------------------------------------------------------
 685 -- Combinators for emitting code
 686
 687 nopC :: Code
 688 nopC = return ()
 689
 690 whenC :: Bool -> Code -> Code
 691 whenC True  code = code
 692 whenC False code = nopC
 693
 694 stmtC :: CmmStmt -> Code
 695 stmtC stmt = emitCgStmt (CgStmt stmt)
 696
 697 labelC :: BlockId -> Code
 698 labelC id = emitCgStmt (CgLabel id)
 699
 700 newLabelC :: FCode BlockId
 701 newLabelC = do { id <- newUnique; return (BlockId id) }
 702
 703 checkedAbsC :: CmmStmt -> Code
 704 -- Emit code, eliminating no-ops
 705 checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
 706                               else unitOL stmt)
 707
 708 stmtsC :: [CmmStmt] -> Code
 709 stmtsC stmts = emitStmts (toOL stmts)
 710
 711 -- Emit code; no no-op checking
 712 emitStmts :: CmmStmts -> Code
 713 emitStmts stmts = emitCgStmts (fmap CgStmt stmts)
 714
 715 -- forkLabelledCode is for emitting a chunk of code with a label, outside
 716 -- of the current instruction stream.
 717 forkLabelledCode :: Code -> FCode BlockId
 718 forkLabelledCode code = getCgStmts code >>= forkCgStmts
 719
 720 emitCgStmt :: CgStmt -> Code
 721 emitCgStmt stmt
 722   = do  { state <- getState
 723         ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
 724         }
 725
 726 emitData :: Section -> [CmmStatic] -> Code
 727 emitData sect lits
 728   = do  { state <- getState
 729         ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
 730   where
 731     data_block = CmmData sect lits
 732
 733 emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [CmmBasicBlock] -> Code
 734 emitProc lits lbl args blocks
 735   = do  { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
 736         ; state <- getState
 737         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 738
 739 emitSimpleProc :: CLabel -> Code -> Code
 740 -- Emit a procedure whose body is the specified code; no info table
 741 emitSimpleProc lbl code
 742   = do  { stmts <- getCgStmts code
 743         ; blks <- cgStmtsToBlocks stmts
 744         ; emitProc [] lbl [] blks }
 745
 746 getCmm :: Code -> FCode Cmm
 747 -- Get all the CmmTops (there should be no stmts)
 748 getCmm code
 749   = do  { state1 <- getState
 750         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
 751         ; setState $ state2 { cgs_tops = cgs_tops state1 }
 752         ; return (Cmm (fromOL (cgs_tops state2))) }
 753
 754 -- ----------------------------------------------------------------------------
 755 -- CgStmts
 756
 757 -- These functions deal in terms of CgStmts, which is an abstract type
 758 -- representing the code in the current proc.
 759
 760
 761 -- emit CgStmts into the current instruction stream
 762 emitCgStmts :: CgStmts -> Code
 763 emitCgStmts stmts
 764   = do  { state <- getState
 765         ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
 766
 767 -- emit CgStmts outside the current instruction stream, and return a label
 768 forkCgStmts :: CgStmts -> FCode BlockId
 769 forkCgStmts stmts
 770   = do  { id <- newLabelC
 771         ; emitCgStmt (CgFork id stmts)
 772         ; return id
 773         }
 774
 775 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 776 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
 777 cgStmtsToBlocks stmts
 778   = do  { id <- newLabelC
 779         ; return (flattenCgStmts id stmts)
 780         }
 781
 782 -- collect the code emitted by an FCode computation
 783 getCgStmts' :: FCode a -> FCode (a, CgStmts)
 784 getCgStmts' fcode
 785   = do  { state1 <- getState
 786         ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
 787         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
 788         ; return (a, cgs_stmts state2) }
 789
 790 getCgStmts :: FCode a -> FCode CgStmts
 791 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
 792
 793 -- Simple ways to construct CgStmts:
 794 noCgStmts :: CgStmts
 795 noCgStmts = nilOL
 796
 797 oneCgStmt :: CmmStmt -> CgStmts
 798 oneCgStmt stmt = unitOL (CgStmt stmt)
 799
 800 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
 801 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
 802
 803 -- ----------------------------------------------------------------------------
 804 -- Get the current module name
 805
 806 getModuleName :: FCode Module
 807 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
 808
 809 -- ----------------------------------------------------------------------------
 810 -- Get/set the end-of-block info
 811
 812 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 813 setEndOfBlockInfo eob_info code = do
 814         info  <- getInfoDown
 815         withInfoDown code (info {cgd_eob = eob_info})
 816
 817 getEndOfBlockInfo :: FCode EndOfBlockInfo
 818 getEndOfBlockInfo = do
 819         info <- getInfoDown
 820         return (cgd_eob info)
 821
 822 -- ----------------------------------------------------------------------------
 823 -- Get/set the current SRT label
 824
 825 -- There is just one SRT for each top level binding; all the nested
 826 -- bindings use sub-sections of this SRT.  The label is passed down to
 827 -- the nested bindings via the monad.
 828
 829 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 830 getSRTLabel = do info  <- getInfoDown
 831                  return (cgd_srt info)
 832
 833 setSRTLabel :: CLabel -> FCode a -> FCode a
 834 setSRTLabel srt_lbl code
 835   = do  info <- getInfoDown
 836         withInfoDown code (info { cgd_srt = srt_lbl})
 837
 838 -- ----------------------------------------------------------------------------
 839 -- Get/set the current ticky counter label
 840
 841 getTickyCtrLabel :: FCode CLabel
 842 getTickyCtrLabel = do
 843         info <- getInfoDown
 844         return (cgd_ticky info)
 845
 846 setTickyCtrLabel :: CLabel -> Code -> Code
 847 setTickyCtrLabel ticky code = do
 848         info <- getInfoDown
 849         withInfoDown code (info {cgd_ticky = ticky})
 850 \end{code}