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