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