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