compiler/codeGen/CgMonad.lhs

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