1 -----------------------------------------------------------------------------
3 -- Monad for Stg to C-- code generation
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
12 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
13 returnFC, fixC, fixC_, nopC, whenC,
14 newUnique, newUniqSupply,
16 emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
18 getCmm, cgStmtsToBlocks,
19 getCodeR, getCode, getHeapUsage,
21 forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
26 withSequel, getSequel,
28 setSRTLabel, getSRTLabel,
29 setTickyCtrLabel, getTickyCtrLabel,
31 withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
33 HeapUsage(..), VirtualHpOffset, initHpUsage,
34 getHpUsage, setHpUsage, heapHWM,
35 setVirtHp, getVirtHp, setRealHp,
39 -- ideally we wouldn't export these, but some other modules access internal state
40 getState, setState, getInfoDown, getDynFlags, getThisPackage,
42 -- more localised access to monad state
43 CgIdInfo(..), CgLoc(..),
44 getBinds, setBinds, getStaticBinds,
46 -- out of general friendliness, we also export ...
47 CgInfoDownwards(..), CgState(..) -- non-abstract
50 #include "HsVersions.h"
58 import CmmNode (UpdFrameOffset)
60 import TyCon ( PrimRep )
68 import FastString(sLit)
73 import Prelude hiding( sequence )
74 import qualified Prelude( sequence )
76 infixr 9 `thenC` -- Right-associative!
80 --------------------------------------------------------
81 -- The FCode monad and its types
82 --------------------------------------------------------
84 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
86 instance Monad FCode where
92 {-# INLINE returnFC #-}
94 initC :: DynFlags -> Module -> FCode a -> IO a
95 initC dflags mod (FCode code)
96 = do { uniqs <- mkSplitUniqSupply 'c'
97 ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
98 (res, _) -> return res
101 returnFC :: a -> FCode a
102 returnFC val = FCode (\_info_down state -> (val, state))
104 thenC :: FCode () -> FCode a -> FCode a
105 thenC (FCode m) (FCode k) =
106 FCode (\info_down state -> let (_,new_state) = m info_down state in
107 k info_down new_state)
112 whenC :: Bool -> FCode () -> FCode ()
113 whenC True code = code
114 whenC False _code = nopC
116 listCs :: [FCode ()] -> FCode ()
117 listCs [] = return ()
122 mapCs :: (a -> FCode ()) -> [a] -> FCode ()
125 thenFC :: FCode a -> (a -> FCode c) -> FCode c
126 thenFC (FCode m) k = FCode (
129 (m_result, new_state) = m info_down state
130 (FCode kcode) = k m_result
132 kcode info_down new_state
135 listFCs :: [FCode a] -> FCode [a]
136 listFCs = Prelude.sequence
138 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
141 fixC :: (a -> FCode a) -> FCode a
146 result@(v,_) = fc info_down state
152 fixC_ :: (a -> FCode a) -> FCode ()
153 fixC_ fcode = fixC fcode >> return ()
155 --------------------------------------------------------
156 -- The code generator environment
157 --------------------------------------------------------
159 -- This monadery has some information that it only passes
160 -- *downwards*, as well as some ``state'' which is modified
163 data CgInfoDownwards -- information only passed *downwards* by the monad
165 cgd_dflags :: DynFlags,
166 cgd_mod :: Module, -- Module being compiled
167 cgd_statics :: CgBindings, -- [Id -> info] : static environment
168 cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT
169 cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
170 cgd_ticky :: CLabel, -- Current destination for ticky counts
171 cgd_sequel :: Sequel -- What to do at end of basic block
174 type CgBindings = IdEnv CgIdInfo
178 { cg_id :: Id -- Id that this is the info for
179 -- Can differ from the Id at occurrence sites by
180 -- virtue of being externalised, for splittable C
181 , cg_lf :: LambdaFormInfo
182 , cg_loc :: CgLoc -- CmmExpr for the *tagged* value
183 , cg_rep :: PrimRep -- Cache for (idPrimRep id)
184 , cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf)
188 = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning
189 -- Hp, so that it remains valid across calls
191 | LneLoc BlockId [LocalReg] -- A join point
192 -- A join point (= let-no-escape) should only
193 -- be tail-called, and in a saturated way.
194 -- To tail-call it, assign to these locals,
195 -- and branch to the block id
197 instance Outputable CgIdInfo where
198 ppr (CgIdInfo { cg_id = id, cg_loc = loc })
199 = ppr id <+> ptext (sLit "-->") <+> ppr loc
201 instance Outputable CgLoc where
202 ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e
203 ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
206 -- Sequel tells what to do with the result of this expression
208 = Return Bool -- Return result(s) to continuation found on the stack
209 -- True <=> the continuation is update code (???)
212 [LocalReg] -- Put result(s) in these regs and fall through
213 -- NB: no void arguments here
214 Bool -- Should we adjust the heap pointer back to recover
215 -- space that's unused on this path?
216 -- We need to do this only if the expression may
217 -- allocate (e.g. it's a foreign call or allocating primOp)
218 instance Show Sequel where
219 show (Return _) = "Sequel: Return"
220 show (AssignTo _ _) = "Sequel: Assign"
222 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
223 initCgInfoDown dflags mod
224 = MkCgInfoDown { cgd_dflags = dflags,
226 cgd_statics = emptyVarEnv,
227 cgd_srt_lbl = error "initC: srt_lbl",
228 cgd_updfr_off = initUpdFrameOff,
229 cgd_ticky = mkTopTickyCtrLabel,
230 cgd_sequel = initSequel }
233 initSequel = Return False
235 initUpdFrameOff :: UpdFrameOffset
236 initUpdFrameOff = widthInBytes wordWidth -- space for the RA
239 --------------------------------------------------------
240 -- The code generator state
241 --------------------------------------------------------
245 cgs_stmts :: CmmAGraph, -- Current procedure
247 cgs_tops :: OrdList CmmTop,
248 -- Other procedures and data blocks in this compilation unit
249 -- Both are ordered only so that we can
250 -- reduce forward references, when it's easy to do so
252 cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment
253 -- Bindings for top-level things are given in
254 -- the info-down part
256 cgs_hp_usg :: HeapUsage,
258 cgs_uniqs :: UniqSupply }
262 virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word
263 -- Incremented whenever we allocate
264 realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr
265 -- Used in instruction addressing modes
268 type VirtualHpOffset = WordOff
270 initCgState :: UniqSupply -> CgState
272 = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
273 cgs_binds = emptyVarEnv,
274 cgs_hp_usg = initHpUsage,
277 stateIncUsage :: CgState -> CgState -> CgState
278 -- stateIncUsage@ e1 e2 incorporates in e1
279 -- the heap high water mark found in e2.
280 stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
281 = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
282 `addCodeBlocksFrom` s2
284 addCodeBlocksFrom :: CgState -> CgState -> CgState
285 -- Add code blocks from the latter to the former
286 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
287 s1 `addCodeBlocksFrom` s2
288 = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
289 cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
292 -- The heap high water mark is the larger of virtHp and hwHp. The latter is
293 -- only records the high water marks of forked-off branches, so to find the
294 -- heap high water mark you have to take the max of virtHp and hwHp. Remember,
295 -- virtHp never retreats!
297 -- Note Jan 04: ok, so why do we only look at the virtual Hp??
299 heapHWM :: HeapUsage -> VirtualHpOffset
302 initHpUsage :: HeapUsage
303 initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
305 maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
306 hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
309 --------------------------------------------------------
310 -- Operators for getting and setting the state and "info_down".
311 --------------------------------------------------------
313 getState :: FCode CgState
314 getState = FCode $ \_info_down state -> (state,state)
316 setState :: CgState -> FCode ()
317 setState state = FCode $ \_info_down _ -> ((),state)
319 getHpUsage :: FCode HeapUsage
322 return $ cgs_hp_usg state
324 setHpUsage :: HeapUsage -> FCode ()
325 setHpUsage new_hp_usg = do
327 setState $ state {cgs_hp_usg = new_hp_usg}
329 setVirtHp :: VirtualHpOffset -> FCode ()
331 = do { hp_usage <- getHpUsage
332 ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
334 getVirtHp :: FCode VirtualHpOffset
336 = do { hp_usage <- getHpUsage
337 ; return (virtHp hp_usage) }
339 setRealHp :: VirtualHpOffset -> FCode ()
341 = do { hp_usage <- getHpUsage
342 ; setHpUsage (hp_usage {realHp = new_realHp}) }
344 getBinds :: FCode CgBindings
347 return $ cgs_binds state
349 setBinds :: CgBindings -> FCode ()
350 setBinds new_binds = do
352 setState $ state {cgs_binds = new_binds}
354 getStaticBinds :: FCode CgBindings
357 return (cgd_statics info)
359 withState :: FCode a -> CgState -> FCode (a,CgState)
360 withState (FCode fcode) newstate = FCode $ \info_down state ->
361 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
363 newUniqSupply :: FCode UniqSupply
366 let (us1, us2) = splitUniqSupply (cgs_uniqs state)
367 setState $ state { cgs_uniqs = us1 }
370 newUnique :: FCode Unique
373 return (uniqFromSupply us)
376 getInfoDown :: FCode CgInfoDownwards
377 getInfoDown = FCode $ \info_down state -> (info_down,state)
379 getDynFlags :: FCode DynFlags
380 getDynFlags = liftM cgd_dflags getInfoDown
382 getThisPackage :: FCode PackageId
383 getThisPackage = liftM thisPackage getDynFlags
385 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
386 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
388 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
389 doFCode (FCode fcode) info_down state = fcode info_down state
392 -- ----------------------------------------------------------------------------
393 -- Get the current module name
395 getModuleName :: FCode Module
396 getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
398 -- ----------------------------------------------------------------------------
399 -- Get/set the end-of-block info
401 withSequel :: Sequel -> FCode () -> FCode ()
402 withSequel sequel code
403 = do { info <- getInfoDown
404 ; withInfoDown code (info {cgd_sequel = sequel }) }
406 getSequel :: FCode Sequel
407 getSequel = do { info <- getInfoDown
408 ; return (cgd_sequel info) }
410 -- ----------------------------------------------------------------------------
411 -- Get/set the current SRT label
413 -- There is just one SRT for each top level binding; all the nested
414 -- bindings use sub-sections of this SRT. The label is passed down to
415 -- the nested bindings via the monad.
417 getSRTLabel :: FCode CLabel -- Used only by cgPanic
418 getSRTLabel = do info <- getInfoDown
419 return (cgd_srt_lbl info)
421 setSRTLabel :: CLabel -> FCode a -> FCode a
422 setSRTLabel srt_lbl code
423 = do info <- getInfoDown
424 withInfoDown code (info { cgd_srt_lbl = srt_lbl})
426 -- ----------------------------------------------------------------------------
427 -- Get/set the size of the update frame
429 -- We keep track of the size of the update frame so that we
430 -- can set the stack pointer to the proper address on return
431 -- (or tail call) from the closure.
432 -- There should be at most one update frame for each closure.
433 -- Note: I'm including the size of the original return address
434 -- in the size of the update frame -- hence the default case on `get'.
436 withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
437 withUpdFrameOff size code
438 = do { info <- getInfoDown
439 ; withInfoDown code (info {cgd_updfr_off = size }) }
441 getUpdFrameOff :: FCode UpdFrameOffset
443 = do { info <- getInfoDown
444 ; return $ cgd_updfr_off info }
446 -- ----------------------------------------------------------------------------
447 -- Get/set the current ticky counter label
449 getTickyCtrLabel :: FCode CLabel
450 getTickyCtrLabel = do
452 return (cgd_ticky info)
454 setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
455 setTickyCtrLabel ticky code = do
457 withInfoDown code (info {cgd_ticky = ticky})
460 --------------------------------------------------------
462 --------------------------------------------------------
464 forkClosureBody :: FCode () -> FCode ()
465 -- forkClosureBody takes a code, $c$, and compiles it in a
466 -- fresh environment, except that:
467 -- - compilation info and statics are passed in unchanged.
468 -- - local bindings are passed in unchanged
469 -- (it's up to the enclosed code to re-bind the
470 -- free variables to a field of the closure)
472 -- The current state is passed on completely unaltered, except that
473 -- C-- from the fork is incorporated.
475 forkClosureBody body_code
476 = do { info <- getInfoDown
477 ; us <- newUniqSupply
479 ; let body_info_down = info { cgd_sequel = initSequel
480 , cgd_updfr_off = initUpdFrameOff }
481 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
483 = doFCode body_code body_info_down fork_state_in
484 ; setState $ state `addCodeBlocksFrom` fork_state_out }
486 forkStatics :: FCode a -> FCode a
487 -- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
488 -- from the current *local bindings*, but which is otherwise freshly initialised.
489 -- The Abstract~C returned is attached to the current state, but the
490 -- bindings and usage information is otherwise unchanged.
491 forkStatics body_code
492 = do { info <- getInfoDown
493 ; us <- newUniqSupply
495 ; let rhs_info_down = info { cgd_statics = cgs_binds state
496 , cgd_sequel = initSequel
497 , cgd_updfr_off = initUpdFrameOff }
498 (result, fork_state_out) = doFCode body_code rhs_info_down
500 ; setState (state `addCodeBlocksFrom` fork_state_out)
503 forkProc :: FCode a -> FCode a
504 -- 'forkProc' takes a code and compiles it in the *current* environment,
505 -- returning the graph thus constructed.
507 -- The current environment is passed on completely unchanged to
508 -- the successor. In particular, any heap usage from the enclosed
509 -- code is discarded; it should deal with its own heap consumption
511 = do { info_down <- getInfoDown
512 ; us <- newUniqSupply
514 ; let info_down' = info_down -- { cgd_sequel = initSequel }
515 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
516 (result, fork_state_out) = doFCode body_code info_down' fork_state_in
517 ; setState $ state `addCodeBlocksFrom` fork_state_out
520 codeOnly :: FCode () -> FCode ()
521 -- Emit any code from the inner thing into the outer thing
522 -- Do not affect anything else in the outer state
523 -- Used in almost-circular code to prevent false loop dependencies
525 = do { info_down <- getInfoDown
526 ; us <- newUniqSupply
528 ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
529 cgs_hp_usg = cgs_hp_usg state }
530 ((), fork_state_out) = doFCode body_code info_down fork_state_in
531 ; setState $ state `addCodeBlocksFrom` fork_state_out }
533 forkAlts :: [FCode a] -> FCode [a]
534 -- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
535 -- an fcode for the default case 'd', and compiles each in the current
536 -- environment. The current environment is passed on unmodified, except
537 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
539 forkAlts branch_fcodes
540 = do { info_down <- getInfoDown
541 ; us <- newUniqSupply
543 ; let compile us branch
544 = (us2, doFCode branch info_down branch_state)
546 (us1,us2) = splitUniqSupply us
547 branch_state = (initCgState us1) {
548 cgs_binds = cgs_binds state,
549 cgs_hp_usg = cgs_hp_usg state }
551 (_us, results) = mapAccumL compile us branch_fcodes
552 (branch_results, branch_out_states) = unzip results
553 ; setState $ foldl stateIncUsage state branch_out_states
554 -- NB foldl. state is the *left* argument to stateIncUsage
555 ; return branch_results }
557 -- collect the code emitted by an FCode computation
558 getCodeR :: FCode a -> FCode (a, CmmAGraph)
560 = do { state1 <- getState
561 ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
562 ; setState $ state2 { cgs_stmts = cgs_stmts state1 }
563 ; return (a, cgs_stmts state2) }
565 getCode :: FCode a -> FCode CmmAGraph
566 getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
568 -- 'getHeapUsage' applies a function to the amount of heap that it uses.
569 -- It initialises the heap usage to zeros, and passes on an unchanged
572 -- It is usually a prelude to performing a GC check, so everything must
573 -- be in a tidy and consistent state.
575 -- Note the slightly subtle fixed point behaviour needed here
577 getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
579 = do { info_down <- getInfoDown
581 ; let fstate_in = state { cgs_hp_usg = initHpUsage }
582 (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
583 hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here!
585 ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
588 -- ----------------------------------------------------------------------------
589 -- Combinators for emitting code
591 emit :: CmmAGraph -> FCode ()
593 = do { state <- getState
594 ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
596 emitData :: Section -> [CmmStatic] -> FCode ()
598 = do { state <- getState
599 ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
601 data_block = CmmData sect lits
603 emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] ->
604 CmmAGraph -> FCode ()
605 emitProcWithConvention conv info lbl args blocks
606 = do { us <- newUniqSupply
607 ; let (offset, entry) = mkCallEntry conv args
608 blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
609 ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
610 proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks
612 ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
614 emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
615 emitProc = emitProcWithConvention NativeNodeCall
617 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
618 emitSimpleProc lbl code =
619 emitProc CmmNonInfoTable lbl [] code
621 getCmm :: FCode () -> FCode Cmm
622 -- Get all the CmmTops (there should be no stmts)
623 -- Return a single Cmm which may be split from other Cmms by
624 -- object splitting (at a later stage)
626 = do { state1 <- getState
627 ; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
628 ; setState $ state2 { cgs_tops = cgs_tops state1 }
629 ; return (Cmm (fromOL (cgs_tops state2))) }
631 -- ----------------------------------------------------------------------------
634 -- These functions deal in terms of CgStmts, which is an abstract type
635 -- representing the code in the current proc.
637 -- turn CgStmts into [CmmBasicBlock], for making a new proc.
638 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
639 cgStmtsToBlocks stmts
640 = do { us <- newUniqSupply
641 ; return (initUs_ us (lgraphOfAGraph stmts)) }