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