compiler/codeGen/CgMonad.lhs

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