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

17
        initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
dterei's avatar
dterei committed
18 19 20
        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}
382 383 384
initC :: IO CgState
initC  = do { uniqs <- mkSplitUniqSupply 'c'
            ; return (initCgState uniqs) }
385

386 387
runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
388 389

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

504 505 506
getDynFlags :: FCode DynFlags
getDynFlags = liftM cgd_dflags getInfoDown

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

rje's avatar
rje committed
510 511 512 513 514
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
515 516
\end{code}

rje's avatar
rje committed
517

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

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

530 531 532 533
@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.
534 535 536 537 538 539 540 541

@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
542
forkClosureBody body_code
dterei's avatar
dterei committed
543 544 545 546 547 548 549 550 551
  = 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 }
        
552
forkStatics :: FCode a -> FCode a
553
forkStatics body_code
dterei's avatar
dterei committed
554 555 556 557 558 559 560 561 562 563
  = 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 }
564 565 566

forkProc :: Code -> FCode CgStmts
forkProc body_code
dterei's avatar
dterei committed
567 568 569 570 571 572 573 574 575 576 577 578
  = 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 }
579 580 581 582

-- 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
583
codeOnly :: Code -> Code
584
codeOnly body_code
dterei's avatar
dterei committed
585 586 587 588 589 590 591 592
  = 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 }
593 594 595 596 597 598
\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
599 600
        - the worst stack high-water mark is incorporated
        - the virtual Hp is moved on to the worst virtual Hp for the branches
601 602

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

forkAlts branch_fcodes
dterei's avatar
dterei committed
606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622
  = 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 }
623 624 625
\end{code}

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

   -  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.
635 636 637 638 639 640 641

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
642 643 644
         -> Code                        -- Code to set environment
         -> FCode Sequel                -- Semi-tagging info to store
         -> FCode EndOfBlockInfo        -- The new end of block info
645

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

650
forkEvalHelp :: EndOfBlockInfo  -- For the body
dterei's avatar
dterei committed
651 652 653 654 655
             -> 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
656
forkEvalHelp body_eob_info env_code body_code
dterei's avatar
dterei committed
657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
  = 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) }
679 680


681 682 683
-- ----------------------------------------------------------------------------
-- Combinators for emitting code

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

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

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

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

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

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

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
722 723 724
  = do  { state <- getState
        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
        }
725

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

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

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

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

-- ----------------------------------------------------------------------------
-- 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
766 767
  = do  { state <- getState
        ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }
768 769 770 771 772

-- 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
773 774 775
        ; emitCgStmt (CgFork id stmts)
        ; return id
        }
776 777 778 779 780

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

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

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
807

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

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

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

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

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

827 828 829
-- 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.
830

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

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

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})
848 849 850

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

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

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