2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.15 1998/12/02 13:17:50 simonm Exp $
6 \section[CgMonad]{The code generation monad}
8 See the beginning of the top-level @CodeGen@ module, to see how this
9 monadic stuff fits into the Big Picture.
16 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
17 returnFC, fixC, absC, nopC, getAbsC,
19 forkClosureBody, forkStatics, forkAlts, forkEval,
20 forkEvalHelp, forkAbsC,
23 addBindC, addBindsC, modifyBindC, lookupBindC,
26 setEndOfBlockInfo, getEndOfBlockInfo,
28 setSRTLabel, getSRTLabel,
30 StackUsage, HeapUsage,
34 costCentresC, moduleName,
36 Sequel(..), -- ToDo: unabstract?
39 -- out of general friendliness, we also export ...
40 CgInfoDownwards(..), CgState(..), -- non-abstract
44 #include "HsVersions.h"
46 import {-# SOURCE #-} CgBindery ( CgIdInfo(..), CgBindings, maybeStkLoc, nukeVolatileBinds )
47 import {-# SOURCE #-} CgUsages ( getSpRelOffset )
50 import AbsCUtils ( mkAbsCStmts )
51 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
52 import CLabel ( CLabel, mkUpdEntryLabel )
53 import DataCon ( ConTag )
56 import PrimRep ( getPrimRepSize, PrimRep(..) )
57 import StgSyn ( StgLiveVars )
60 infixr 9 `thenC` -- Right-associative!
64 %************************************************************************
66 \subsection[CgMonad-environment]{Stuff for manipulating environments}
68 %************************************************************************
70 This monadery has some information that it only passes {\em
71 downwards}, as well as some ``state'' which is modified as we go
75 data CgInfoDownwards -- information only passed *downwards* by the monad
77 CompilationInfo -- COMPLETELY STATIC info about this compilation
78 -- (e.g., what flags were passed to the compiler)
80 CgBindings -- [Id -> info] : static environment
82 CLabel -- label of the current SRT
84 EndOfBlockInfo -- Info for stuff to do at end of basic block:
89 FAST_STRING -- the module name
93 AbstractC -- code accumulated so far
94 CgBindings -- [Id -> info] : *local* bindings environment
95 -- Bindings for top-level things are given in the info-down part
99 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
100 if the expression is a @case@, what to do at the end of each
106 VirtualSpOffset -- Args Sp: trim the stack to this point at a
107 -- return; push arguments starting just
108 -- above this point on a tail call.
110 -- This is therefore the stk ptr as seen
111 -- by a case alternative.
114 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
117 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
118 that it must survive stack pointer adjustments at the end of the
124 VirtualSpOffset -- Continuation is on the stack, at the
125 -- specified location
130 CAddrMode -- Jump to this; if the continuation is for a vectored
131 -- case this might be the label of a return
132 -- vector Guaranteed to be a non-volatile
133 -- addressing mode (I think)
136 | SeqFrame -- like CaseAlts but push a seq frame too.
140 type SemiTaggingStuff
141 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
142 ([(ConTag, JoinDetails)], -- Alternatives
143 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
144 -- Maybe[3] the default is a
145 -- bind-default (Just b); that is,
146 -- it expects a ptr to the thing
147 -- in Node, bound to b
151 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
152 -- and join point label
154 -- The abstract C is executed only from a successful semitagging
155 -- venture, when a case has looked at a variable, found that it's
156 -- evaluated, and wants to load up the contents and go to the join
160 -- The OnStack case of sequelToAmode delivers an Amode which is only
161 -- valid just before the final control transfer, because it assumes
162 -- that Sp is pointing to the top word of the return address. This
163 -- seems unclean but there you go.
165 sequelToAmode :: Sequel -> FCode CAddrMode
167 sequelToAmode (OnStack virt_sp_offset)
168 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
169 returnFC (CVal sp_rel RetRep)
171 sequelToAmode UpdateCode = returnFC (CLbl mkUpdEntryLabel CodePtrRep)
172 sequelToAmode (CaseAlts amode _) = returnFC amode
173 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
175 type CgStksAndHeapUsage -- stacks and heap usage information
176 = (StackUsage, HeapUsage)
179 (Int, -- virtSp: Virtual offset of topmost allocated slot
180 [Int], -- free: List of free slots, in increasing order
181 Int, -- realSp: Virtual offset of real stack pointer
182 Int) -- hwSp: Highest value ever taken by virtSp
185 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
186 HeapOffset) -- realHp: Virtual offset of real heap ptr
189 NB: absolutely every one of the above Ints is really
190 a VirtualOffset of some description (the code generator
191 works entirely in terms of VirtualOffsets).
196 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
198 initUsage :: CgStksAndHeapUsage
199 initUsage = ((0,[],0,0), (initVirtHp, initRealHp))
200 initVirtHp = panic "Uninitialised virtual Hp"
201 initRealHp = panic "Uninitialised real Hp"
204 "envInitForAlternatives" initialises the environment for a case alternative,
205 assuming that the alternative is entered after an evaluation.
208 - zapping any volatile bindings, which aren't valid.
210 - zapping the heap usage. It should be restored by a heap check.
212 - setting the virtual AND real stack pointer fields to the given
213 virtual stack offsets. this doesn't represent any {\em code}; it is a
214 prediction of where the real stack pointer will be when we come back
215 from the case analysis.
217 - BUT LEAVING the rest of the stack-usage info because it is all
218 valid. In particular, we leave the tail stack pointers unchanged,
219 becuase the alternative has to de-allocate the original @case@
220 expression's stack. \end{itemize}
222 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
223 marks found in $e_2$.
226 stateIncUsage :: CgState -> CgState -> CgState
228 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
229 (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
232 ((v,f,r,h1 `max` h2),
233 (vH1 `max` vH2, rH1))
236 %************************************************************************
238 \subsection[CgMonad-basics]{Basic code-generation monad magic}
240 %************************************************************************
243 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
244 type Code = CgInfoDownwards -> CgState -> CgState
247 {-# INLINE thenFC #-}
248 {-# INLINE returnFC #-}
250 The Abstract~C is not in the environment so as to improve strictness.
253 initC :: CompilationInfo -> Code -> AbstractC
256 = case (code (MkCgInfoDown
258 (error "initC: statics")
262 MkCgState abc _ _ -> abc
264 returnFC :: a -> FCode a
266 returnFC val info_down state = (val, state)
271 -> (CgInfoDownwards -> CgState -> a)
272 -> CgInfoDownwards -> CgState -> a
274 -- thenC has both of the following types:
275 -- thenC :: Code -> Code -> Code
276 -- thenC :: Code -> FCode a -> FCode a
278 thenC m k info_down state
279 = k info_down new_state
281 new_state = m info_down state
283 listCs :: [Code] -> Code
285 listCs [] info_down state = state
286 listCs (c:cs) info_down state = stateN
288 state1 = c info_down state
289 stateN = listCs cs info_down state1
291 mapCs :: (a -> Code) -> [a] -> Code
293 mapCs f [] info_down state = state
294 mapCs f (c:cs) info_down state = stateN
296 state1 = (f c) info_down state
297 stateN = mapCs f cs info_down state1
302 -> (a -> CgInfoDownwards -> CgState -> c)
303 -> CgInfoDownwards -> CgState -> c
305 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
306 -- thenFC :: FCode a -> (a -> Code) -> Code
308 thenFC m k info_down state
309 = k m_result info_down new_state
311 (m_result, new_state) = m info_down state
313 listFCs :: [FCode a] -> FCode [a]
315 listFCs [] info_down state = ([], state)
316 listFCs (fc:fcs) info_down state = (thing : things, stateN)
318 (thing, state1) = fc info_down state
319 (things, stateN) = listFCs fcs info_down state1
321 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
323 mapFCs f [] info_down state = ([], state)
324 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
326 (thing, state1) = (f fc) info_down state
327 (things, stateN) = mapFCs f fcs info_down state1
330 And the knot-tying combinator:
332 fixC :: (a -> FCode a) -> FCode a
333 fixC fcode info_down state = result
335 result@(v, _) = fcode v info_down state
339 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
340 fresh environment, except that:
341 - compilation info and statics are passed in unchanged.
342 The current environment is passed on completely unaltered, except that
343 abstract C from the fork is incorporated.
345 @forkAbsC@ takes a code and compiles it in the current environment,
346 returning the abstract C thus constructed. The current environment
347 is passed on completely unchanged. It is pretty similar to @getAbsC@,
348 except that the latter does affect the environment. ToDo: combine?
350 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
351 from the current bindings, but which is otherwise freshly initialised.
352 The Abstract~C returned is attached to the current state, but the
353 bindings and usage information is otherwise unchanged.
356 forkClosureBody :: Code -> Code
359 (MkCgInfoDown cg_info statics srt _)
360 (MkCgState absC_in binds un_usage)
361 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
363 fork_state = code body_info_down initialStateC
364 MkCgState absC_fork _ _ = fork_state
365 body_info_down = MkCgInfoDown cg_info statics srt initEobInfo
367 forkStatics :: FCode a -> FCode a
369 forkStatics fcode (MkCgInfoDown cg_info _ srt _)
370 (MkCgState absC_in statics un_usage)
371 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
373 (result, state) = fcode rhs_info_down initialStateC
374 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
375 -- above or it becomes too strict!
376 rhs_info_down = MkCgInfoDown cg_info statics srt initEobInfo
378 forkAbsC :: Code -> FCode AbstractC
379 forkAbsC code info_down (MkCgState absC1 bs usage)
382 MkCgState absC2 _ ((_, _, _,h2), _) =
383 code info_down (MkCgState AbsCNop bs usage)
384 ((v, f, r, h1), heap_usage) = usage
386 new_usage = ((v, f, r, h1 `max` h2), heap_usage)
387 new_state = MkCgState absC1 bs new_usage
390 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
391 an fcode for the default case $d$, and compiles each in the current
392 environment. The current environment is passed on unmodified, except
394 - the worst stack high-water mark is incorporated
395 - the virtual Hp is moved on to the worst virtual Hp for the branches
398 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
400 forkAlts branch_fcodes deflt_fcode info_down in_state
401 = ((branch_results , deflt_result), out_state)
403 compile fc = fc info_down in_state
405 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
407 (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
409 out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
410 -- NB foldl. in_state is the *left* argument to stateIncUsage
413 @forkEval@ takes two blocks of code.
415 - The first meddles with the environment to set it up as expected by
416 the alternatives of a @case@ which does an eval (or gc-possible primop).
417 - The second block is the code for the alternatives.
418 (plus info for semi-tagging purposes)
420 @forkEval@ picks up the virtual stack pointer and returns a suitable
421 @EndOfBlockInfo@ for the caller to use, together with whatever value
422 is returned by the second block.
424 It uses @initEnvForAlternatives@ to initialise the environment, and
425 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
429 forkEval :: EndOfBlockInfo -- For the body
430 -> Code -- Code to set environment
431 -> FCode Sequel -- Semi-tagging info to store
432 -> FCode EndOfBlockInfo -- The new end of block info
434 forkEval body_eob_info env_code body_code
435 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
436 returnFC (EndOfBlockInfo v sequel)
438 forkEvalHelp :: EndOfBlockInfo -- For the body
439 -> Code -- Code to set environment
440 -> FCode a -- The code to do after the eval
442 a) -- Result of the FCode
444 forkEvalHelp body_eob_info env_code body_code
445 info_down@(MkCgInfoDown cg_info statics srt _) state
446 = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
448 info_down_for_body = MkCgInfoDown cg_info statics srt body_eob_info
450 (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
451 -- These v and f things are now set up as the body code expects them
453 (value_returned, state_at_end_return)
454 = body_code info_down_for_body state_for_body
456 state_for_body = MkCgState AbsCNop
457 (nukeVolatileBinds binds)
459 (initVirtHp, initRealHp))
462 stateIncUsageEval :: CgState -> CgState -> CgState
463 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
464 (MkCgState absC2 _ ((_,_,_,h2), _))
465 = MkCgState (absC1 `AbsCStmts` absC2)
466 -- The AbsC coming back should consist only of nested declarations,
467 -- notably of the return vector!
469 ((v,f,r,h1 `max` h2), heap_usage)
470 -- We don't max the heap high-watermark because stateIncUsageEval is
471 -- used only in forkEval, which in turn is only used for blocks of code
472 -- which do their own heap-check.
475 %************************************************************************
477 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
479 %************************************************************************
481 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
482 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
485 nopC info_down state = state
487 absC :: AbstractC -> Code
488 absC more_absC info_down state@(MkCgState absC binds usage)
489 = MkCgState (mkAbsCStmts absC more_absC) binds usage
492 These two are just like @absC@, except they examine the compilation
493 info (whether SCC profiling or profiling-ctrs going) and possibly emit
497 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
499 costCentresC macro args _ state@(MkCgState absC binds usage)
500 = if opt_SccProfilingOn
501 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
504 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
506 profCtrC macro args _ state@(MkCgState absC binds usage)
507 = if not opt_DoTickyProfiling
509 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
511 {- Try to avoid adding too many special compilation strategies here.
512 It's better to modify the header files as necessary for particular
513 targets, so that we can get away with as few variants of .hc files
518 @getAbsC@ compiles the code in the current environment, and returns
519 the abstract C thus constructed (leaving the abstract C being carried
520 around in the state untouched). @getAbsC@ does not generate any
521 in-line Abstract~C itself, but the environment it returns is that
522 obtained from the compilation.
525 getAbsC :: Code -> FCode AbstractC
527 getAbsC code info_down (MkCgState absC binds usage)
528 = (absC2, MkCgState absC binds2 usage2)
530 (MkCgState absC2 binds2 usage2)
531 = code info_down (MkCgState AbsCNop binds usage)
536 moduleName :: FCode FAST_STRING
537 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
543 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
544 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt _) state
545 = code (MkCgInfoDown c_info statics srt eob_info) state
547 getEndOfBlockInfo :: FCode EndOfBlockInfo
548 getEndOfBlockInfo (MkCgInfoDown c_info statics _ eob_info) state
553 getSRTLabel :: FCode CLabel
554 getSRTLabel (MkCgInfoDown _ _ srt _) state
557 setSRTLabel :: CLabel -> Code -> Code
558 setSRTLabel srt code (MkCgInfoDown c_info statics _ eob_info) state
559 = code (MkCgInfoDown c_info statics srt eob_info) state
562 %************************************************************************
564 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
566 %************************************************************************
568 There are three basic routines, for adding (@addBindC@), modifying
569 (@modifyBindC@) and looking up (@lookupBindC@) bindings.
571 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
572 The name should not already be bound. (nice ASSERT, eh?)
575 addBindC :: Id -> CgIdInfo -> Code
576 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
577 = MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
579 addBindsC :: [(Id, CgIdInfo)] -> Code
580 addBindsC new_bindings info_down (MkCgState absC binds usage)
581 = MkCgState absC new_binds usage
583 new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
587 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
588 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
589 = MkCgState absC (modifyVarEnv mangle_fn binds name) usage
591 lookupBindC :: Id -> FCode CgIdInfo
592 lookupBindC name info_down@(MkCgInfoDown _ static_binds srt _)
593 state@(MkCgState absC local_binds usage)
596 val = case (lookupVarEnv local_binds name) of
597 Nothing -> try_static
601 case (lookupVarEnv static_binds name) of
604 -> pprPanic "lookupBindC:no info!\n"
606 hsep [ptext SLIT("for:"), ppr name],
607 ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
608 ptext SLIT("static binds for:"),
609 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
610 ptext SLIT("local binds for:"),
611 vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv local_binds ]