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