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