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 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
 162 initEobInfo = EndOfBlockInfo 0 OnStack
 163 \end{code}
 164
 165 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
 166 that it must survive stack pointer adjustments at the end of the
 167 block.
 168
 169 \begin{code}
 170 data Sequel
 171   = OnStack             -- Continuation is on the stack
 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         (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
 238
 239   flatten (s:ss) =
 240         case s of
 241           CgStmt stmt -> (stmt:block,blocks)
 242           CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
 243           CgFork fork_id stmts ->
 244                 (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
 245                 where (fork_block, fork_blocks) = flatten (fromOL stmts)
 246     where (block,blocks) = flatten ss
 247
 248 isJump :: CmmStmt -> Bool
 249 isJump (CmmJump _ _) = True
 250 isJump (CmmBranch _) = True
 251 isJump (CmmSwitch _ _) = True
 252 isJump (CmmReturn _) = True
 253 isJump _ = False
 254
 255 isOrdinaryStmt :: CgStmt -> Bool
 256 isOrdinaryStmt (CgStmt _) = True
 257 isOrdinaryStmt _ = False
 258 \end{code}
 259
 260 %************************************************************************
 261 %*                                                                      *
 262                 Stack and heap models
 263 %*                                                                      *
 264 %************************************************************************
 265
 266 \begin{code}
 267 type VirtualHpOffset = WordOff  -- Both are in
 268 type VirtualSpOffset = WordOff  -- units of words
 269
 270 data StackUsage
 271   = StackUsage {
 272         virtSp :: VirtualSpOffset,
 273                 -- Virtual offset of topmost allocated slot
 274
 275         frameSp :: VirtualSpOffset,
 276                 -- Virtual offset of the return address of the enclosing frame.
 277                 -- This RA describes the liveness/pointedness of
 278                 -- all the stack from frameSp downwards
 279                 -- INVARIANT: less than or equal to virtSp
 280
 281          freeStk :: [VirtualSpOffset],
 282                 -- List of free slots, in *increasing* order
 283                 -- INVARIANT: all <= virtSp
 284                 -- All slots <= virtSp are taken except these ones
 285
 286          realSp :: VirtualSpOffset,
 287                 -- Virtual offset of real stack pointer register
 288
 289          hwSp :: VirtualSpOffset
 290   }                -- Highest value ever taken by virtSp
 291
 292 -- INVARIANT: The environment contains no Stable references to
 293 --            stack slots below (lower offset) frameSp
 294 --            It can contain volatile references to this area though.
 295
 296 data HeapUsage =
 297   HeapUsage {
 298         virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
 299         realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
 300   }
 301 \end{code}
 302
 303 The heap high water mark is the larger of virtHp and hwHp.  The latter is
 304 only records the high water marks of forked-off branches, so to find the
 305 heap high water mark you have to take the max of virtHp and hwHp.  Remember,
 306 virtHp never retreats!
 307
 308 Note Jan 04: ok, so why do we only look at the virtual Hp??
 309
 310 \begin{code}
 311 heapHWM :: HeapUsage -> VirtualHpOffset
 312 heapHWM = virtHp
 313 \end{code}
 314
 315 Initialisation.
 316
 317 \begin{code}
 318 initStkUsage :: StackUsage
 319 initStkUsage = StackUsage {
 320                         virtSp = 0,
 321                         frameSp = 0,
 322                         freeStk = [],
 323                         realSp = 0,
 324                         hwSp = 0
 325                }
 326
 327 initHpUsage :: HeapUsage
 328 initHpUsage = HeapUsage {
 329                 virtHp = 0,
 330                 realHp = 0
 331               }
 332 \end{code}
 333
 334 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
 335 marks found in $e_2$.
 336
 337 \begin{code}
 338 stateIncUsage :: CgState -> CgState -> CgState
 339 stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
 340      = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
 341             cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
 342        `addCodeBlocksFrom` s2
 343
 344 stateIncUsageEval :: CgState -> CgState -> CgState
 345 stateIncUsageEval s1 s2
 346      = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
 347        `addCodeBlocksFrom` s2
 348         -- We don't max the heap high-watermark because stateIncUsageEval is
 349         -- used only in forkEval, which in turn is only used for blocks of code
 350         -- which do their own heap-check.
 351
 352 addCodeBlocksFrom :: CgState -> CgState -> CgState
 353 -- Add code blocks from the latter to the former
 354 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 355 s1 `addCodeBlocksFrom` s2
 356   = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
 357          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 358
 359 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
 360 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 361
 362 maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
 363 stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368                 The FCode monad
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
 374 type Code       = FCode ()
 375
 376 instance Monad FCode where
 377         (>>=) = thenFC
 378         return = returnFC
 379
 380 {-# INLINE thenC #-}
 381 {-# INLINE thenFC #-}
 382 {-# INLINE returnFC #-}
 383 \end{code}
 384 The Abstract~C is not in the environment so as to improve strictness.
 385
 386 \begin{code}
 387 initC :: DynFlags -> Module -> FCode a -> IO a
 388
 389 initC dflags mod (FCode code)
 390   = do  { uniqs <- mkSplitUniqSupply 'c'
 391         ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
 392               (res, _) -> return res
 393         }
 394
 395 returnFC :: a -> FCode a
 396 returnFC val = FCode (\_ state -> (val, state))
 397 \end{code}
 398
 399 \begin{code}
 400 thenC :: Code -> FCode a -> FCode a
 401 thenC (FCode m) (FCode k) =
 402         FCode (\info_down state -> let (_,new_state) = m info_down state in
 403                 k info_down new_state)
 404
 405 listCs :: [Code] -> Code
 406 listCs [] = return ()
 407 listCs (fc:fcs) = do
 408         fc
 409         listCs fcs
 410
 411 mapCs :: (a -> Code) -> [a] -> Code
 412 mapCs = mapM_
 413 \end{code}
 414
 415 \begin{code}
 416 thenFC  :: FCode a -> (a -> FCode c) -> FCode c
 417 thenFC (FCode m) k = FCode (
 418         \info_down state ->
 419                 let
 420                         (m_result, new_state) = m info_down state
 421                         (FCode kcode) = k m_result
 422                 in
 423                         kcode info_down new_state
 424         )
 425
 426 listFCs :: [FCode a] -> FCode [a]
 427 listFCs = sequence
 428
 429 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
 430 mapFCs = mapM
 431 \end{code}
 432
 433 And the knot-tying combinator:
 434 \begin{code}
 435 fixC :: (a -> FCode a) -> FCode a
 436 fixC fcode = FCode (
 437         \info_down state ->
 438                 let
 439                         FCode fc = fcode v
 440                         result@(v,_) = fc info_down state
 441                         --          ^--------^
 442                 in
 443                         result
 444         )
 445
 446 fixC_ :: (a -> FCode a) -> FCode ()
 447 fixC_ fcode = fixC fcode >> return ()
 448 \end{code}
 449
 450 %************************************************************************
 451 %*                                                                      *
 452         Operators for getting and setting the state and "info_down".
 453
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 \begin{code}
 458 getState :: FCode CgState
 459 getState = FCode $ \_ state -> (state,state)
 460
 461 setState :: CgState -> FCode ()
 462 setState state = FCode $ \_ _ -> ((),state)
 463
 464 getStkUsage :: FCode StackUsage
 465 getStkUsage = do
 466         state <- getState
 467         return $ cgs_stk_usg state
 468
 469 setStkUsage :: StackUsage -> Code
 470 setStkUsage new_stk_usg = do
 471         state <- getState
 472         setState $ state {cgs_stk_usg = new_stk_usg}
 473
 474 getHpUsage :: FCode HeapUsage
 475 getHpUsage = do
 476         state <- getState
 477         return $ cgs_hp_usg state
 478
 479 setHpUsage :: HeapUsage -> Code
 480 setHpUsage new_hp_usg = do
 481         state <- getState
 482         setState $ state {cgs_hp_usg = new_hp_usg}
 483
 484 getBinds :: FCode CgBindings
 485 getBinds = do
 486         state <- getState
 487         return $ cgs_binds state
 488
 489 setBinds :: CgBindings -> FCode ()
 490 setBinds new_binds = do
 491         state <- getState
 492         setState $ state {cgs_binds = new_binds}
 493
 494 getStaticBinds :: FCode CgBindings
 495 getStaticBinds = do
 496         info  <- getInfoDown
 497         return (cgd_statics info)
 498
 499 withState :: FCode a -> CgState -> FCode (a,CgState)
 500 withState (FCode fcode) newstate = FCode $ \info_down state ->
 501         let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
 502
 503 newUniqSupply :: FCode UniqSupply
 504 newUniqSupply = do
 505         state <- getState
 506         let (us1, us2) = splitUniqSupply (cgs_uniqs state)
 507         setState $ state { cgs_uniqs = us1 }
 508         return us2
 509
 510 newUnique :: FCode Unique
 511 newUnique = do
 512         us <- newUniqSupply
 513         return (uniqFromSupply us)
 514
 515 ------------------
 516 getInfoDown :: FCode CgInfoDownwards
 517 getInfoDown = FCode $ \info_down state -> (info_down,state)
 518
 519 getDynFlags :: FCode DynFlags
 520 getDynFlags = liftM cgd_dflags getInfoDown
 521
 522 getThisPackage :: FCode PackageId
 523 getThisPackage = liftM thisPackage getDynFlags
 524
 525 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 526 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
 527
 528 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
 529 doFCode (FCode fcode) info_down state = fcode info_down state
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535                 Forking
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
 540 fresh environment, except that:
 541         - compilation info and statics are passed in unchanged.
 542 The current environment is passed on completely unaltered, except that
 543 abstract C from the fork is incorporated.
 544
 545 @forkProc@ takes a code and compiles it in the current environment,
 546 returning the basic blocks thus constructed.  The current environment
 547 is passed on completely unchanged.  It is pretty similar to
 548 @getBlocks@, except that the latter does affect the environment.
 549
 550 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
 551 from the current bindings, but which is otherwise freshly initialised.
 552 The Abstract~C returned is attached to the current state, but the
 553 bindings and usage information is otherwise unchanged.
 554
 555 \begin{code}
 556 forkClosureBody :: Code -> Code
 557 forkClosureBody body_code
 558   = do  { info <- getInfoDown
 559         ; us   <- newUniqSupply
 560         ; state <- getState
 561         ; let   body_info_down = info { cgd_eob = initEobInfo }
 562                 ((),fork_state) = doFCode body_code body_info_down
 563                                           (initCgState us)
 564         ; ASSERT( isNilOL (cgs_stmts fork_state) )
 565           setState $ state `addCodeBlocksFrom` fork_state }
 566
 567 forkStatics :: FCode a -> FCode a
 568 forkStatics body_code
 569   = do  { info  <- getInfoDown
 570         ; us    <- newUniqSupply
 571         ; state <- getState
 572         ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
 573                                        cgd_eob     = initEobInfo }
 574                 (result, fork_state_out) = doFCode body_code rhs_info_down
 575                                                    (initCgState us)
 576         ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
 577           setState (state `addCodeBlocksFrom` fork_state_out)
 578         ; return result }
 579
 580 forkProc :: Code -> FCode CgStmts
 581 forkProc body_code
 582   = do  { info_down <- getInfoDown
 583         ; us    <- newUniqSupply
 584         ; state <- getState
 585         ; let   fork_state_in = (initCgState us)
 586                                         { cgs_binds   = cgs_binds state,
 587                                           cgs_stk_usg = cgs_stk_usg state,
 588                                           cgs_hp_usg  = cgs_hp_usg state }
 589                         -- ToDo: is the hp usage necesary?
 590                 (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
 591                                                       info_down fork_state_in
 592         ; setState $ state `stateIncUsageEval` fork_state_out
 593         ; return code_blks }
 594
 595 codeOnly :: Code -> Code
 596 -- Emit any code from the inner thing into the outer thing
 597 -- Do not affect anything else in the outer state
 598 -- Used in almost-circular code to prevent false loop dependencies
 599 codeOnly body_code
 600   = do  { info_down <- getInfoDown
 601         ; us   <- newUniqSupply
 602         ; state <- getState
 603         ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
 604                                                    cgs_stk_usg = cgs_stk_usg state,
 605                                                    cgs_hp_usg  = cgs_hp_usg state }
 606                 ((), fork_state_out) = doFCode body_code info_down fork_state_in
 607         ; setState $ state `addCodeBlocksFrom` fork_state_out }
 608 \end{code}
 609
 610 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
 611 an fcode for the default case $d$, and compiles each in the current
 612 environment.  The current environment is passed on unmodified, except
 613 that
 614         - the worst stack high-water mark is incorporated
 615         - the virtual Hp is moved on to the worst virtual Hp for the branches
 616
 617 \begin{code}
 618 forkAlts :: [FCode a] -> FCode [a]
 619
 620 forkAlts branch_fcodes
 621   = do  { info_down <- getInfoDown
 622         ; us <- newUniqSupply
 623         ; state <- getState
 624         ; let compile us branch
 625                 = (us2, doFCode branch info_down branch_state)
 626                 where
 627                   (us1,us2) = splitUniqSupply us
 628                   branch_state = (initCgState us1) {
 629                                         cgs_binds   = cgs_binds state,
 630                                         cgs_stk_usg = cgs_stk_usg state,
 631                                         cgs_hp_usg  = cgs_hp_usg state }
 632
 633               (_us, results) = mapAccumL compile us branch_fcodes
 634               (branch_results, branch_out_states) = unzip results
 635         ; setState $ foldl stateIncUsage state branch_out_states
 636                 -- NB foldl.  state is the *left* argument to stateIncUsage
 637         ; return branch_results }
 638 \end{code}
 639
 640 @forkEval@ takes two blocks of code.
 641
 642    -  The first meddles with the environment to set it up as expected by
 643       the alternatives of a @case@ which does an eval (or gc-possible primop).
 644    -  The second block is the code for the alternatives.
 645       (plus info for semi-tagging purposes)
 646
 647 @forkEval@ picks up the virtual stack pointer and returns a suitable
 648 @EndOfBlockInfo@ for the caller to use, together with whatever value
 649 is returned by the second block.
 650
 651 It uses @initEnvForAlternatives@ to initialise the environment, and
 652 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
 653 usage.
 654
 655 \begin{code}
 656 forkEval :: EndOfBlockInfo              -- For the body
 657          -> Code                        -- Code to set environment
 658          -> FCode Sequel                -- Semi-tagging info to store
 659          -> FCode EndOfBlockInfo        -- The new end of block info
 660
 661 forkEval body_eob_info env_code body_code
 662   = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
 663         ; returnFC (EndOfBlockInfo v sequel) }
 664
 665 forkEvalHelp :: EndOfBlockInfo  -- For the body
 666              -> Code            -- Code to set environment
 667              -> FCode a         -- The code to do after the eval
 668              -> FCode (VirtualSpOffset, -- Sp
 669                        a)               -- Result of the FCode
 670         -- A disturbingly complicated function
 671 forkEvalHelp body_eob_info env_code body_code
 672   = do  { info_down <- getInfoDown
 673         ; us   <- newUniqSupply
 674         ; state <- getState
 675         ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
 676               ; (_, env_state) = doFCode env_code info_down_for_body
 677                                          (state {cgs_uniqs = us})
 678               ; state_for_body = (initCgState (cgs_uniqs env_state))
 679                                         { cgs_binds   = binds_for_body,
 680                                           cgs_stk_usg = stk_usg_for_body }
 681               ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
 682               ; stk_usg_from_env = cgs_stk_usg env_state
 683               ; virtSp_from_env  = virtSp stk_usg_from_env
 684               ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
 685                                                      hwSp   = virtSp_from_env}
 686               ; (value_returned, state_at_end_return)
 687                         = doFCode body_code info_down_for_body state_for_body
 688           }
 689         ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
 690                  -- The code coming back should consist only of nested declarations,
 691                  -- notably of the return vector!
 692           setState $ state `stateIncUsageEval` state_at_end_return
 693         ; return (virtSp_from_env, value_returned) }
 694
 695
 696 -- ----------------------------------------------------------------------------
 697 -- Combinators for emitting code
 698
 699 nopC :: Code
 700 nopC = return ()
 701
 702 whenC :: Bool -> Code -> Code
 703 whenC True  code = code
 704 whenC False _    = nopC
 705
 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 $ BlockId 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 args blocks
 748   = do  { let proc_block = CmmProc info lbl args (ListGraph 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 -- Return a single Cmm which may be split from other Cmms by
 762 -- object splitting (at a later stage)
 763 getCmm code
 764   = do  { state1 <- getState
 765         ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
 766         ; setState $ state2 { cgs_tops = cgs_tops state1 }
 767         ; return (Cmm (fromOL (cgs_tops state2)))
 768         }
 769
 770 -- ----------------------------------------------------------------------------
 771 -- CgStmts
 772
 773 -- These functions deal in terms of CgStmts, which is an abstract type
 774 -- representing the code in the current proc.
 775
 776
 777 -- emit CgStmts into the current instruction stream
 778 emitCgStmts :: CgStmts -> Code
 779 emitCgStmts stmts
 780   = do  { state <- getState
 781         ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
 782
 783 -- emit CgStmts outside the current instruction stream, and return a label
 784 forkCgStmts :: CgStmts -> FCode BlockId
 785 forkCgStmts stmts
 786   = do  { id <- newLabelC
 787         ; emitCgStmt (CgFork id stmts)
 788         ; return id
 789         }
 790
 791 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
 792 cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
 793 cgStmtsToBlocks stmts
 794   = do  { id <- newLabelC
 795         ; return (flattenCgStmts id stmts)
 796         }
 797
 798 -- collect the code emitted by an FCode computation
 799 getCgStmts' :: FCode a -> FCode (a, CgStmts)
 800 getCgStmts' fcode
 801   = do  { state1 <- getState
 802         ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
 803         ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
 804         ; return (a, cgs_stmts state2) }
 805
 806 getCgStmts :: FCode a -> FCode CgStmts
 807 getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }
 808
 809 -- Simple ways to construct CgStmts:
 810 noCgStmts :: CgStmts
 811 noCgStmts = nilOL
 812
 813 oneCgStmt :: CmmStmt -> CgStmts
 814 oneCgStmt stmt = unitOL (CgStmt stmt)
 815
 816 consCgStmt :: CmmStmt -> CgStmts -> CgStmts
 817 consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
 818
 819 -- ----------------------------------------------------------------------------
 820 -- Get the current module name
 821
 822 getModuleName :: FCode Module
 823 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
 824
 825 -- ----------------------------------------------------------------------------
 826 -- Get/set the end-of-block info
 827
 828 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
 829 setEndOfBlockInfo eob_info code = do
 830         info  <- getInfoDown
 831         withInfoDown code (info {cgd_eob = eob_info})
 832
 833 getEndOfBlockInfo :: FCode EndOfBlockInfo
 834 getEndOfBlockInfo = do
 835         info <- getInfoDown
 836         return (cgd_eob info)
 837
 838 -- ----------------------------------------------------------------------------
 839 -- Get/set the current SRT label
 840
 841 -- There is just one SRT for each top level binding; all the nested
 842 -- bindings use sub-sections of this SRT.  The label is passed down to
 843 -- the nested bindings via the monad.
 844
 845 getSRTLabel :: FCode CLabel     -- Used only by cgPanic
 846 getSRTLabel = do info  <- getInfoDown
 847                  return (cgd_srt_lbl info)
 848
 849 setSRTLabel :: CLabel -> FCode a -> FCode a
 850 setSRTLabel srt_lbl code
 851   = do  info <- getInfoDown
 852         withInfoDown code (info { cgd_srt_lbl = srt_lbl})
 853
 854 getSRT :: FCode SRT
 855 getSRT = do info <- getInfoDown
 856             return (cgd_srt info)
 857
 858 setSRT :: SRT -> FCode a -> FCode a
 859 setSRT srt code
 860   = do info <- getInfoDown
 861        withInfoDown code (info { cgd_srt = srt})
 862
 863 -- ----------------------------------------------------------------------------
 864 -- Get/set the current ticky counter label
 865
 866 getTickyCtrLabel :: FCode CLabel
 867 getTickyCtrLabel = do
 868         info <- getInfoDown
 869         return (cgd_ticky info)
 870
 871 setTickyCtrLabel :: CLabel -> Code -> Code
 872 setTickyCtrLabel ticky code = do
 873         info <- getInfoDown
 874         withInfoDown code (info {cgd_ticky = ticky})
 875 \end{code}