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