CgMonad.lhs 26.3 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
Simon Marlow's avatar
Simon Marlow committed
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
import Cmm
Simon Marlow's avatar
Simon Marlow committed
67
import CmmUtils
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
import Unique
76
import Util()
Simon Marlow's avatar
Simon Marlow committed
77
import UniqSupply
78
import FastString()
79
import Outputable
80

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

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
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
100
  = MkCgInfoDown {
101
	cgd_dflags  :: DynFlags,
102
103
	cgd_mod     :: Module,		-- Module being compiled
	cgd_statics :: CgBindings,	-- [Id -> info] : static environment
104
105
	cgd_srt_lbl :: CLabel,		-- label of the current SRT
        cgd_srt     :: SRT,		-- the current SRT
106
107
108
109
	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
110
111
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
112
113
  = MkCgInfoDown {	cgd_dflags  = dflags,
			cgd_mod     = mod,
114
			cgd_statics = emptyVarEnv,
115
			cgd_srt_lbl = error "initC: srt_lbl",
116
117
118
			cgd_srt     = error "initC: srt",
			cgd_ticky   = mkTopTickyCtrLabel,
			cgd_eob     = initEobInfo }
119

120
data CgState
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
  = 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 }
144
145
\end{code}

146
147
148
@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.
149
150
151
152

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

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

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

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

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

-- The case branch is executed only from a successful semitagging
188
189
190
-- 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.
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
222
223
224
\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]
225
    = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
226
227
228
229
230
231
232
233
234
235
236
237

  -- 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)
238
        (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
239
240
241
242
243
244
245
246
247
248

  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
249
isJump :: CmmStmt -> Bool
250
251
isJump (CmmJump _ _) = True
isJump (CmmBranch _) = True
252
isJump (CmmSwitch _ _) = True
253
isJump (CmmReturn _) = True
254
255
isJump _ = False

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

%************************************************************************
%*									*
		Stack and heap models
%*									*
%************************************************************************
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
\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

293
-- INVARIANT: The environment contains no Stable references to
294
295
296
297
298
299
300
301
-- 	      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
  }
302
\end{code}
303

304
305
306
307
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!
308

309
Note Jan 04: ok, so why do we only look at the virtual Hp??
310
311

\begin{code}
312
313
314
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp
\end{code}
315

316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
Initialisation.

\begin{code}
initStkUsage :: StackUsage
initStkUsage = StackUsage {
			virtSp = 0,
			frameSp = 0,
			freeStk = [],
			realSp = 0,
			hwSp = 0
	       }
		
initHpUsage :: HeapUsage 
initHpUsage = HeapUsage {
	      	virtHp = 0,
		realHp = 0
	      }
333
334
335
336
337
338
339
\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
340
341
342
343
344
345
346
347
348
349
350
351
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.
352

353
354
355
356
357
358
359
360
361
362
363
364
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 }
365
366
367
368
\end{code}

%************************************************************************
%*									*
369
		The FCode monad
370
371
372
373
%*									*
%************************************************************************

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

instance Monad FCode where
	(>>=) = thenFC
	return = returnFC
380
381
382
383
384
385
386
387

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

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

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

\begin{code}
rje's avatar
rje committed
401
402
403
404
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)
405
406

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

\begin{code}
rje's avatar
rje committed
417
418
419
420
421
422
423
424
425
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
	)
426
427

listFCs :: [FCode a] -> FCode [a]
rje's avatar
rje committed
428
listFCs = sequence
429
430

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

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

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

451
452
453
454
455
456
%************************************************************************
%*									*
	Operators for getting and setting the state and "info_down".

%*									*
%************************************************************************
rje's avatar
rje committed
457
458
459

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

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

465
466
467
468
getStkUsage :: FCode StackUsage
getStkUsage = do
	state <- getState
	return $ cgs_stk_usg state
rje's avatar
rje committed
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
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
484
485
486

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

getStaticBinds :: FCode CgBindings
getStaticBinds = do
497
498
	info  <- getInfoDown
	return (cgd_statics info)
rje's avatar
rje committed
499
500
501
502
503

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)

504
505
506
507
508
509
510
511
512
513
514
515
516
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
517
518
519
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)

520
521
522
getDynFlags :: FCode DynFlags
getDynFlags = liftM cgd_dflags getInfoDown

Simon Marlow's avatar
Simon Marlow committed
523
524
getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags
525

rje's avatar
rje committed
526
527
528
529
530
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
531
532
\end{code}

rje's avatar
rje committed
533

534
535
536
537
538
539
%************************************************************************
%*									*
		Forking
%*									*
%************************************************************************

540
541
542
543
544
545
@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.

546
547
548
549
@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.
550
551
552
553
554
555
556
557

@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
558
559
560
561
562
563
564
565
566
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
567
	
568
forkStatics :: FCode a -> FCode a
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
606
607
608
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 }
609
610
611
612
613
614
615
616
617
618
\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}
619
620
621
forkAlts :: [FCode a] -> FCode [a]

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

@forkEval@ takes two blocks of code.
642
643
644
645
646
647
648
649
650

   -  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.
651
652
653
654
655
656
657
658
659
660
661

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

662
forkEval body_eob_info env_code body_code
663
664
  = do  { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
 	; returnFC (EndOfBlockInfo v sequel) }
665

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


697
698
699
-- ----------------------------------------------------------------------------
-- Combinators for emitting code

700
nopC :: Code
rje's avatar
rje committed
701
nopC = return ()
702

703
704
whenC :: Bool -> Code -> Code
whenC True  code = code
Ian Lynagh's avatar
Ian Lynagh committed
705
whenC False _    = nopC
706
707
708
709
710
711
712
713

stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)

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

newLabelC :: FCode BlockId
714
715
newLabelC = do { u <- newUnique
               ; return $ BlockId u }
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
746

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

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

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}