fb290d8e96d13c4799df8309ce0b9f0bf3fa8383
[ghc.git] / compiler / codeGen / StgCmmMonad.hs
1 {-# LANGUAGE GADTs #-}
2 -----------------------------------------------------------------------------
3 --
4 -- Monad for Stg to C-- code generation
5 --
6 -- (c) The University of Glasgow 2004-2006
7 --
8 -----------------------------------------------------------------------------
9
10 {-# OPTIONS -fno-warn-tabs #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and
13 -- detab the module (please do the detabbing in a separate patch). See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
15 -- for details
16
17 module StgCmmMonad (
18 FCode, -- type
19
20 initC, runC, thenC, thenFC, listCs,
21 returnFC, nopC, whenC,
22 newUnique, newUniqSupply,
23
24 newLabelC, emitLabel,
25
26 emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc,
27 emitOutOfLine, emitAssign, emitStore, emitComment,
28
29 getCmm, cgStmtsToBlocks,
30 getCodeR, getCode, getHeapUsage,
31
32 mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
33 mkCall, mkCmmCall,
34
35 forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
36
37 ConTagZ,
38
39 Sequel(..), ReturnKind(..),
40 withSequel, getSequel,
41
42 setTickyCtrLabel, getTickyCtrLabel,
43
44 withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
45
46 HeapUsage(..), VirtualHpOffset, initHpUsage,
47 getHpUsage, setHpUsage, heapHWM,
48 setVirtHp, getVirtHp, setRealHp,
49
50 getModuleName,
51
52 -- ideally we wouldn't export these, but some other modules access internal state
53 getState, setState, getInfoDown, getDynFlags, getThisPackage,
54
55 -- more localised access to monad state
56 CgIdInfo(..), CgLoc(..),
57 getBinds, setBinds, getStaticBinds,
58
59 -- out of general friendliness, we also export ...
60 CgInfoDownwards(..), CgState(..) -- non-abstract
61 ) where
62
63 #include "HsVersions.h"
64
65 import Cmm
66 import StgCmmClosure
67 import DynFlags
68 import Hoopl
69 import MkGraph
70 import BlockId
71 import CLabel
72 import SMRep
73 import Module
74 import Id
75 import VarEnv
76 import OrdList
77 import Unique
78 import UniqSupply
79 import FastString
80 import Outputable
81
82 import Control.Monad
83 import Data.List
84 import Prelude hiding( sequence, succ )
85 import qualified Prelude( sequence )
86
87 infixr 9 `thenC` -- Right-associative!
88 infixr 9 `thenFC`
89
90
91 --------------------------------------------------------
92 -- The FCode monad and its types
93 --------------------------------------------------------
94
95 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
96
97 instance Functor FCode where
98 fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
99
100 instance Monad FCode where
101 (>>=) = thenFC
102 return = returnFC
103
104 {-# INLINE thenC #-}
105 {-# INLINE thenFC #-}
106 {-# INLINE returnFC #-}
107
108 initC :: IO CgState
109 initC = do { uniqs <- mkSplitUniqSupply 'c'
110 ; return (initCgState uniqs) }
111
112 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
113 runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
114
115 returnFC :: a -> FCode a
116 returnFC val = FCode (\_info_down state -> (# val, state #))
117
118 thenC :: FCode () -> FCode a -> FCode a
119 thenC (FCode m) (FCode k) =
120 FCode $ \info_down state -> case m info_down state of
121 (# _,new_state #) -> k info_down new_state
122
123 nopC :: FCode ()
124 nopC = return ()
125
126 whenC :: Bool -> FCode () -> FCode ()
127 whenC True code = code
128 whenC False _code = nopC
129
130 listCs :: [FCode ()] -> FCode ()
131 listCs [] = return ()
132 listCs (fc:fcs) = do
133 fc
134 listCs fcs
135
136 thenFC :: FCode a -> (a -> FCode c) -> FCode c
137 thenFC (FCode m) k = FCode $
138 \info_down state ->
139 case m info_down state of
140 (# m_result, new_state #) ->
141 case k m_result of
142 FCode kcode -> kcode info_down new_state
143
144 --------------------------------------------------------
145 -- The code generator environment
146 --------------------------------------------------------
147
148 -- This monadery has some information that it only passes
149 -- *downwards*, as well as some ``state'' which is modified
150 -- as we go along.
151
152 data CgInfoDownwards -- information only passed *downwards* by the monad
153 = MkCgInfoDown {
154 cgd_dflags :: DynFlags,
155 cgd_mod :: Module, -- Module being compiled
156 cgd_statics :: CgBindings, -- [Id -> info] : static environment
157 cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
158 cgd_ticky :: CLabel, -- Current destination for ticky counts
159 cgd_sequel :: Sequel -- What to do at end of basic block
160 }
161
162 type CgBindings = IdEnv CgIdInfo
163
164 data CgIdInfo
165 = CgIdInfo
166 { cg_id :: Id -- Id that this is the info for
167 -- Can differ from the Id at occurrence sites by
168 -- virtue of being externalised, for splittable C
169 , cg_lf :: LambdaFormInfo
170 , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
171 , cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf)
172 }
173
174 data CgLoc
175 = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
176 -- Hp, so that it remains valid across calls
177
178 | LneLoc BlockId [LocalReg] -- A join point
179 -- A join point (= let-no-escape) should only
180 -- be tail-called, and in a saturated way.
181 -- To tail-call it, assign to these locals,
182 -- and branch to the block id
183
184 instance Outputable CgIdInfo where
185 ppr (CgIdInfo { cg_id = id, cg_loc = loc })
186 = ppr id <+> ptext (sLit "-->") <+> ppr loc
187
188 instance Outputable CgLoc where
189 ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e
190 ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
191
192
193 -- Sequel tells what to do with the result of this expression
194 data Sequel
195 = Return Bool -- Return result(s) to continuation found on the stack
196 -- True <=> the continuation is update code (???)
197
198 | AssignTo
199 [LocalReg] -- Put result(s) in these regs and fall through
200 -- NB: no void arguments here
201 --
202 Bool -- Should we adjust the heap pointer back to
203 -- recover space that's unused on this path?
204 -- We need to do this only if the expression
205 -- may allocate (e.g. it's a foreign call or
206 -- allocating primOp)
207
208 -- See Note [sharing continuations] below
209 data ReturnKind
210 = AssignedDirectly
211 | ReturnedTo BlockId ByteOff
212
213 -- Note [sharing continuations]
214 --
215 -- ReturnKind says how the expression being compiled returned its
216 -- results: either by assigning directly to the registers specified
217 -- by the Sequel, or by returning to a continuation that does the
218 -- assignments. The point of this is we might be able to re-use the
219 -- continuation in a subsequent heap-check. Consider:
220 --
221 -- case f x of z
222 -- True -> <True code>
223 -- False -> <False code>
224 --
225 -- Naively we would generate
226 --
227 -- R2 = x -- argument to f
228 -- Sp[young(L1)] = L1
229 -- call f returns to L1
230 -- L1:
231 -- z = R1
232 -- if (z & 1) then Ltrue else Lfalse
233 -- Ltrue:
234 -- Hp = Hp + 24
235 -- if (Hp > HpLim) then L4 else L7
236 -- L4:
237 -- HpAlloc = 24
238 -- goto L5
239 -- L5:
240 -- R1 = z
241 -- Sp[young(L6)] = L6
242 -- call stg_gc_unpt_r1 returns to L6
243 -- L6:
244 -- z = R1
245 -- goto L1
246 -- L7:
247 -- <True code>
248 -- Lfalse:
249 -- <False code>
250 --
251 -- We want the gc call in L4 to return to L1, and discard L6. Note
252 -- that not only can we share L1 and L6, but the assignment of the
253 -- return address in L4 is unnecessary because the return address for
254 -- L1 is already on the stack. We used to catch the sharing of L1 and
255 -- L6 in the common-block-eliminator, but not the unnecessary return
256 -- address assignment.
257 --
258 -- Since this case is so common I decided to make it more explicit and
259 -- robust by programming the sharing directly, rather than relying on
260 -- the common-block elimiantor to catch it. This makes
261 -- common-block-elimianteion an optional optimisation, and furthermore
262 -- generates less code in the first place that we have to subsequently
263 -- clean up.
264 --
265 -- There are some rarer cases of common blocks that we don't catch
266 -- this way, but that's ok. Common-block-elimation is still available
267 -- to catch them when optimisation is enabled. Some examples are:
268 --
269 -- - when both the True and False branches do a heap check, we
270 -- can share the heap-check failure code L4a and maybe L4
271 --
272 -- - in a case-of-case, there might be multiple continuations that
273 -- we can common up.
274 --
275 -- It is always safe to use AssignedDirectly. Expressions that jump
276 -- to the continuation from multiple places (e.g. case expressions)
277 -- fall back to AssignedDirectly.
278 --
279
280
281 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
282 initCgInfoDown dflags mod
283 = MkCgInfoDown { cgd_dflags = dflags,
284 cgd_mod = mod,
285 cgd_statics = emptyVarEnv,
286 cgd_updfr_off = initUpdFrameOff dflags,
287 cgd_ticky = mkTopTickyCtrLabel,
288 cgd_sequel = initSequel }
289
290 initSequel :: Sequel
291 initSequel = Return False
292
293 initUpdFrameOff :: DynFlags -> UpdFrameOffset
294 initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
295
296
297 --------------------------------------------------------
298 -- The code generator state
299 --------------------------------------------------------
300
301 data CgState
302 = MkCgState {
303 cgs_stmts :: CmmAGraph, -- Current procedure
304
305 cgs_tops :: OrdList CmmDecl,
306 -- Other procedures and data blocks in this compilation unit
307 -- Both are ordered only so that we can
308 -- reduce forward references, when it's easy to do so
309
310 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
311 -- Bindings for top-level things are given in
312 -- the info-down part
313
314 cgs_hp_usg :: HeapUsage,
315
316 cgs_uniqs :: UniqSupply }
317
318 data HeapUsage =
319 HeapUsage {
320 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
321 -- Incremented whenever we allocate
322 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
323 -- Used in instruction addressing modes
324 }
325
326 type VirtualHpOffset = WordOff
327
328
329
330 initCgState :: UniqSupply -> CgState
331 initCgState uniqs
332 = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
333 cgs_binds = emptyVarEnv,
334 cgs_hp_usg = initHpUsage,
335 cgs_uniqs = uniqs }
336
337 stateIncUsage :: CgState -> CgState -> CgState
338 -- stateIncUsage@ e1 e2 incorporates in e1
339 -- the heap high water mark found in e2.
340 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
341 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
342 `addCodeBlocksFrom` s2
343
344 addCodeBlocksFrom :: CgState -> CgState -> CgState
345 -- Add code blocks from the latter to the former
346 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
347 s1 `addCodeBlocksFrom` s2
348 = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
349 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
350
351
352 -- The heap high water mark is the larger of virtHp and hwHp. The latter is
353 -- only records the high water marks of forked-off branches, so to find the
354 -- heap high water mark you have to take the max of virtHp and hwHp. Remember,
355 -- virtHp never retreats!
356 --
357 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
358
359 heapHWM :: HeapUsage -> VirtualHpOffset
360 heapHWM = virtHp
361
362 initHpUsage :: HeapUsage
363 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
364
365 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
366 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
367
368 --------------------------------------------------------
369 -- Operators for getting and setting the state and "info_down".
370 --------------------------------------------------------
371
372 getState :: FCode CgState
373 getState = FCode $ \_info_down state -> (# state, state #)
374
375 setState :: CgState -> FCode ()
376 setState state = FCode $ \_info_down _ -> (# (), state #)
377
378 getHpUsage :: FCode HeapUsage
379 getHpUsage = do
380 state <- getState
381 return $ cgs_hp_usg state
382
383 setHpUsage :: HeapUsage -> FCode ()
384 setHpUsage new_hp_usg = do
385 state <- getState
386 setState $ state {cgs_hp_usg = new_hp_usg}
387
388 setVirtHp :: VirtualHpOffset -> FCode ()
389 setVirtHp new_virtHp
390 = do { hp_usage <- getHpUsage
391 ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
392
393 getVirtHp :: FCode VirtualHpOffset
394 getVirtHp
395 = do { hp_usage <- getHpUsage
396 ; return (virtHp hp_usage) }
397
398 setRealHp :: VirtualHpOffset -> FCode ()
399 setRealHp new_realHp
400 = do { hp_usage <- getHpUsage
401 ; setHpUsage (hp_usage {realHp = new_realHp}) }
402
403 getBinds :: FCode CgBindings
404 getBinds = do
405 state <- getState
406 return $ cgs_binds state
407
408 setBinds :: CgBindings -> FCode ()
409 setBinds new_binds = do
410 state <- getState
411 setState $ state {cgs_binds = new_binds}
412
413 getStaticBinds :: FCode CgBindings
414 getStaticBinds = do
415 info <- getInfoDown
416 return (cgd_statics info)
417
418 withState :: FCode a -> CgState -> FCode (a,CgState)
419 withState (FCode fcode) newstate = FCode $ \info_down state ->
420 case fcode info_down newstate of
421 (# retval, state2 #) -> (# (retval,state2), state #)
422
423 newUniqSupply :: FCode UniqSupply
424 newUniqSupply = do
425 state <- getState
426 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
427 setState $ state { cgs_uniqs = us1 }
428 return us2
429
430 newUnique :: FCode Unique
431 newUnique = do
432 us <- newUniqSupply
433 return (uniqFromSupply us)
434
435 ------------------
436 getInfoDown :: FCode CgInfoDownwards
437 getInfoDown = FCode $ \info_down state -> (# info_down,state #)
438
439 instance HasDynFlags FCode where
440 getDynFlags = liftM cgd_dflags getInfoDown
441
442 getThisPackage :: FCode PackageId
443 getThisPackage = liftM thisPackage getDynFlags
444
445 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
446 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
447
448 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
449 doFCode (FCode fcode) info_down state =
450 case fcode info_down state of
451 (# a, s #) -> ( a, s )
452
453 -- ----------------------------------------------------------------------------
454 -- Get the current module name
455
456 getModuleName :: FCode Module
457 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
458
459 -- ----------------------------------------------------------------------------
460 -- Get/set the end-of-block info
461
462 withSequel :: Sequel -> FCode a -> FCode a
463 withSequel sequel code
464 = do { info <- getInfoDown
465 ; withInfoDown code (info {cgd_sequel = sequel }) }
466
467 getSequel :: FCode Sequel
468 getSequel = do { info <- getInfoDown
469 ; return (cgd_sequel info) }
470
471 -- ----------------------------------------------------------------------------
472 -- Get/set the size of the update frame
473
474 -- We keep track of the size of the update frame so that we
475 -- can set the stack pointer to the proper address on return
476 -- (or tail call) from the closure.
477 -- There should be at most one update frame for each closure.
478 -- Note: I'm including the size of the original return address
479 -- in the size of the update frame -- hence the default case on `get'.
480
481 withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
482 withUpdFrameOff size code
483 = do { info <- getInfoDown
484 ; withInfoDown code (info {cgd_updfr_off = size }) }
485
486 getUpdFrameOff :: FCode UpdFrameOffset
487 getUpdFrameOff
488 = do { info <- getInfoDown
489 ; return $ cgd_updfr_off info }
490
491 -- ----------------------------------------------------------------------------
492 -- Get/set the current ticky counter label
493
494 getTickyCtrLabel :: FCode CLabel
495 getTickyCtrLabel = do
496 info <- getInfoDown
497 return (cgd_ticky info)
498
499 setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
500 setTickyCtrLabel ticky code = do
501 info <- getInfoDown
502 withInfoDown code (info {cgd_ticky = ticky})
503
504
505 --------------------------------------------------------
506 -- Forking
507 --------------------------------------------------------
508
509 forkClosureBody :: FCode () -> FCode ()
510 -- forkClosureBody takes a code, $c$, and compiles it in a
511 -- fresh environment, except that:
512 -- - compilation info and statics are passed in unchanged.
513 -- - local bindings are passed in unchanged
514 -- (it's up to the enclosed code to re-bind the
515 -- free variables to a field of the closure)
516 --
517 -- The current state is passed on completely unaltered, except that
518 -- C-- from the fork is incorporated.
519
520 forkClosureBody body_code
521 = do { dflags <- getDynFlags
522 ; info <- getInfoDown
523 ; us <- newUniqSupply
524 ; state <- getState
525 ; let body_info_down = info { cgd_sequel = initSequel
526 , cgd_updfr_off = initUpdFrameOff dflags }
527 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
528 ((),fork_state_out)
529 = doFCode body_code body_info_down fork_state_in
530 ; setState $ state `addCodeBlocksFrom` fork_state_out }
531
532 forkStatics :: FCode a -> FCode a
533 -- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
534 -- from the current *local bindings*, but which is otherwise freshly initialised.
535 -- The Abstract~C returned is attached to the current state, but the
536 -- bindings and usage information is otherwise unchanged.
537 forkStatics body_code
538 = do { dflags <- getDynFlags
539 ; info <- getInfoDown
540 ; us <- newUniqSupply
541 ; state <- getState
542 ; let rhs_info_down = info { cgd_statics = cgs_binds state
543 , cgd_sequel = initSequel
544 , cgd_updfr_off = initUpdFrameOff dflags }
545 (result, fork_state_out) = doFCode body_code rhs_info_down
546 (initCgState us)
547 ; setState (state `addCodeBlocksFrom` fork_state_out)
548 ; return result }
549
550 forkProc :: FCode a -> FCode a
551 -- 'forkProc' takes a code and compiles it in the *current* environment,
552 -- returning the graph thus constructed.
553 --
554 -- The current environment is passed on completely unchanged to
555 -- the successor. In particular, any heap usage from the enclosed
556 -- code is discarded; it should deal with its own heap consumption
557 forkProc body_code
558 = do { info_down <- getInfoDown
559 ; us <- newUniqSupply
560 ; state <- getState
561 ; let info_down' = info_down -- { cgd_sequel = initSequel }
562 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
563 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
564 ; setState $ state `addCodeBlocksFrom` fork_state_out
565 ; return result }
566
567 codeOnly :: FCode () -> FCode ()
568 -- Emit any code from the inner thing into the outer thing
569 -- Do not affect anything else in the outer state
570 -- Used in almost-circular code to prevent false loop dependencies
571 codeOnly body_code
572 = do { info_down <- getInfoDown
573 ; us <- newUniqSupply
574 ; state <- getState
575 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
576 cgs_hp_usg = cgs_hp_usg state }
577 ((), fork_state_out) = doFCode body_code info_down fork_state_in
578 ; setState $ state `addCodeBlocksFrom` fork_state_out }
579
580 forkAlts :: [FCode a] -> FCode [a]
581 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
582 -- an fcode for the default case 'd', and compiles each in the current
583 -- environment. The current environment is passed on unmodified, except
584 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
585
586 forkAlts branch_fcodes
587 = do { info_down <- getInfoDown
588 ; us <- newUniqSupply
589 ; state <- getState
590 ; let compile us branch
591 = (us2, doFCode branch info_down branch_state)
592 where
593 (us1,us2) = splitUniqSupply us
594 branch_state = (initCgState us1) {
595 cgs_binds = cgs_binds state,
596 cgs_hp_usg = cgs_hp_usg state }
597
598 (_us, results) = mapAccumL compile us branch_fcodes
599 (branch_results, branch_out_states) = unzip results
600 ; setState $ foldl stateIncUsage state branch_out_states
601 -- NB foldl. state is the *left* argument to stateIncUsage
602 ; return branch_results }
603
604 -- collect the code emitted by an FCode computation
605 getCodeR :: FCode a -> FCode (a, CmmAGraph)
606 getCodeR fcode
607 = do { state1 <- getState
608 ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
609 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
610 ; return (a, cgs_stmts state2) }
611
612 getCode :: FCode a -> FCode CmmAGraph
613 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
614
615 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
616 -- It initialises the heap usage to zeros, and passes on an unchanged
617 -- heap usage.
618 --
619 -- It is usually a prelude to performing a GC check, so everything must
620 -- be in a tidy and consistent state.
621 --
622 -- Note the slightly subtle fixed point behaviour needed here
623
624 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
625 getHeapUsage fcode
626 = do { info_down <- getInfoDown
627 ; state <- getState
628 ; let fstate_in = state { cgs_hp_usg = initHpUsage }
629 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
630 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
631
632 ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
633 ; return r }
634
635 -- ----------------------------------------------------------------------------
636 -- Combinators for emitting code
637
638 emitCgStmt :: CgStmt -> FCode ()
639 emitCgStmt stmt
640 = do { state <- getState
641 ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
642 }
643
644 emitLabel :: BlockId -> FCode ()
645 emitLabel id = emitCgStmt (CgLabel id)
646
647 emitComment :: FastString -> FCode ()
648 #if 0 /* def DEBUG */
649 emitComment s = emitCgStmt (CgStmt (CmmComment s))
650 #else
651 emitComment _ = return ()
652 #endif
653
654 emitAssign :: CmmReg -> CmmExpr -> FCode ()
655 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
656
657 emitStore :: CmmExpr -> CmmExpr -> FCode ()
658 emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
659
660
661 newLabelC :: FCode BlockId
662 newLabelC = do { u <- newUnique
663 ; return $ mkBlockId u }
664
665 emit :: CmmAGraph -> FCode ()
666 emit ag
667 = do { state <- getState
668 ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
669
670 emitDecl :: CmmDecl -> FCode ()
671 emitDecl decl
672 = do { state <- getState
673 ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
674
675 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
676 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
677
678 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
679 -> [CmmFormal] -> CmmAGraph -> FCode ()
680 emitProcWithConvention conv mb_info lbl args blocks
681 = do { dflags <- getDynFlags
682 ; us <- newUniqSupply
683 ; let (offset, entry) = mkCallEntry dflags conv args
684 blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
685 ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)}
686 tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
687 proc_block = CmmProc tinfo lbl blks
688
689 infos | Just info <- mb_info
690 = mapSingleton (g_entry blks) info
691 | otherwise
692 = mapEmpty
693
694 ; state <- getState
695 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
696
697 emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
698 emitProc = emitProcWithConvention NativeNodeCall
699
700 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
701 emitSimpleProc lbl code =
702 emitProc Nothing lbl [] code
703
704 getCmm :: FCode () -> FCode CmmGroup
705 -- Get all the CmmTops (there should be no stmts)
706 -- Return a single Cmm which may be split from other Cmms by
707 -- object splitting (at a later stage)
708 getCmm code
709 = do { state1 <- getState
710 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
711 ; setState $ state2 { cgs_tops = cgs_tops state1 }
712 ; return (fromOL (cgs_tops state2)) }
713
714
715 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
716 mkCmmIfThenElse e tbranch fbranch = do
717 endif <- newLabelC
718 tid <- newLabelC
719 fid <- newLabelC
720 return $ mkCbranch e tid fid <*>
721 mkLabel tid <*> tbranch <*> mkBranch endif <*>
722 mkLabel fid <*> fbranch <*> mkLabel endif
723
724 mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
725 mkCmmIfGoto e tid = do
726 endif <- newLabelC
727 return $ mkCbranch e tid endif <*> mkLabel endif
728
729 mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
730 mkCmmIfThen e tbranch = do
731 endif <- newLabelC
732 tid <- newLabelC
733 return $ mkCbranch e tid endif <*>
734 mkLabel tid <*> tbranch <*> mkLabel endif
735
736
737 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
738 -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
739 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
740 dflags <- getDynFlags
741 k <- newLabelC
742 let area = Young k
743 (off, copyin) = copyInOflow dflags retConv area results
744 copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
745 return (copyout <*> mkLabel k <*> copyin)
746
747 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
748 -> FCode CmmAGraph
749 mkCmmCall f results actuals updfr_off
750 = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
751
752
753 -- ----------------------------------------------------------------------------
754 -- CgStmts
755
756 -- These functions deal in terms of CgStmts, which is an abstract type
757 -- representing the code in the current proc.
758
759 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
760 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
761 cgStmtsToBlocks stmts
762 = do { us <- newUniqSupply
763 ; return (initUs_ us (lgraphOfAGraph stmts)) }