compiler/codeGen/CgMonad.lhs

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