StgCmmMonad.hs 23.3 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, listFCs, mapCs, mapFCs,
21
	returnFC, fixC, fixC_, nopC, whenC, 
22
23
	newUnique, newUniqSupply, 

24
25
        newLabelC, emitLabel,

26
	emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc,
27
        emitOutOfLine, emitAssign, emitStore, emitComment,
28
29
30
31

	getCmm, cgStmtsToBlocks,
	getCodeR, getCode, getHeapUsage,

32
33
        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
        mkCall, mkCmmCall, mkSafeCall,
34
35

        forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
36
37
38
39
40
41
42
43
44

	ConTagZ,

	Sequel(..),
	withSequel, getSequel,

	setSRTLabel, getSRTLabel, 
	setTickyCtrLabel, getTickyCtrLabel,

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 MkGraph
70
71
72
73
74
75
76
77
78
import BlockId
import CLabel
import SMRep
import Module
import Id
import VarEnv
import OrdList
import Unique
import UniqSupply
79
import FastString
80
import Outputable
81

82
83
import Control.Monad
import Data.List
84
import Prelude hiding( sequence, succ )
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
import qualified Prelude( sequence )

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


--------------------------------------------------------
--	The FCode monad and its types
--------------------------------------------------------

newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))

instance Monad FCode where
	(>>=) = thenFC
	return = returnFC

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

105
106
107
108
109
110
initC :: IO CgState
initC  = do { uniqs <- mkSplitUniqSupply 'c'
            ; return (initCgState uniqs) }

runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162

returnFC :: a -> FCode a
returnFC val = FCode (\_info_down state -> (val, state))

thenC :: FCode () -> 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)

nopC :: FCode ()
nopC = return ()

whenC :: Bool -> FCode () -> FCode ()
whenC True  code  = code
whenC False _code = nopC

listCs :: [FCode ()] -> FCode ()
listCs [] = return ()
listCs (fc:fcs) = do
	fc
	listCs fcs
   	
mapCs :: (a -> FCode ()) -> [a] -> FCode ()
mapCs = mapM_

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
	)

listFCs :: [FCode a] -> FCode [a]
listFCs = Prelude.sequence

mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
mapFCs = mapM

fixC :: (a -> FCode a) -> FCode a
fixC fcode = FCode (
	\info_down state -> 
		let
			FCode fc = fcode v
			result@(v,_) = fc info_down state
			--	    ^--------^
		in
			result
	)

163
164
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
165
166
167
168
169
170
171
172
173
174
175

--------------------------------------------------------
--	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 {
176
177
178
179
180
181
182
	cgd_dflags     :: DynFlags,
	cgd_mod        :: Module,	  -- Module being compiled
	cgd_statics    :: CgBindings,	  -- [Id -> info] : static environment
	cgd_srt_lbl    :: CLabel,	  -- Label of the current top-level SRT
	cgd_updfr_off  :: UpdFrameOffset, -- Size of current update frame
	cgd_ticky      :: CLabel,	  -- Current destination for ticky counts
	cgd_sequel     :: Sequel	  -- What to do at end of basic block
183
184
185
186
187
188
189
190
191
192
  }

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 
193
	, cg_loc :: CgLoc		     -- CmmExpr for the *tagged* value
194
        , cg_tag :: {-# UNPACK #-} !DynTag   -- Cache for (lfDynTag cg_lf)
195
        }
196
197
198
199
200
201
202
203
204
205
206

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
207
208
209
instance Outputable CgIdInfo where
  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
    = ppr id <+> ptext (sLit "-->") <+> ppr loc
210

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


-- 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
224
225
226
227
        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)
228
229
230
instance Show Sequel where
  show (Return _) = "Sequel: Return"
  show (AssignTo _ _) = "Sequel: Assign"
231
232
233

initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
234
235
236
237
238
239
240
  = MkCgInfoDown {	cgd_dflags    = dflags,
			cgd_mod       = mod,
			cgd_statics   = emptyVarEnv,
			cgd_srt_lbl   = error "initC: srt_lbl",
			cgd_updfr_off = initUpdFrameOff,
			cgd_ticky     = mkTopTickyCtrLabel,
			cgd_sequel    = initSequel }
241
242
243
244

initSequel :: Sequel
initSequel = Return False

245
246
247
initUpdFrameOff :: UpdFrameOffset
initUpdFrameOff = widthInBytes wordWidth -- space for the RA

248
249
250
251
252
253
254
255
256

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
257
     cgs_tops  :: OrdList CmmDecl,
258
259
260
261
262
263
264
265
266
	-- 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,
267

268
269
270
271
272
     cgs_uniqs :: UniqSupply }

data HeapUsage =
  HeapUsage {
	virtHp :: VirtualHpOffset,	-- Virtual offset of highest-allocated word
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
273
	       	  			--   Incremented whenever we allocate
274
	realHp :: VirtualHpOffset	-- realHp: Virtual offset of real heap ptr
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
275
	       	  			--   Used in instruction addressing modes
276
277
278
279
  }

type VirtualHpOffset = WordOff

280
281


282
283
initCgState :: UniqSupply -> CgState
initCgState uniqs
284
285
286
287
  = MkCgState { cgs_stmts      = mkNop, cgs_tops = nilOL,
		cgs_binds      = emptyVarEnv, 
		cgs_hp_usg     = initHpUsage,
		cgs_uniqs      = uniqs }
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
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

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
getState = FCode $ \_info_down state -> (state,state)

setState :: CgState -> FCode ()
setState state = FCode $ \_info_down _ -> ((),state)

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 -> 
	let (retval, state2) = fcode info_down newstate in ((retval,state2), state)

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
getInfoDown = FCode $ \info_down state -> (info_down,state)

390
391
instance HasDynFlags FCode where
    getDynFlags = liftM cgd_dflags getInfoDown
392
393
394
395
396
397
398
399
400
401
402
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

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)
doFCode (FCode fcode) info_down state = fcode info_down state


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

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

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

withSequel :: Sequel -> FCode () -> FCode ()
withSequel sequel code
  = do	{ info  <- getInfoDown
	; withInfoDown code (info {cgd_sequel = sequel }) }

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

-- ----------------------------------------------------------------------------
-- Get/set the current SRT label

-- 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.

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

setSRTLabel :: CLabel -> FCode a -> FCode a
setSRTLabel srt_lbl code
  = do  info <- getInfoDown
	withInfoDown code (info { cgd_srt_lbl = srt_lbl})

437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
-- ----------------------------------------------------------------------------
-- 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'.

withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
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 }

457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
-- ----------------------------------------------------------------------------
-- 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
  = do	{ info <- getInfoDown
	; us   <- newUniqSupply
	; state <- getState
490
491
   	; let	body_info_down = info { cgd_sequel    = initSequel
                                      , cgd_updfr_off = initUpdFrameOff }
492
493
494
495
496
497
498
499
500
501
502
503
504
505
		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
  = do	{ info  <- getInfoDown
	; us    <- newUniqSupply
	; state <- getState
506
507
508
	; let	rhs_info_down = info { cgd_statics = cgs_binds state
				     , cgd_sequel  = initSequel 
			             , cgd_updfr_off = initUpdFrameOff }
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
		(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
525
   	; let	info_down' = info_down -- { cgd_sequel = initSequel }
526
527
                fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
		(result, fork_state_out) = doFCode body_code info_down' fork_state_in
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
  	; 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
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
  = 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 }
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

-- 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

602
603
604
605
606
607
608
609
610
611
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
612
#if 0 /* def DEBUG */
613
614
emitComment s = emitCgStmt (CgStmt (CmmComment s))
#else
615
emitComment _ = return ()
616
617
618
619
620
621
622
623
624
625
626
627
628
#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 }

629
630
631
632
633
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
634
emitDecl :: CmmDecl -> FCode ()
635
emitDecl decl
636
  = do 	{ state <- getState
637
	; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
638

639
640
641
emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)

642
emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] ->
643
644
                          CmmAGraph -> FCode ()
emitProcWithConvention conv info lbl args blocks
645
  = do  { us <- newUniqSupply
646
647
648
649
        ; let (offset, entry) = mkCallEntry conv args
              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
        ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
              proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks
650
651
652
        ; state <- getState
        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }

653
emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
654
emitProc = emitProcWithConvention NativeNodeCall
655

656
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
657
emitSimpleProc lbl code = 
658
  emitProc CmmNonInfoTable lbl [] code
659

Simon Peyton Jones's avatar
Simon Peyton Jones committed
660
getCmm :: FCode () -> FCode CmmGroup
661
662
663
664
665
666
667
-- 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 } 
668
        ; return (fromOL (cgs_tops state2)) }
669

670
671
672
673
674
675
676
677
678
679

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

680
681
682
683
684
mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto e tid = do
  endif <- newLabelC
  return $ mkCbranch e tid endif <*> mkLabel endif

685
686
687
688
689
690
691
692
693
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]
Simon Marlow's avatar
Simon Marlow committed
694
695
       -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
696
  k <- newLabelC
Simon Marlow's avatar
Simon Marlow committed
697
  let area = Young k
698
      (off, copyin) = copyInOflow retConv area results
Simon Marlow's avatar
Simon Marlow committed
699
      copyout = mkCallReturnsTo f callConv actuals k off updfr_off extra_stack
700
701
702
703
  return (copyout <*> mkLabel k <*> copyin)

mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
          -> FCode CmmAGraph
Simon Marlow's avatar
Simon Marlow committed
704
705
mkCmmCall f results actuals updfr_off
   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
706
707
708
709
710
711
712


mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
           -> UpdFrameOffset -> Bool
           -> FCode CmmAGraph
mkSafeCall   t fs as upd i = do
  k <- newLabelC
713
714
  let (_off, copyout) = copyInOflow NativeReturn (Young k) fs
    -- see Note [safe foreign call convention]
715
  return
Simon Marlow's avatar
Simon Marlow committed
716
     (    mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
717
                  (CmmLit (CmmBlock k))
718
719
720
721
722
      <*> mkLast (CmmForeignCall { tgt=t, res=fs, args=as, succ=k
                                 , updfr=upd, intrbl=i })
      <*> mkLabel k
      <*> copyout
     )
723

724
725
726
727
728
729
730
731
732
733
-- ----------------------------------------------------------------------------
-- CgStmts

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

-- turn CgStmts into [CmmBasicBlock], for making a new proc.
cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
cgStmtsToBlocks stmts
  = do  { us <- newUniqSupply
734
	; return (initUs_ us (lgraphOfAGraph stmts)) }