StgCmmMonad.hs 26.4 KB
Newer Older
1
{-# LANGUAGE GADTs #-}
2 3 4 5 6 7 8 9
-----------------------------------------------------------------------------
--
-- Monad for Stg to C-- code generation
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
10 11 12 13 14 15 16
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

17 18 19
module StgCmmMonad (
	FCode,	-- type

20
        initC, runC, thenC, thenFC, listCs,
21
        returnFC, fixC,
22 23
	newUnique, newUniqSupply, 

24 25
        newLabelC, emitLabel,

26 27
        emit, emitDecl, emitProc,
        emitProcWithConvention, emitProcWithStackFrame,
28
        emitOutOfLine, emitAssign, emitStore, emitComment,
29

30
        getCmm, aGraphToGraph,
31 32
	getCodeR, getCode, getHeapUsage,

33
        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
34
        mkCall, mkCmmCall,
35 36

        forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
37 38 39

	ConTagZ,

40
        Sequel(..), ReturnKind(..),
41 42
	withSequel, getSequel,

43
        setTickyCtrLabel, getTickyCtrLabel,
44

45 46
	withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,

47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65
	HeapUsage(..), VirtualHpOffset,	initHpUsage,
	getHpUsage,  setHpUsage, heapHWM,
	setVirtHp, getVirtHp, setRealHp,

	getModuleName,

	-- ideally we wouldn't export these, but some other modules access internal state
	getState, setState, getInfoDown, getDynFlags, getThisPackage,

	-- more localised access to monad state	
	CgIdInfo(..), CgLoc(..),
	getBinds, setBinds, getStaticBinds,

	-- out of general friendliness, we also export ...
	CgInfoDownwards(..), CgState(..)	-- non-abstract
    ) where

#include "HsVersions.h"

66
import Cmm
67 68
import StgCmmClosure
import DynFlags
69
import Hoopl
70
import MkGraph
71 72 73 74 75 76 77 78 79
import BlockId
import CLabel
import SMRep
import Module
import Id
import VarEnv
import OrdList
import Unique
import UniqSupply
80
import FastString
81
import Outputable
82

83 84
import Control.Monad
import Data.List
85
import Prelude hiding( sequence, succ )
86 87 88 89 90 91 92
import qualified Prelude( sequence )

infixr 9 `thenC`	-- Right-associative!
infixr 9 `thenFC`


--------------------------------------------------------
93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
-- The FCode monad and its types
--
-- FCode is the monad plumbed through the Stg->Cmm code generator, and
-- the Cmm parser.  It contains the following things:
--
--  - A writer monad, collecting:
--    - code for the current function, in the form of a CmmAGraph.
--      The function "emit" appends more code to this.
--    - the top-level CmmDecls accumulated so far
--
--  - A state monad with:
--    - the local bindings in scope
--    - the current heap usage
--    - a UniqSupply
--
--  - A reader monad, for CgInfoDownwards, containing
--    - DynFlags,
--    - the current Module
--    - the static top-level environmnet
--    - the update-frame offset
--    - the ticky counter label
--    - the Sequel (the continuation to return to)


117 118
--------------------------------------------------------

119
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
120

121
instance Functor FCode where
122
  fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
123

124 125 126 127 128 129 130 131
instance Monad FCode where
	(>>=) = thenFC
	return = returnFC

{-# INLINE thenC #-}
{-# INLINE thenFC #-}
{-# INLINE returnFC #-}

132 133 134 135 136
initC :: IO CgState
initC  = do { uniqs <- mkSplitUniqSupply 'c'
            ; return (initCgState uniqs) }

runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
137
runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
138 139

returnFC :: a -> FCode a
140
returnFC val = FCode (\_info_down state -> (# val, state #))
141 142 143

thenC :: FCode () -> FCode a -> FCode a
thenC (FCode m) (FCode k) = 
144 145
        FCode $ \info_down state -> case m info_down state of
                                     (# _,new_state #) -> k info_down new_state
146 147 148 149 150 151 152

listCs :: [FCode ()] -> FCode ()
listCs [] = return ()
listCs (fc:fcs) = do
	fc
	listCs fcs
   	
153 154
thenFC  :: FCode a -> (a -> FCode c) -> FCode c
thenFC (FCode m) k = FCode $
155
	\info_down state ->
156 157 158 159
            case m info_down state of
              (# m_result, new_state #) ->
                 case k m_result of
                   FCode kcode -> kcode info_down new_state
160

161 162 163 164 165 166 167 168 169
fixC :: (a -> FCode a) -> FCode a
fixC fcode = FCode (
	\info_down state -> 
		let
                        (v,s) = doFCode (fcode v) info_down state
                in
                        (# v, s #)
	)

170 171 172 173 174 175 176 177 178 179
--------------------------------------------------------
--	The code generator environment
--------------------------------------------------------

-- This monadery has some information that it only passes 
-- *downwards*, as well as some ``state'' which is modified 
-- as we go along.

data CgInfoDownwards	-- information only passed *downwards* by the monad
  = MkCgInfoDown {
180 181 182
	cgd_dflags     :: DynFlags,
	cgd_mod        :: Module,	  -- Module being compiled
	cgd_statics    :: CgBindings,	  -- [Id -> info] : static environment
183
        cgd_updfr_off  :: UpdFrameOffset, -- Size of current update frame
184 185
	cgd_ticky      :: CLabel,	  -- Current destination for ticky counts
	cgd_sequel     :: Sequel	  -- What to do at end of basic block
186 187 188 189 190 191 192 193 194 195
  }

type CgBindings = IdEnv CgIdInfo

data CgIdInfo
  = CgIdInfo	
	{ cg_id :: Id	-- Id that this is the info for
			-- Can differ from the Id at occurrence sites by 
			-- virtue of being externalised, for splittable C
	, cg_lf  :: LambdaFormInfo 
196
	, cg_loc :: CgLoc		     -- CmmExpr for the *tagged* value
197
        , cg_tag :: {-# UNPACK #-} !DynTag   -- Cache for (lfDynTag cg_lf)
198
        }
199 200 201 202 203 204 205 206 207 208 209

data CgLoc
  = CmmLoc CmmExpr	-- A stable CmmExpr; that is, one not mentioning
			-- Hp, so that it remains valid across calls

  | LneLoc BlockId [LocalReg]  	   -- A join point
	-- A join point (= let-no-escape) should only 
	-- be tail-called, and in a saturated way.
	-- To tail-call it, assign to these locals, 
	-- and branch to the block id

Ian Lynagh's avatar
Ian Lynagh committed
210 211 212
instance Outputable CgIdInfo where
  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
    = ppr id <+> ptext (sLit "-->") <+> ppr loc
213

Ian Lynagh's avatar
Ian Lynagh committed
214 215 216
instance Outputable CgLoc where
  ppr (CmmLoc e)    = ptext (sLit "cmm") <+> ppr e
  ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
217 218 219 220 221 222 223 224 225 226


-- Sequel tells what to do with the result of this expression
data Sequel
  = Return Bool		  -- Return result(s) to continuation found on the stack
			  -- 	True <=> the continuation is update code (???)

  | AssignTo 
	[LocalReg]	-- Put result(s) in these regs and fall through
			-- 	NB: no void arguments here
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
                        --
        Bool            -- Should we adjust the heap pointer back to
                        -- recover space that's unused on this path?
                        -- We need to do this only if the expression
                        -- may allocate (e.g. it's a foreign call or
                        -- allocating primOp)

-- See Note [sharing continuations] below
data ReturnKind
  = AssignedDirectly
  | ReturnedTo BlockId ByteOff

-- Note [sharing continuations]
--
-- ReturnKind says how the expression being compiled returned its
-- results: either by assigning directly to the registers specified
-- by the Sequel, or by returning to a continuation that does the
-- assignments.  The point of this is we might be able to re-use the
-- continuation in a subsequent heap-check.  Consider:
--
--    case f x of z
--      True  -> <True code>
--      False -> <False code>
--
-- Naively we would generate
--
--    R2 = x   -- argument to f
--    Sp[young(L1)] = L1
--    call f returns to L1
--  L1:
--    z = R1
--    if (z & 1) then Ltrue else Lfalse
--  Ltrue:
--    Hp = Hp + 24
--    if (Hp > HpLim) then L4 else L7
--  L4:
--    HpAlloc = 24
--    goto L5
--  L5:
--    R1 = z
--    Sp[young(L6)] = L6
--    call stg_gc_unpt_r1 returns to L6
--  L6:
--    z = R1
--    goto L1
--  L7:
--    <True code>
--  Lfalse:
--    <False code>
--
-- We want the gc call in L4 to return to L1, and discard L6.  Note
-- that not only can we share L1 and L6, but the assignment of the
-- return address in L4 is unnecessary because the return address for
-- L1 is already on the stack.  We used to catch the sharing of L1 and
-- L6 in the common-block-eliminator, but not the unnecessary return
-- address assignment.
--
-- Since this case is so common I decided to make it more explicit and
-- robust by programming the sharing directly, rather than relying on
-- the common-block elimiantor to catch it.  This makes
-- common-block-elimianteion an optional optimisation, and furthermore
-- generates less code in the first place that we have to subsequently
-- clean up.
--
-- There are some rarer cases of common blocks that we don't catch
-- this way, but that's ok.  Common-block-elimation is still available
-- to catch them when optimisation is enabled.  Some examples are:
--
--   - when both the True and False branches do a heap check, we
--     can share the heap-check failure code L4a and maybe L4
--
--   - in a case-of-case, there might be multiple continuations that
--     we can common up.
--
-- It is always safe to use AssignedDirectly.  Expressions that jump
-- to the continuation from multiple places (e.g. case expressions)
-- fall back to AssignedDirectly.
--

306 307 308

initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
309 310 311
  = MkCgInfoDown {	cgd_dflags    = dflags,
			cgd_mod       = mod,
			cgd_statics   = emptyVarEnv,
312
                        cgd_updfr_off = initUpdFrameOff dflags,
313 314
			cgd_ticky     = mkTopTickyCtrLabel,
			cgd_sequel    = initSequel }
315 316 317 318

initSequel :: Sequel
initSequel = Return False

319 320
initUpdFrameOff :: DynFlags -> UpdFrameOffset
initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
321

322 323 324 325 326 327 328 329 330

--------------------------------------------------------
--	The code generator state
--------------------------------------------------------

data CgState
  = MkCgState {
     cgs_stmts :: CmmAGraph,	  -- Current procedure

Simon Peyton Jones's avatar
Simon Peyton Jones committed
331
     cgs_tops  :: OrdList CmmDecl,
332 333 334 335 336 337 338 339 340
	-- Other procedures and data blocks in this compilation unit
	-- Both are ordered only so that we can 
	-- reduce forward references, when it's easy to do so
     
     cgs_binds :: CgBindings,	-- [Id -> info] : *local* bindings environment
     				-- Bindings for top-level things are given in
				-- the info-down part

     cgs_hp_usg  :: HeapUsage,
341

342 343 344 345 346
     cgs_uniqs :: UniqSupply }

data HeapUsage =
  HeapUsage {
	virtHp :: VirtualHpOffset,	-- Virtual offset of highest-allocated word
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
347
	       	  			--   Incremented whenever we allocate
348
	realHp :: VirtualHpOffset	-- realHp: Virtual offset of real heap ptr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
349
	       	  			--   Used in instruction addressing modes
350 351 352 353
  }

type VirtualHpOffset = WordOff

354 355


356 357
initCgState :: UniqSupply -> CgState
initCgState uniqs
358 359 360 361
  = MkCgState { cgs_stmts      = mkNop, cgs_tops = nilOL,
		cgs_binds      = emptyVarEnv, 
		cgs_hp_usg     = initHpUsage,
		cgs_uniqs      = uniqs }
362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398

stateIncUsage :: CgState -> CgState -> CgState
-- stateIncUsage@ e1 e2 incorporates in e1 
-- the heap high water mark found in e2.
stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
       `addCodeBlocksFrom` s2
		
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 <*> cgs_stmts s2,
	 cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }


-- The heap high water mark is the larger of virtHp and hwHp.  The latter is
-- only records the high water marks of forked-off branches, so to find the
-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
-- virtHp never retreats!
-- 
-- Note Jan 04: ok, so why do we only look at the virtual Hp??

heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp

initHpUsage :: HeapUsage 
initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }

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

--------------------------------------------------------
-- Operators for getting and setting the state and "info_down".
--------------------------------------------------------

getState :: FCode CgState
399
getState = FCode $ \_info_down state -> (# state, state #)
400 401

setState :: CgState -> FCode ()
402
setState state = FCode $ \_info_down _ -> (# (), state #)
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445

getHpUsage :: FCode HeapUsage
getHpUsage = do
	state <- getState
	return $ cgs_hp_usg state
	
setHpUsage :: HeapUsage -> FCode ()
setHpUsage new_hp_usg = do
	state <- getState
	setState $ state {cgs_hp_usg = new_hp_usg}

setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp new_virtHp
  = do	{ hp_usage <- getHpUsage
	; setHpUsage (hp_usage {virtHp = new_virtHp}) }

getVirtHp :: FCode VirtualHpOffset
getVirtHp 
  = do	{ hp_usage <- getHpUsage
	; return (virtHp hp_usage) }

setRealHp ::  VirtualHpOffset -> FCode ()
setRealHp new_realHp
  = do	{ hp_usage <- getHpUsage
	; setHpUsage (hp_usage {realHp = new_realHp}) }

getBinds :: FCode CgBindings
getBinds = do
	state <- getState
	return $ cgs_binds state
	
setBinds :: CgBindings -> FCode ()
setBinds new_binds = do
	state <- getState
	setState $ state {cgs_binds = new_binds}

getStaticBinds :: FCode CgBindings
getStaticBinds = do
	info  <- getInfoDown
	return (cgd_statics info)

withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state -> 
446 447
  case fcode info_down newstate of
    (# retval, state2 #) -> (# (retval,state2), state #)
448 449 450 451 452 453 454 455 456 457 458 459 460 461 462

newUniqSupply :: FCode UniqSupply
newUniqSupply = do
	state <- getState
	let (us1, us2) = splitUniqSupply (cgs_uniqs state)
	setState $ state { cgs_uniqs = us1 }
	return us2

newUnique :: FCode Unique
newUnique = do
	us <- newUniqSupply
	return (uniqFromSupply us)

------------------
getInfoDown :: FCode CgInfoDownwards
463
getInfoDown = FCode $ \info_down state -> (# info_down,state #)
464

465 466
instance HasDynFlags FCode where
    getDynFlags = liftM cgd_dflags getInfoDown
467 468 469 470 471 472 473 474

getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags

withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 

doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
475 476 477
doFCode (FCode fcode) info_down state =
  case fcode info_down state of
    (# a, s #) -> ( a, s )
478 479 480 481 482 483 484 485 486 487

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

getModuleName :: FCode Module
getModuleName = do { info <- getInfoDown; return (cgd_mod info) }

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

488
withSequel :: Sequel -> FCode a -> FCode a
489 490 491 492 493 494 495 496
withSequel sequel code
  = do	{ info  <- getInfoDown
	; withInfoDown code (info {cgd_sequel = sequel }) }

getSequel :: FCode Sequel
getSequel = do  { info <- getInfoDown
		; return (cgd_sequel info) }

497 498 499 500 501 502 503 504 505 506
-- ----------------------------------------------------------------------------
-- Get/set the size of the update frame

-- We keep track of the size of the update frame so that we
-- can set the stack pointer to the proper address on return
-- (or tail call) from the closure.
-- There should be at most one update frame for each closure.
-- Note: I'm including the size of the original return address
-- in the size of the update frame -- hence the default case on `get'.

507
withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
508 509 510 511 512 513 514 515 516
withUpdFrameOff size code
  = do	{ info  <- getInfoDown
	; withInfoDown code (info {cgd_updfr_off = size }) }

getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff
  = do	{ info  <- getInfoDown
	; return $ cgd_updfr_off info }

517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546
-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label

getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
	info <- getInfoDown
	return (cgd_ticky info)

setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
setTickyCtrLabel ticky code = do
	info <- getInfoDown
	withInfoDown code (info {cgd_ticky = ticky})


--------------------------------------------------------
-- 		Forking
--------------------------------------------------------

forkClosureBody :: FCode () -> FCode ()
-- forkClosureBody takes a code, $c$, and compiles it in a 
-- fresh environment, except that:
--	- compilation info and statics are passed in unchanged.
--	- local bindings are passed in unchanged
--	  (it's up to the enclosed code to re-bind the
--	   free variables to a field of the closure)
-- 
-- The current state is passed on completely unaltered, except that
-- C-- from the fork is incorporated.

forkClosureBody body_code
547 548
  = do	{ dflags <- getDynFlags
      	; info <- getInfoDown
549 550
	; us   <- newUniqSupply
	; state <- getState
551
   	; let	body_info_down = info { cgd_sequel    = initSequel
552
                                      , cgd_updfr_off = initUpdFrameOff dflags }
553 554 555 556 557 558 559 560 561 562 563
		fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
		((),fork_state_out)
		    = doFCode body_code body_info_down fork_state_in
	; setState $ state `addCodeBlocksFrom` fork_state_out }
	
forkStatics :: FCode a -> FCode a
-- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
-- from the current *local 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.
forkStatics body_code
564 565
  = do	{ dflags <- getDynFlags
      	; info  <- getInfoDown
566 567
	; us    <- newUniqSupply
	; state <- getState
568 569
	; let	rhs_info_down = info { cgd_statics = cgs_binds state
				     , cgd_sequel  = initSequel 
570
			             , cgd_updfr_off = initUpdFrameOff dflags }
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586
		(result, fork_state_out) = doFCode body_code rhs_info_down 
						   (initCgState us)
	; setState (state `addCodeBlocksFrom` fork_state_out)
	; return result }

forkProc :: FCode a -> FCode a
-- 'forkProc' takes a code and compiles it in the *current* environment,
-- returning the graph thus constructed. 
--
-- The current environment is passed on completely unchanged to
-- the successor.  In particular, any heap usage from the enclosed
-- code is discarded; it should deal with its own heap consumption
forkProc body_code
  = do	{ info_down <- getInfoDown
	; us    <- newUniqSupply
	; state <- getState
587
   	; let	info_down' = info_down -- { cgd_sequel = initSequel }
588 589
                fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
		(result, fork_state_out) = doFCode body_code info_down' fork_state_in
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612
  	; setState $ state `addCodeBlocksFrom` fork_state_out
	; return result }

codeOnly :: FCode () -> FCode ()
-- 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
codeOnly body_code
  = do	{ info_down <- getInfoDown
	; us   <- newUniqSupply
	; state <- getState
	; let	fork_state_in = (initCgState us) { cgs_binds   = cgs_binds 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 }

forkAlts :: [FCode a] -> FCode [a]
-- (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 the virtual Hp is moved on to the worst virtual Hp for the branches

forkAlts branch_fcodes
Ian Lynagh's avatar
Ian Lynagh committed
613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628
  = 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_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 }
629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663

-- collect the code emitted by an FCode computation
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR fcode
  = do	{ state1 <- getState
	; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
	; setState $ state2 { cgs_stmts = cgs_stmts state1  }
	; return (a, cgs_stmts state2) }

getCode :: FCode a -> FCode CmmAGraph
getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }

-- 'getHeapUsage' applies a function to the amount of heap that it uses.
-- It initialises the heap usage to zeros, and passes on an unchanged
-- heap usage. 
--
-- It is usually a prelude to performing a GC check, so everything must
-- be in a tidy and consistent state.
-- 
-- Note the slightly subtle fixed point behaviour needed here

getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage fcode
  = do	{ info_down <- getInfoDown
	; state <- getState
	; let	fstate_in = state { cgs_hp_usg  = initHpUsage }
		(r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
		hp_hw = heapHWM (cgs_hp_usg fstate_out)	-- Loop here!
		
	; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
	; return r }

-- ----------------------------------------------------------------------------
-- Combinators for emitting code

664 665 666 667 668 669 670 671 672 673
emitCgStmt :: CgStmt -> FCode ()
emitCgStmt stmt
  = do  { state <- getState
        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
        }

emitLabel :: BlockId -> FCode ()
emitLabel id = emitCgStmt (CgLabel id)

emitComment :: FastString -> FCode ()
Simon Marlow's avatar
Simon Marlow committed
674
#if 0 /* def DEBUG */
675 676
emitComment s = emitCgStmt (CgStmt (CmmComment s))
#else
677
emitComment _ = return ()
678 679 680 681 682 683 684 685 686 687 688 689 690
#endif

emitAssign :: CmmReg  -> CmmExpr -> FCode ()
emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))

emitStore :: CmmExpr  -> CmmExpr -> FCode ()
emitStore l r = emitCgStmt (CgStmt (CmmStore l r))


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

691 692 693 694 695
emit :: CmmAGraph -> FCode ()
emit ag
  = do	{ state <- getState
	; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
696
emitDecl :: CmmDecl -> FCode ()
697
emitDecl decl
698
  = do 	{ state <- getState
699
	; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
700

701 702 703
emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)

704 705 706 707 708 709 710 711 712 713 714 715
emitProcWithStackFrame
   :: Convention                        -- entry convention
   -> Maybe CmmInfoTable                -- info table?
   -> CLabel                            -- label for the proc
   -> [CmmFormal]                       -- stack frame
   -> [CmmFormal]                       -- arguments
   -> CmmAGraph                         -- code
   -> Bool                              -- do stack layout?
   -> FCode ()

emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
  = do  { dflags <- getDynFlags
716
        ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
717 718 719
        }
emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
  = do  { dflags <- getDynFlags
720 721
        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
        ; emitProc_ mb_info lbl live (entry <*> blocks) offset True
722 723 724
        }
emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"

725
emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
726 727 728
                       -> [CmmFormal]
                       -> CmmAGraph
                       -> FCode ()
729
emitProcWithConvention conv mb_info lbl args blocks
730 731
  = emitProcWithStackFrame conv mb_info lbl [] args blocks True

732 733 734
emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> FCode ()
emitProc  mb_info lbl live blocks offset
 = emitProc_ mb_info lbl live blocks offset True
735

736
emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraph -> Int -> Bool
737
          -> FCode ()
738
emitProc_ mb_info lbl live blocks offset do_layout
739
  = do  { dflags <- getDynFlags
740 741 742
        ; l <- newLabelC
        ; let
              blks = labelAGraph l blocks
743

744 745
              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
                    | otherwise            = mapEmpty
746

747 748 749 750 751 752
              sinfo = StackInfo { arg_space = offset
                                , updfr_space = Just (initUpdFrameOff dflags)
                                , do_layout = do_layout }

              tinfo = TopInfo { info_tbls = infos
                              , stack_info=sinfo}
753

754
              proc_block = CmmProc tinfo lbl live blks
755

756 757
        ; state <- getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
758

Simon Peyton Jones's avatar
Simon Peyton Jones committed
759
getCmm :: FCode () -> FCode CmmGroup
760 761 762 763 764 765 766
-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
getCmm code 
  = do	{ state1 <- getState
	; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
	; setState $ state2 { cgs_tops = cgs_tops state1 } 
767
        ; return (fromOL (cgs_tops state2)) }
768

769 770 771 772 773 774 775 776 777 778

mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse e tbranch fbranch = do
  endif <- newLabelC
  tid   <- newLabelC
  fid   <- newLabelC
  return $ mkCbranch e tid fid <*>
            mkLabel tid <*> tbranch <*> mkBranch endif <*>
            mkLabel fid <*> fbranch <*> mkLabel endif

779 780 781 782 783
mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto e tid = do
  endif <- newLabelC
  return $ mkCbranch e tid endif <*> mkLabel endif

784 785 786 787 788 789 790 791 792
mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen e tbranch = do
  endif <- newLabelC
  tid <- newLabelC
  return $ mkCbranch e tid endif <*>
         mkLabel tid <*> tbranch <*> mkLabel endif


mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
793
       -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph
Simon Marlow's avatar
Simon Marlow committed
794
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
795
  dflags <- getDynFlags
796
  k <- newLabelC
Simon Marlow's avatar
Simon Marlow committed
797
  let area = Young k
798
      (off, _, copyin) = copyInOflow dflags retConv area results []
799
      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
800 801 802 803
  return (copyout <*> mkLabel k <*> copyin)

mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
          -> FCode CmmAGraph
Simon Marlow's avatar
Simon Marlow committed
804
mkCmmCall f results actuals updfr_off
805
   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
806 807


808
-- ----------------------------------------------------------------------------
809
-- turn CmmAGraph into CmmGraph, for making a new proc.
810

811 812 813 814
aGraphToGraph :: CmmAGraph -> FCode CmmGraph
aGraphToGraph stmts
  = do  { l <- newLabelC
        ; return (labelAGraph l stmts) }