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