CgMonad.lhs 26.4 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 11
\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}
module CgMonad (
12 13
	Code,	-- type
	FCode,	-- type
14 15

	initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
16
	returnFC, fixC, fixC_, checkedAbsC, 
17 18
	stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
	newUnique, newUniqSupply, 
19

20 21 22 23 24 25 26 27
	CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
	getCgStmts', getCgStmts,
	noCgStmts, oneCgStmt, consCgStmt,

	getCmm,
	emitData, emitProc, emitSimpleProc,

	forkLabelledCode,
28
	forkClosureBody, forkStatics, forkAlts, forkEval,
29 30
	forkEvalHelp, forkProc, codeOnly,
	SemiTaggingStuff, ConTagZ,
31 32 33 34

	EndOfBlockInfo(..),
	setEndOfBlockInfo, getEndOfBlockInfo,

35
	setSRT, getSRT,
36
	setSRTLabel, getSRTLabel, 
37
	setTickyCtrLabel, getTickyCtrLabel,
38

39 40 41 42 43
	StackUsage(..), HeapUsage(..),
	VirtualSpOffset, VirtualHpOffset,
	initStkUsage, initHpUsage,
	getHpUsage,  setHpUsage,
	heapHWM,
44

Simon Marlow's avatar
Simon Marlow committed
45
	getModuleName,
46 47 48

	Sequel(..), -- ToDo: unabstract?

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

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

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

60
#include "HsVersions.h"
sof's avatar
sof committed
61

62
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
63

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

Simon Marlow's avatar
Simon Marlow committed
79
import Control.Monad
80
import Data.List
81

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
infixr 9 `thenC`	-- Right-associative!
infixr 9 `thenFC`
\end{code}

%************************************************************************
%*									*
\subsection[CgMonad-environment]{Stuff for manipulating environments}
%*									*
%************************************************************************

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}
data CgInfoDownwards	-- information only passed *downwards* by the monad
98
  = MkCgInfoDown {
99
	cgd_dflags  :: DynFlags,
100 101
	cgd_mod     :: Module,		-- Module being compiled
	cgd_statics :: CgBindings,	-- [Id -> info] : static environment
102 103
	cgd_srt_lbl :: CLabel,		-- label of the current SRT
        cgd_srt     :: SRT,		-- the current SRT
104 105 106 107
	cgd_ticky   :: CLabel,		-- current destination for ticky counts
	cgd_eob     :: EndOfBlockInfo	-- Info for stuff to do at end of basic block:
  }

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

118
data CgState
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
  = MkCgState {
     cgs_stmts :: OrdList CgStmt,	  -- Current proc
     cgs_tops  :: OrdList CmmTop,
	-- 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
     
     cgs_binds :: CgBindings,	-- [Id -> info] : *local* bindings environment
     				-- Bindings for top-level things are given in
				-- the info-down part
     
     cgs_stk_usg :: StackUsage,
     cgs_hp_usg  :: HeapUsage,
     
     cgs_uniqs :: UniqSupply }

initCgState :: UniqSupply -> CgState
initCgState uniqs
  = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL,
		cgs_binds = emptyVarEnv, 
		cgs_stk_usg = initStkUsage, 
		cgs_hp_usg = initHpUsage,
		cgs_uniqs = uniqs }
142 143
\end{code}

144 145 146
@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.
147 148 149 150

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

Ian Lynagh's avatar
Ian Lynagh committed
159
initEobInfo :: EndOfBlockInfo
160
initEobInfo = EndOfBlockInfo 0 OnStack
161 162 163 164 165 166 167 168
\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
169
  = OnStack 		-- Continuation is on the stack
170

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

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

type ConTagZ = Int	-- A *zero-indexed* contructor tag

-- The case branch is executed only from a successful semitagging
185 186 187
-- 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.
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
\end{code}

%************************************************************************
%*									*
		CgStmt type
%*									*
%************************************************************************

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 = 
	case flatten (fromOL stmts) of
	  ([],blocks)    -> blocks
	  (block,blocks) -> BasicBlock id block : blocks
 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]
222
    = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
223 224 225 226 227 228 229 230 231 232 233 234

  -- 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
	[]                     -> ( [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)
235
        (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
236 237 238 239 240 241 242 243 244 245

  flatten (s:ss) = 
	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)
    where (block,blocks) = flatten ss

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

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

%************************************************************************
%*									*
		Stack and heap models
%*									*
%************************************************************************
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
\begin{code}
type VirtualHpOffset = WordOff	-- Both are in
type VirtualSpOffset = WordOff	-- units of words

data StackUsage 
  = StackUsage {
	virtSp :: VirtualSpOffset,
		-- Virtual offset of topmost allocated slot

	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

	 freeStk :: [VirtualSpOffset], 
		-- List of free slots, in *increasing* order
		-- INVARIANT: all <= virtSp
		-- All slots <= virtSp are taken except these ones

	 realSp :: VirtualSpOffset,	
		-- Virtual offset of real stack pointer register

	 hwSp :: VirtualSpOffset
  }		   -- Highest value ever taken by virtSp

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

data HeapUsage =
  HeapUsage {
	virtHp :: VirtualHpOffset,	-- Virtual offset of highest-allocated word
	realHp :: VirtualHpOffset	-- realHp: Virtual offset of real heap ptr
  }
299
\end{code}
300

301 302 303 304
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!
305

306
Note Jan 04: ok, so why do we only look at the virtual Hp??
307 308

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

313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329
Initialisation.

\begin{code}
initStkUsage :: StackUsage
initStkUsage = StackUsage {
			virtSp = 0,
			frameSp = 0,
			freeStk = [],
			realSp = 0,
			hwSp = 0
	       }
		
initHpUsage :: HeapUsage 
initHpUsage = HeapUsage {
	      	virtHp = 0,
		realHp = 0
	      }
330 331 332 333 334 335 336
\end{code}

@stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
marks found in $e_2$.

\begin{code}
stateIncUsage :: CgState -> CgState -> CgState
337 338 339 340 341 342 343 344 345 346 347 348
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,
	    cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
       `addCodeBlocksFrom` s2
		
stateIncUsageEval :: CgState -> CgState -> CgState
stateIncUsageEval s1 s2
     = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
       `addCodeBlocksFrom` s2
	-- 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.
349

350 351 352 353 354 355 356 357 358 359 360 361
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,
	 cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }

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 }
362 363 364 365
\end{code}

%************************************************************************
%*									*
366
		The FCode monad
367 368 369 370
%*									*
%************************************************************************

\begin{code}
rje's avatar
rje committed
371
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
372
type Code       = FCode ()
rje's avatar
rje committed
373 374 375 376

instance Monad FCode where
	(>>=) = thenFC
	return = returnFC
377 378 379 380 381 382 383 384

{-# 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
385
initC :: DynFlags -> Module -> FCode a -> IO a
386

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

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

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

listCs :: [Code] -> Code
rje's avatar
rje committed
404 405 406 407 408
listCs [] = return ()
listCs (fc:fcs) = do
	fc
	listCs fcs
   	
409
mapCs :: (a -> Code) -> [a] -> Code
rje's avatar
rje committed
410
mapCs = mapM_
411 412 413
\end{code}

\begin{code}
rje's avatar
rje committed
414 415 416 417 418 419 420 421 422
thenFC	:: FCode a -> (a -> FCode c) -> FCode c
thenFC (FCode m) k = FCode (
	\info_down state ->
		let 
			(m_result, new_state) = m info_down state
			(FCode kcode) = k m_result
		in 
			kcode info_down new_state
	)
423 424

listFCs :: [FCode a] -> FCode [a]
rje's avatar
rje committed
425
listFCs = sequence
426 427

mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
rje's avatar
rje committed
428
mapFCs = mapM
429 430 431 432 433
\end{code}

And the knot-tying combinator:
\begin{code}
fixC :: (a -> FCode a) -> FCode a
rje's avatar
rje committed
434 435 436 437 438 439 440 441 442
fixC fcode = FCode (
	\info_down state -> 
		let
			FCode fc = fcode v
			result@(v,_) = fc info_down state
			--	    ^--------^
		in
			result
	)
443 444 445

fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
rje's avatar
rje committed
446 447
\end{code}

448 449 450 451 452 453
%************************************************************************
%*									*
	Operators for getting and setting the state and "info_down".

%*									*
%************************************************************************
rje's avatar
rje committed
454 455 456

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

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

462 463 464 465
getStkUsage :: FCode StackUsage
getStkUsage = do
	state <- getState
	return $ cgs_stk_usg state
rje's avatar
rje committed
466

467 468 469 470 471 472 473 474 475 476 477 478 479 480
setStkUsage :: StackUsage -> Code
setStkUsage new_stk_usg = do
	state <- getState
	setState $ state {cgs_stk_usg = new_stk_usg}

getHpUsage :: FCode HeapUsage
getHpUsage = do
	state <- getState
	return $ cgs_hp_usg state
	
setHpUsage :: HeapUsage -> Code
setHpUsage new_hp_usg = do
	state <- getState
	setState $ state {cgs_hp_usg = new_hp_usg}
rje's avatar
rje committed
481 482 483

getBinds :: FCode CgBindings
getBinds = do
484 485
	state <- getState
	return $ cgs_binds state
rje's avatar
rje committed
486 487
	
setBinds :: CgBindings -> FCode ()
488 489 490
setBinds new_binds = do
	state <- getState
	setState $ state {cgs_binds = new_binds}
rje's avatar
rje committed
491 492 493

getStaticBinds :: FCode CgBindings
getStaticBinds = do
494 495
	info  <- getInfoDown
	return (cgd_statics info)
rje's avatar
rje committed
496 497 498 499 500

withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state -> 
	let (retval, state2) = fcode info_down newstate in ((retval,state2), state)

501 502 503 504 505 506 507 508 509 510 511 512 513
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)

------------------
rje's avatar
rje committed
514 515 516
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)

517 518 519
getDynFlags :: FCode DynFlags
getDynFlags = liftM cgd_dflags getInfoDown

Simon Marlow's avatar
Simon Marlow committed
520 521
getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags
522

rje's avatar
rje committed
523 524 525 526 527
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
528 529
\end{code}

rje's avatar
rje committed
530

531 532 533 534 535 536
%************************************************************************
%*									*
		Forking
%*									*
%************************************************************************

537 538 539 540 541 542
@forkClosureBody@ takes a code, $c$, and compiles it in a completely
fresh environment, except that:
	- compilation info and statics are passed in unchanged.
The current environment is passed on completely unaltered, except that
abstract C from the fork is incorporated.

543 544 545 546
@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.
547 548 549 550 551 552 553 554

@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
555 556 557 558 559 560 561 562 563
forkClosureBody body_code
  = 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 }
rje's avatar
rje committed
564
	
565
forkStatics :: FCode a -> FCode a
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605
forkStatics body_code
  = 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 }

forkProc :: Code -> FCode CgStmts
forkProc body_code
  = 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 }

codeOnly :: Code -> Code
-- 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_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 }
606 607 608 609 610 611 612 613 614 615
\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
	- the worst stack high-water mark is incorporated
	- the virtual Hp is moved on to the worst virtual Hp for the branches

\begin{code}
616 617 618
forkAlts :: [FCode a] -> FCode [a]

forkAlts branch_fcodes
619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635
  = 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 }
636 637 638
\end{code}

@forkEval@ takes two blocks of code.
639 640 641 642 643 644 645 646 647

   -  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.
648 649 650 651 652 653 654 655 656 657 658

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

659
forkEval body_eob_info env_code body_code
660 661
  = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
 	; returnFC (EndOfBlockInfo v sequel) }
662

663
forkEvalHelp :: EndOfBlockInfo  -- For the body
664 665
    	     -> Code		-- Code to set environment
	     -> FCode a		-- The code to do after the eval
666 667 668 669
	     -> FCode (VirtualSpOffset,	-- Sp
		       a)		-- Result of the FCode
	-- A disturbingly complicated function
forkEvalHelp body_eob_info env_code body_code
670
  = do	{ info_down <- getInfoDown
671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688
	; 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,
689
		 -- notably of the return vector!
690 691
	  setState $ state `stateIncUsageEval` state_at_end_return
	; return (virtSp_from_env, value_returned) }
692 693


694 695 696
-- ----------------------------------------------------------------------------
-- Combinators for emitting code

697
nopC :: Code
rje's avatar
rje committed
698
nopC = return ()
699

700 701
whenC :: Bool -> Code -> Code
whenC True  code = code
Ian Lynagh's avatar
Ian Lynagh committed
702
whenC False _    = nopC
703

704 705
-- Corresponds to 'emit' in new code generator with a smart constructor
-- from cmm/MkGraph.hs
706 707 708 709 710 711 712
stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)

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

newLabelC :: FCode BlockId
713
newLabelC = do { u <- newUnique
714
               ; return $ mkBlockId u }
715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745

checkedAbsC :: CmmStmt -> Code
-- Emit code, eliminating no-ops
checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL
	 		      else unitOL stmt)

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

emitData :: Section -> [CmmStatic] -> Code
emitData sect lits
  = do 	{ state <- getState
	; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
  where
    data_block = CmmData sect lits

746
emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
747 748
emitProc info lbl [] blocks
  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
749 750
	; state <- getState
	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
751
emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
752 753 754 755 756 757

emitSimpleProc :: CLabel -> Code -> Code
-- Emit a procedure whose body is the specified code; no info table
emitSimpleProc lbl code
  = do	{ stmts <- getCgStmts code
	; blks <- cgStmtsToBlocks stmts
758
	; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
759 760 761

getCmm :: Code -> FCode Cmm
-- Get all the CmmTops (there should be no stmts)
762 763
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
764 765 766 767
getCmm code 
  = do	{ state1 <- getState
	; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
	; setState $ state2 { cgs_tops = cgs_tops state1 } 
768 769
	; return (Cmm (fromOL (cgs_tops state2))) 
        }
770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821

-- ----------------------------------------------------------------------------
-- 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
  = do	{ state <- getState
	; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } }

-- emit CgStmts outside the current instruction stream, and return a label
forkCgStmts :: CgStmts -> FCode BlockId
forkCgStmts stmts
  = do  { id <- newLabelC
	; emitCgStmt (CgFork id stmts)
	; return id
	}

-- turn CgStmts into [CmmBasicBlock], for making a new proc.
cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
cgStmtsToBlocks stmts
  = do  { id <- newLabelC
	; return (flattenCgStmts id stmts)
	}	

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

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
822

Simon Marlow's avatar
Simon Marlow committed
823 824
getModuleName :: FCode Module
getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
825 826 827

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

setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
rje's avatar
rje committed
830
setEndOfBlockInfo eob_info code	= do
831 832
	info  <- getInfoDown
	withInfoDown code (info {cgd_eob = eob_info})
833 834

getEndOfBlockInfo :: FCode EndOfBlockInfo
rje's avatar
rje committed
835
getEndOfBlockInfo = do
836 837
	info <- getInfoDown
	return (cgd_eob info)
838

839 840
-- ----------------------------------------------------------------------------
-- Get/set the current SRT label
841

842 843 844
-- 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.
845 846

getSRTLabel :: FCode CLabel	-- Used only by cgPanic
847
getSRTLabel = do info  <- getInfoDown
848
		 return (cgd_srt_lbl info)
849

850
setSRTLabel :: CLabel -> FCode a -> FCode a
851
setSRTLabel srt_lbl code
852
  = do  info <- getInfoDown
853 854 855 856 857 858 859 860 861 862
	withInfoDown code (info { cgd_srt_lbl = srt_lbl})

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})
863 864 865

-- ----------------------------------------------------------------------------
-- Get/set the current ticky counter label
866 867

getTickyCtrLabel :: FCode CLabel
rje's avatar
rje committed
868
getTickyCtrLabel = do
869 870
	info <- getInfoDown
	return (cgd_ticky info)
871 872

setTickyCtrLabel :: CLabel -> Code -> Code
rje's avatar
rje committed
873
setTickyCtrLabel ticky code = do
874 875
	info <- getInfoDown
	withInfoDown code (info {cgd_ticky = ticky})
876
\end{code}