compiler/codeGen/CgMonad.lhs

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