CgMonad.lhs 30.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3 4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
5 6 7 8 9 10
\section[CgMonad]{The code generation monad}

See the beginning of the top-level @CodeGen@ module, to see how this
monadic stuff fits into the Big Picture.

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
11

12
{-# LANGUAGE BangPatterns #-}
13
module CgMonad (
dterei's avatar
dterei committed
14 15
        Code,
        FCode,
16

dterei's avatar
dterei committed
17 18 19 20
        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
        returnFC, fixC, fixC_, checkedAbsC, 
        stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
        newUnique, newUniqSupply, 
21

dterei's avatar
dterei committed
22 23 24
        CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
        getCgStmts', getCgStmts,
        noCgStmts, oneCgStmt, consCgStmt,
25

dterei's avatar
dterei committed
26 27
        getCmm,
        emitDecl, emitProc, emitSimpleProc,
28

dterei's avatar
dterei committed
29 30 31 32
        forkLabelledCode,
        forkClosureBody, forkStatics, forkAlts, forkEval,
        forkEvalHelp, forkProc, codeOnly,
        SemiTaggingStuff, ConTagZ,
33

dterei's avatar
dterei committed
34 35
        EndOfBlockInfo(..),
        setEndOfBlockInfo, getEndOfBlockInfo,
36

dterei's avatar
dterei committed
37 38 39
        setSRT, getSRT,
        setSRTLabel, getSRTLabel, 
        setTickyCtrLabel, getTickyCtrLabel,
40

dterei's avatar
dterei committed
41 42 43 44 45
        StackUsage(..), HeapUsage(..),
        VirtualSpOffset, VirtualHpOffset,
        initStkUsage, initHpUsage,
        getHpUsage,  setHpUsage,
        heapHWM,
46

dterei's avatar
dterei committed
47
        getModuleName,
48

dterei's avatar
dterei committed
49
        Sequel(..),
50

dterei's avatar
dterei committed
51 52
        -- ideally we wouldn't export these, but some other modules access internal state
        getState, setState, getInfoDown, getDynFlags, getThisPackage, 
rje's avatar
rje committed
53

dterei's avatar
dterei committed
54 55 56
        -- more localised access to monad state 
        getStkUsage, setStkUsage,
        getBinds, setBinds, getStaticBinds,
rje's avatar
rje committed
57

dterei's avatar
dterei committed
58 59
        -- out of general friendliness, we also export ...
        CgInfoDownwards(..), CgState(..)
60 61
    ) where

62
#include "HsVersions.h"
sof's avatar
sof committed
63

64
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
65

Simon Marlow's avatar
Simon Marlow committed
66
import DynFlags
67
import BlockId
68 69
import OldCmm
import OldCmmUtils
70
import CLabel
71
import StgSyn (SRT)
72
import ClosureInfo( ConTagZ )
Simon Marlow's avatar
Simon Marlow committed
73 74 75
import SMRep
import Module
import Id
76
import VarEnv
77
import OrdList
Simon Marlow's avatar
Simon Marlow committed
78 79
import Unique
import UniqSupply
80
import Outputable
81

Simon Marlow's avatar
Simon Marlow committed
82
import Control.Monad
83
import Data.List
84

dterei's avatar
dterei committed
85
infixr 9 `thenC`
86 87 88 89
infixr 9 `thenFC`
\end{code}

%************************************************************************
dterei's avatar
dterei committed
90
%*                                                                      *
91
\subsection[CgMonad-environment]{Stuff for manipulating environments}
dterei's avatar
dterei committed
92
%*                                                                      *
93 94 95 96 97 98 99
%************************************************************************

This monadery has some information that it only passes {\em
downwards}, as well as some ``state'' which is modified as we go
along.

\begin{code}
dterei's avatar
dterei committed
100
data CgInfoDownwards    -- information only passed *downwards* by the monad
101
  = MkCgInfoDown {
dterei's avatar
dterei committed
102 103 104 105 106 107 108
        cgd_dflags  :: DynFlags,
        cgd_mod     :: Module,          -- Module being compiled
        cgd_statics :: CgBindings,      -- [Id -> info] : static environment
        cgd_srt_lbl :: CLabel,          -- label of the current SRT
        cgd_srt     :: SRT,             -- the current SRT
        cgd_ticky   :: CLabel,          -- current destination for ticky counts
        cgd_eob     :: EndOfBlockInfo   -- Info for stuff to do at end of basic block:
109 110
  }

Simon Marlow's avatar
Simon Marlow committed
111 112
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
dterei's avatar
dterei committed
113 114 115 116 117 118 119
  = MkCgInfoDown {      cgd_dflags  = dflags,
                        cgd_mod     = mod,
                        cgd_statics = emptyVarEnv,
                        cgd_srt_lbl = error "initC: srt_lbl",
                        cgd_srt     = error "initC: srt",
                        cgd_ticky   = mkTopTickyCtrLabel,
                        cgd_eob     = initEobInfo }
120

121
data CgState
122
  = MkCgState {
dterei's avatar
dterei committed
123
     cgs_stmts :: OrdList CgStmt, -- Current proc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
124
     cgs_tops  :: OrdList CmmDecl,
dterei's avatar
dterei committed
125 126 127
        -- Other procedures and data blocks in this compilation unit
        -- Both the latter two are ordered only so that we can 
        -- reduce forward references, when it's easy to do so
128
     
dterei's avatar
dterei committed
129 130 131
     cgs_binds :: CgBindings,     -- [Id -> info] : *local* bindings environment
                                  -- Bindings for top-level things are given in
                                  -- the info-down part
132 133 134 135 136 137 138 139 140
     
     cgs_stk_usg :: StackUsage,
     cgs_hp_usg  :: HeapUsage,
     
     cgs_uniqs :: UniqSupply }

initCgState :: UniqSupply -> CgState
initCgState uniqs
  = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
dterei's avatar
dterei committed
141 142 143 144
                cgs_binds = emptyVarEnv, 
                cgs_stk_usg = initStkUsage, 
                cgs_hp_usg = initHpUsage,
                cgs_uniqs = uniqs }
145 146
\end{code}

147 148 149
@EndOfBlockInfo@ tells what to do at the end of this block of code or,
if the expression is a @case@, what to do at the end of each
alternative.
150 151 152 153

\begin{code}
data EndOfBlockInfo
  = EndOfBlockInfo
dterei's avatar
dterei committed
154 155 156 157 158 159 160
        VirtualSpOffset   -- Args Sp: trim the stack to this point at a
                          -- return; push arguments starting just
                          -- above this point on a tail call.
                          
                          -- This is therefore the stk ptr as seen
                          -- by a case alternative.
        Sequel
161

Ian Lynagh's avatar
Ian Lynagh committed
162
initEobInfo :: EndOfBlockInfo
163
initEobInfo = EndOfBlockInfo 0 OnStack
164 165 166 167 168 169 170 171
\end{code}

Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
that it must survive stack pointer adjustments at the end of the
block.

\begin{code}
data Sequel
dterei's avatar
dterei committed
172
  = OnStack          -- Continuation is on the stack
173

174
  | CaseAlts
dterei's avatar
dterei committed
175 176 177 178
          CLabel     -- Jump to this; if the continuation is for a vectored
                     -- case this might be the label of a return vector
          SemiTaggingStuff
          Id          -- The case binder, only used to see if it's dead
179

180
type SemiTaggingStuff
dterei's avatar
dterei committed
181 182 183
  = Maybe                   -- Maybe we don't have any semi-tagging stuff...
     ([(ConTagZ, CmmLit)],  -- Alternatives
      CmmLit)               -- Default (will be a can't happen RTS label if can't happen)
184 185

-- The case branch is executed only from a successful semitagging
186 187 188
-- venture, when a case has looked at a variable, found that it's
-- evaluated, and wants to load up the contents and go to the join
-- point.
189 190 191
\end{code}

%************************************************************************
dterei's avatar
dterei committed
192 193 194
%*                                                                      *
                CgStmt type
%*                                                                      *
195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
%************************************************************************

The CgStmts type is what the code generator outputs: it is a tree of
statements, including in-line labels.  The job of flattenCgStmts is to
turn this into a list of basic blocks, each of which ends in a jump
statement (either a local branch or a non-local jump).

\begin{code}
type CgStmts = OrdList CgStmt

data CgStmt
  = CgStmt  CmmStmt
  | CgLabel BlockId
  | CgFork  BlockId CgStmts

flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
flattenCgStmts id stmts = 
dterei's avatar
dterei committed
212 213 214
        case flatten (fromOL stmts) of
          ([],blocks)    -> blocks
          (block,blocks) -> BasicBlock id block : blocks
215 216 217 218 219 220 221 222
 where
  flatten [] = ([],[])

  -- A label at the end of a function or fork: this label must not be reachable,
  -- but it might be referred to from another BB that also isn't reachable.
  -- Eliminating these has to be done with a dead-code analysis.  For now,
  -- we just make it into a well-formed block by adding a recursive jump.
  flatten [CgLabel id]
223
    = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
224 225 226 227 228 229

  -- A jump/branch: throw away all the code up to the next label, because
  -- it is unreachable.  Be careful to keep forks that we find on the way.
  flatten (CgStmt stmt : stmts)
    | isJump stmt
    = case dropWhile isOrdinaryStmt stmts of
dterei's avatar
dterei committed
230 231 232 233 234 235
        []                     -> ( [stmt], [] )
        [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
        (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
            where (block,blocks) = flatten stmts
        (CgFork fork_id stmts : ss) -> 
           flatten (CgFork fork_id stmts : CgStmt stmt : ss)
236
        (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
237 238

  flatten (s:ss) = 
dterei's avatar
dterei committed
239 240 241 242 243 244
        case s of
          CgStmt stmt -> (stmt:block,blocks)
          CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
          CgFork fork_id stmts -> 
                (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
                where (fork_block, fork_blocks) = flatten (fromOL stmts)
245 246
    where (block,blocks) = flatten ss

Ian Lynagh's avatar
Ian Lynagh committed
247
isJump :: CmmStmt -> Bool
dterei's avatar
dterei committed
248 249
isJump (CmmJump   _ _) = True
isJump (CmmBranch _  ) = True
250
isJump (CmmSwitch _ _) = True
dterei's avatar
dterei committed
251 252
isJump (CmmReturn _  ) = True
isJump _               = False
253

Ian Lynagh's avatar
Ian Lynagh committed
254
isOrdinaryStmt :: CgStmt -> Bool
255
isOrdinaryStmt (CgStmt _) = True
dterei's avatar
dterei committed
256
isOrdinaryStmt _          = False
257 258 259
\end{code}

%************************************************************************
dterei's avatar
dterei committed
260 261 262
%*                                                                      *
                Stack and heap models
%*                                                                      *
263
%************************************************************************
264

265
\begin{code}
dterei's avatar
dterei committed
266 267
type VirtualHpOffset = WordOff  -- Both are in
type VirtualSpOffset = WordOff  -- units of words
268 269 270

data StackUsage 
  = StackUsage {
dterei's avatar
dterei committed
271 272
        virtSp :: VirtualSpOffset,
                -- Virtual offset of topmost allocated slot
273

dterei's avatar
dterei committed
274 275 276 277 278
        frameSp :: VirtualSpOffset,
                -- Virtual offset of the return address of the enclosing frame.
                -- This RA describes the liveness/pointedness of
                -- all the stack from frameSp downwards
                -- INVARIANT: less than or equal to virtSp
279

dterei's avatar
dterei committed
280 281 282 283
         freeStk :: [VirtualSpOffset], 
                -- List of free slots, in *increasing* order
                -- INVARIANT: all <= virtSp
                -- All slots <= virtSp are taken except these ones
284

dterei's avatar
dterei committed
285 286
         realSp :: VirtualSpOffset,     
                -- Virtual offset of real stack pointer register
287

dterei's avatar
dterei committed
288 289
         hwSp :: VirtualSpOffset
  }                -- Highest value ever taken by virtSp
290

291
-- INVARIANT: The environment contains no Stable references to
dterei's avatar
dterei committed
292 293
--            stack slots below (lower offset) frameSp
--            It can contain volatile references to this area though.
294 295 296

data HeapUsage =
  HeapUsage {
dterei's avatar
dterei committed
297 298
        virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
        realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
299
  }
300
\end{code}
301

dterei's avatar
dterei committed
302 303 304 305 306
virtHp keeps track of the next location to allocate an object at. realHp keeps
track of what the Hp STG register actually points to. The reason these aren't
always the same is that we want to be able to move the realHp in one go when
allocating numerous objects to save having to bump it each time. virtHp we do
bump each time but it doesn't create corresponding inefficient machine code.
307 308

\begin{code}
309 310 311
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp
\end{code}
312

313 314 315 316 317
Initialisation.

\begin{code}
initStkUsage :: StackUsage
initStkUsage = StackUsage {
dterei's avatar
dterei committed
318 319 320 321 322 323 324
                        virtSp = 0,
                        frameSp = 0,
                        freeStk = [],
                        realSp = 0,
                        hwSp = 0
               }
                
325 326
initHpUsage :: HeapUsage 
initHpUsage = HeapUsage {
dterei's avatar
dterei committed
327 328 329
                virtHp = 0,
                realHp = 0
              }
330

dterei's avatar
dterei committed
331 332
-- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to
-- be the max of the high water marks of $arg1$ and $arg2$.
333
stateIncUsage :: CgState -> CgState -> CgState
334 335
stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
dterei's avatar
dterei committed
336
            cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
337
       `addCodeBlocksFrom` s2
dterei's avatar
dterei committed
338
                
339 340 341 342
stateIncUsageEval :: CgState -> CgState -> CgState
stateIncUsageEval s1 s2
     = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
       `addCodeBlocksFrom` s2
dterei's avatar
dterei committed
343 344 345
        -- We don't max the heap high-watermark because stateIncUsageEval is
        -- used only in forkEval, which in turn is only used for blocks of code
        -- which do their own heap-check.
346

347 348 349 350 351
addCodeBlocksFrom :: CgState -> CgState -> CgState
-- Add code blocks from the latter to the former
-- (The cgs_stmts will often be empty, but not always; see codeOnly)
s1 `addCodeBlocksFrom` s2
  = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
dterei's avatar
dterei committed
352
         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
353 354 355 356 357 358

maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }

maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
359 360 361
\end{code}

%************************************************************************
dterei's avatar
dterei committed
362 363 364
%*                                                                      *
                The FCode monad
%*                                                                      *
365 366 367
%************************************************************************

\begin{code}
rje's avatar
rje committed
368
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
369
type Code       = FCode ()
rje's avatar
rje committed
370 371

instance Monad FCode where
dterei's avatar
dterei committed
372 373
        (>>=) = thenFC
        return = returnFC
374 375 376 377 378 379 380 381

{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}
\end{code}
The Abstract~C is not in the environment so as to improve strictness.

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
382
initC :: DynFlags -> Module -> FCode a -> IO a
383

Simon Marlow's avatar
Simon Marlow committed
384
initC dflags mod (FCode code)
dterei's avatar
dterei committed
385 386 387 388
  = do  { uniqs <- mkSplitUniqSupply 'c'
        ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
              (res, _) -> return res
        }
389 390

returnFC :: a -> FCode a
Ian Lynagh's avatar
Ian Lynagh committed
391
returnFC val = FCode (\_ state -> (val, state))
392 393 394
\end{code}

\begin{code}
rje's avatar
rje committed
395 396
thenC :: Code -> FCode a -> FCode a
thenC (FCode m) (FCode k) = 
dterei's avatar
dterei committed
397 398
        FCode (\info_down state -> let (_,new_state) = m info_down state in 
                k info_down new_state)
399 400

listCs :: [Code] -> Code
rje's avatar
rje committed
401 402
listCs [] = return ()
listCs (fc:fcs) = do
dterei's avatar
dterei committed
403 404 405
        fc
        listCs fcs
        
406
mapCs :: (a -> Code) -> [a] -> Code
rje's avatar
rje committed
407
mapCs = mapM_
408

dterei's avatar
dterei committed
409
thenFC  :: FCode a -> (a -> FCode c) -> FCode c
rje's avatar
rje committed
410
thenFC (FCode m) k = FCode (
dterei's avatar
dterei committed
411 412
        \info_down state ->
                let 
413 414
                        (m_result, new_state) = m info_down state
                        (FCode kcode) = k m_result
dterei's avatar
dterei committed
415 416 417
                in 
                        kcode info_down new_state
        )
418 419

listFCs :: [FCode a] -> FCode [a]
rje's avatar
rje committed
420
listFCs = sequence
421 422

mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
rje's avatar
rje committed
423
mapFCs = mapM
424

dterei's avatar
dterei committed
425
-- | Knot-tying combinator for @FCode@
426
fixC :: (a -> FCode a) -> FCode a
dterei's avatar
dterei committed
427 428 429 430 431
fixC fcode = FCode $
        \info_down state -> 
                let FCode fc     = fcode v
                    result@(v,_) = fc info_down state
                in result
432

dterei's avatar
dterei committed
433
-- | Knot-tying combinator that throws result away
434 435
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
rje's avatar
rje committed
436 437
\end{code}

438
%************************************************************************
dterei's avatar
dterei committed
439 440 441
%*                                                                      *
        Operators for getting and setting the state and "info_down".
%*                                                                      *
442
%************************************************************************
rje's avatar
rje committed
443 444 445

\begin{code}
getState :: FCode CgState
Ian Lynagh's avatar
Ian Lynagh committed
446
getState = FCode $ \_ state -> (state,state)
rje's avatar
rje committed
447 448

setState :: CgState -> FCode ()
Ian Lynagh's avatar
Ian Lynagh committed
449
setState state = FCode $ \_ _ -> ((),state)
rje's avatar
rje committed
450

451 452
getStkUsage :: FCode StackUsage
getStkUsage = do
dterei's avatar
dterei committed
453 454
        state <- getState
        return $ cgs_stk_usg state
rje's avatar
rje committed
455

456 457
setStkUsage :: StackUsage -> Code
setStkUsage new_stk_usg = do
dterei's avatar
dterei committed
458 459
        state <- getState
        setState $ state {cgs_stk_usg = new_stk_usg}
460 461 462

getHpUsage :: FCode HeapUsage
getHpUsage = do
dterei's avatar
dterei committed
463 464 465
        state <- getState
        return $ cgs_hp_usg state
        
466 467
setHpUsage :: HeapUsage -> Code
setHpUsage new_hp_usg = do
dterei's avatar
dterei committed
468 469
        state <- getState
        setState $ state {cgs_hp_usg = new_hp_usg}
rje's avatar
rje committed
470 471 472

getBinds :: FCode CgBindings
getBinds = do
dterei's avatar
dterei committed
473 474 475
        state <- getState
        return $ cgs_binds state
        
rje's avatar
rje committed
476
setBinds :: CgBindings -> FCode ()
477
setBinds new_binds = do
dterei's avatar
dterei committed
478 479
        state <- getState
        setState $ state {cgs_binds = new_binds}
rje's avatar
rje committed
480 481 482

getStaticBinds :: FCode CgBindings
getStaticBinds = do
dterei's avatar
dterei committed
483 484
        info  <- getInfoDown
        return (cgd_statics info)
rje's avatar
rje committed
485 486 487

withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state -> 
dterei's avatar
dterei committed
488
        let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
rje's avatar
rje committed
489

490 491
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
dterei's avatar
dterei committed
492 493 494 495
        state <- getState
        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
        setState $ state { cgs_uniqs = us1 }
        return us2
496 497 498

newUnique :: FCode Unique
newUnique = do
dterei's avatar
dterei committed
499 500
        us <- newUniqSupply
        return (uniqFromSupply us)
501

rje's avatar
rje committed
502 503 504
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)

505 506
instance HasDynFlags FCode where
    getDynFlags = liftM cgd_dflags getInfoDown
507

Simon Marlow's avatar
Simon Marlow committed
508 509
getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags
510

rje's avatar
rje committed
511 512 513 514 515
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 

doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
doFCode (FCode fcode) info_down state = fcode info_down state
516 517
\end{code}

rje's avatar
rje committed
518

519
%************************************************************************
dterei's avatar
dterei committed
520 521 522
%*                                                                      *
                Forking
%*                                                                      *
523 524
%************************************************************************

525 526
@forkClosureBody@ takes a code, $c$, and compiles it in a completely
fresh environment, except that:
dterei's avatar
dterei committed
527
        - compilation info and statics are passed in unchanged.
528 529 530
The current environment is passed on completely unaltered, except that
abstract C from the fork is incorporated.

531 532 533 534
@forkProc@ takes a code and compiles it in the current environment,
returning the basic blocks thus constructed.  The current environment
is passed on completely unchanged.  It is pretty similar to
@getBlocks@, except that the latter does affect the environment.
535 536 537 538 539 540 541 542

@forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
from the current bindings, but which is otherwise freshly initialised.
The Abstract~C returned is attached to the current state, but the
bindings and usage information is otherwise unchanged.

\begin{code}
forkClosureBody :: Code -> Code
543
forkClosureBody body_code
dterei's avatar
dterei committed
544 545 546 547 548 549 550 551 552
  = do  { info <- getInfoDown
        ; us   <- newUniqSupply
        ; state <- getState
        ; let   body_info_down = info { cgd_eob = initEobInfo }
                ((),fork_state) = doFCode body_code body_info_down 
                                          (initCgState us)
        ; ASSERT( isNilOL (cgs_stmts fork_state) )
          setState $ state `addCodeBlocksFrom` fork_state }
        
553
forkStatics :: FCode a -> FCode a
554
forkStatics body_code
dterei's avatar
dterei committed
555 556 557 558 559 560 561 562 563 564
  = do  { info  <- getInfoDown
        ; us    <- newUniqSupply
        ; state <- getState
        ; let   rhs_info_down = info { cgd_statics = cgs_binds state,
                                       cgd_eob     = initEobInfo }
                (result, fork_state_out) = doFCode body_code rhs_info_down 
                                                   (initCgState us)
        ; ASSERT( isNilOL (cgs_stmts fork_state_out) )
          setState (state `addCodeBlocksFrom` fork_state_out)
        ; return result }
565 566 567

forkProc :: Code -> FCode CgStmts
forkProc body_code
dterei's avatar
dterei committed
568 569 570 571 572 573 574 575 576 577 578 579
  = do  { info_down <- getInfoDown
        ; us    <- newUniqSupply
        ; state <- getState
        ; let   fork_state_in = (initCgState us) 
                                        { cgs_binds   = cgs_binds state,
                                          cgs_stk_usg = cgs_stk_usg state,
                                          cgs_hp_usg  = cgs_hp_usg state }
                        -- ToDo: is the hp usage necesary?
                (code_blks, fork_state_out) = doFCode (getCgStmts body_code) 
                                                      info_down fork_state_in
        ; setState $ state `stateIncUsageEval` fork_state_out
        ; return code_blks }
580 581 582 583

-- Emit any code from the inner thing into the outer thing
-- Do not affect anything else in the outer state
-- Used in almost-circular code to prevent false loop dependencies
dterei's avatar
dterei committed
584
codeOnly :: Code -> Code
585
codeOnly body_code
dterei's avatar
dterei committed
586 587 588 589 590 591 592 593
  = do  { info_down <- getInfoDown
        ; us   <- newUniqSupply
        ; state <- getState
        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
                                                   cgs_stk_usg = cgs_stk_usg state,
                                                   cgs_hp_usg  = cgs_hp_usg state }
                ((), fork_state_out) = doFCode body_code info_down fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out }
594 595 596 597 598 599
\end{code}

@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
an fcode for the default case $d$, and compiles each in the current
environment.  The current environment is passed on unmodified, except
that
dterei's avatar
dterei committed
600 601
        - the worst stack high-water mark is incorporated
        - the virtual Hp is moved on to the worst virtual Hp for the branches
602 603

\begin{code}
604 605 606
forkAlts :: [FCode a] -> FCode [a]

forkAlts branch_fcodes
dterei's avatar
dterei committed
607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
  = do  { info_down <- getInfoDown
        ; us <- newUniqSupply
        ; state <- getState
        ; let compile us branch 
                = (us2, doFCode branch info_down branch_state)
                where
                  (us1,us2) = splitUniqSupply us
                  branch_state = (initCgState us1) {
                                        cgs_binds   = cgs_binds state,
                                        cgs_stk_usg = cgs_stk_usg state,
                                        cgs_hp_usg  = cgs_hp_usg state }

              (_us, results) = mapAccumL compile us branch_fcodes
              (branch_results, branch_out_states) = unzip results
        ; setState $ foldl stateIncUsage state branch_out_states
                -- NB foldl.  state is the *left* argument to stateIncUsage
        ; return branch_results }
624 625 626
\end{code}

@forkEval@ takes two blocks of code.
627 628 629 630 631 632 633 634 635

   -  The first meddles with the environment to set it up as expected by
      the alternatives of a @case@ which does an eval (or gc-possible primop).
   -  The second block is the code for the alternatives.
      (plus info for semi-tagging purposes)

@forkEval@ picks up the virtual stack pointer and returns a suitable
@EndOfBlockInfo@ for the caller to use, together with whatever value
is returned by the second block.
636 637 638 639 640 641 642

It uses @initEnvForAlternatives@ to initialise the environment, and
@stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
usage.

\begin{code}
forkEval :: EndOfBlockInfo              -- For the body
dterei's avatar
dterei committed
643 644 645
         -> Code                        -- Code to set environment
         -> FCode Sequel                -- Semi-tagging info to store
         -> FCode EndOfBlockInfo        -- The new end of block info
646

647
forkEval body_eob_info env_code body_code
648
  = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
dterei's avatar
dterei committed
649
        ; returnFC (EndOfBlockInfo v sequel) }
650

651
forkEvalHelp :: EndOfBlockInfo  -- For the body
dterei's avatar
dterei committed
652 653 654 655 656
             -> Code            -- Code to set environment
             -> FCode a         -- The code to do after the eval
             -> FCode (VirtualSpOffset, -- Sp
                       a)               -- Result of the FCode
        -- A disturbingly complicated function
657
forkEvalHelp body_eob_info env_code body_code
dterei's avatar
dterei committed
658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679
  = do  { info_down <- getInfoDown
        ; us   <- newUniqSupply
        ; state <- getState
        ; let { info_down_for_body = info_down {cgd_eob = body_eob_info}
              ; (_, env_state) = doFCode env_code info_down_for_body 
                                         (state {cgs_uniqs = us})
              ; state_for_body = (initCgState (cgs_uniqs env_state)) 
                                        { cgs_binds   = binds_for_body,
                                          cgs_stk_usg = stk_usg_for_body }
              ; binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
              ; stk_usg_from_env = cgs_stk_usg env_state
              ; virtSp_from_env  = virtSp stk_usg_from_env
              ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env,
                                                     hwSp   = virtSp_from_env}
              ; (value_returned, state_at_end_return)
                        = doFCode body_code info_down_for_body state_for_body           
          } 
        ; ASSERT( isNilOL (cgs_stmts state_at_end_return) )
                 -- The code coming back should consist only of nested declarations,
                 -- notably of the return vector!
          setState $ state `stateIncUsageEval` state_at_end_return
        ; return (virtSp_from_env, value_returned) }
680 681


682 683 684
-- ----------------------------------------------------------------------------
-- Combinators for emitting code

685
nopC :: Code
rje's avatar
rje committed
686
nopC = return ()
687

688 689
whenC :: Bool -> Code -> Code
whenC True  code = code
Ian Lynagh's avatar
Ian Lynagh committed
690
whenC False _    = nopC
691

692 693
-- Corresponds to 'emit' in new code generator with a smart constructor
-- from cmm/MkGraph.hs
694 695 696 697 698 699 700
stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)

labelC :: BlockId -> Code
labelC id = emitCgStmt (CgLabel id)

newLabelC :: FCode BlockId
701
newLabelC = do { u <- newUnique
702
               ; return $ mkBlockId u }
703 704

-- Emit code, eliminating no-ops
dterei's avatar
dterei committed
705
checkedAbsC :: CmmStmt -> Code
706
checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
dterei's avatar
dterei committed
707
                              else unitOL stmt)
708 709 710 711 712 713 714 715 716 717 718 719 720 721 722

stmtsC :: [CmmStmt] -> Code
stmtsC stmts = emitStmts (toOL stmts)

-- Emit code; no no-op checking
emitStmts :: CmmStmts -> Code
emitStmts stmts = emitCgStmts (fmap CgStmt stmts)

-- forkLabelledCode is for emitting a chunk of code with a label, outside
-- of the current instruction stream.
forkLabelledCode :: Code -> FCode BlockId
forkLabelledCode code = getCgStmts code >>= forkCgStmts

emitCgStmt :: CgStmt -> Code
emitCgStmt stmt
dterei's avatar
dterei committed
723 724 725
  = do  { state <- getState
        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
        }
726

Simon Peyton Jones's avatar
Simon Peyton Jones committed
727
emitDecl :: CmmDecl -> Code
728
emitDecl decl
dterei's avatar
dterei committed
729 730
  = do  { state <- getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
731

732
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
733 734
emitProc info lbl [] blocks
  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
dterei's avatar
dterei committed
735 736
        ; state <- getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
737
emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
738 739

-- Emit a procedure whose body is the specified code; no info table
dterei's avatar
dterei committed
740
emitSimpleProc :: CLabel -> Code -> Code
741
emitSimpleProc lbl code
dterei's avatar
dterei committed
742 743 744
  = do  { stmts <- getCgStmts code
        ; blks <- cgStmtsToBlocks stmts
        ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
745 746

-- Get all the CmmTops (there should be no stmts)
747 748
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
dterei's avatar
dterei committed
749
getCmm :: Code -> FCode CmmGroup
750
getCmm code 
dterei's avatar
dterei committed
751 752 753
  = do  { state1 <- getState
        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
        ; setState $ state2 { cgs_tops = cgs_tops state1 } 
754
        ; return (fromOL (cgs_tops state2))
755
        }
756 757 758 759 760 761 762 763 764 765 766

-- ----------------------------------------------------------------------------
-- CgStmts

-- These functions deal in terms of CgStmts, which is an abstract type
-- representing the code in the current proc.


-- emit CgStmts into the current instruction stream
emitCgStmts :: CgStmts -> Code
emitCgStmts stmts
dterei's avatar
dterei committed
767 768
  = do  { state <- getState
        ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
769 770 771 772 773

-- emit CgStmts outside the current instruction stream, and return a label
forkCgStmts :: CgStmts -> FCode BlockId
forkCgStmts stmts
  = do  { id <- newLabelC
dterei's avatar
dterei committed
774 775 776
        ; emitCgStmt (CgFork id stmts)
        ; return id
        }
777 778 779 780 781

-- turn CgStmts into [CmmBasicBlock], for making a new proc.
cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
cgStmtsToBlocks stmts
  = do  { id <- newLabelC
dterei's avatar
dterei committed
782 783
        ; return (flattenCgStmts id stmts)
        }       
784 785 786 787

-- collect the code emitted by an FCode computation
getCgStmts' :: FCode a -> FCode (a, CgStmts)
getCgStmts' fcode
dterei's avatar
dterei committed
788 789 790 791
  = do  { state1 <- getState
        ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
        ; return (a, cgs_stmts state2) }
792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807

getCgStmts :: FCode a -> FCode CgStmts
getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts }

-- Simple ways to construct CgStmts:
noCgStmts :: CgStmts
noCgStmts = nilOL

oneCgStmt :: CmmStmt -> CgStmts
oneCgStmt stmt = unitOL (CgStmt stmt)

consCgStmt :: CmmStmt -> CgStmts -> CgStmts
consCgStmt stmt stmts = CgStmt stmt `consOL` stmts

-- ----------------------------------------------------------------------------
-- Get the current module name
808

Simon Marlow's avatar
Simon Marlow committed
809 810
getModuleName :: FCode Module
getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
811 812 813

-- ----------------------------------------------------------------------------
-- Get/set the end-of-block info
814 815

setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
dterei's avatar
dterei committed
816 817 818
setEndOfBlockInfo eob_info code = do
        info  <- getInfoDown
        withInfoDown code (info {cgd_eob = eob_info})
819 820

getEndOfBlockInfo :: FCode EndOfBlockInfo
rje's avatar
rje committed
821
getEndOfBlockInfo = do
dterei's avatar
dterei committed
822 823
        info <- getInfoDown
        return (cgd_eob info)
824

825 826
-- ----------------------------------------------------------------------------
-- Get/set the current SRT label
827

828 829 830
-- There is just one SRT for each top level binding; all the nested
-- bindings use sub-sections of this SRT.  The label is passed down to
-- the nested bindings via the monad.
831

dterei's avatar
dterei committed
832
getSRTLabel :: FCode CLabel     -- Used only by cgPanic
833
getSRTLabel = do info  <- getInfoDown
dterei's avatar
dterei committed
834
                 return (cgd_srt_lbl info)
835

836
setSRTLabel :: CLabel -> FCode a -> FCode a
837
setSRTLabel srt_lbl code
838
  = do  info <- getInfoDown
dterei's avatar
dterei committed
839
        withInfoDown code (info { cgd_srt_lbl = srt_lbl})
840 841 842 843 844 845 846 847 848

getSRT :: FCode SRT
getSRT = do info <- getInfoDown
            return (cgd_srt info)

setSRT :: SRT -> FCode a -> FCode a
setSRT srt code
  = do info <- getInfoDown
       withInfoDown code (info { cgd_srt = srt})
849 850 851

-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label
852 853

getTickyCtrLabel :: FCode CLabel
rje's avatar
rje committed
854
getTickyCtrLabel = do
dterei's avatar
dterei committed
855 856
        info <- getInfoDown
        return (cgd_ticky info)
857 858

setTickyCtrLabel :: CLabel -> Code -> Code
rje's avatar
rje committed
859
setTickyCtrLabel ticky code = do
dterei's avatar
dterei committed
860 861
        info <- getInfoDown
        withInfoDown code (info {cgd_ticky = ticky})
862
\end{code}