2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.35 2002/09/13 15:02:28 simonpj 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,
24 setEndOfBlockInfo, getEndOfBlockInfo,
26 setSRTLabel, getSRTLabel, getSRTInfo,
27 setTickyCtrLabel, getTickyCtrLabel,
29 StackUsage, Slot(..), HeapUsage,
31 profCtrC, profCtrAbsC, ldvEnter,
33 costCentresC, moduleName,
35 Sequel(..), -- ToDo: unabstract?
38 -- ideally we wouldn't export these, but some other modules access internal state
39 getState, setState, getInfoDown,
41 -- more localised access to monad state
43 getBinds, setBinds, getStaticBinds,
45 -- out of general friendliness, we also export ...
46 CgInfoDownwards(..), CgState(..), -- non-abstract
50 #include "HsVersions.h"
52 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
53 import {-# SOURCE #-} CgUsages ( getSpRelOffset )
56 import StgSyn ( SRT(..) )
57 import AbsCUtils ( mkAbsCStmts )
58 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
59 import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
60 import Module ( Module )
61 import DataCon ( ConTag )
64 import PrimRep ( PrimRep(..) )
68 infixr 9 `thenC` -- Right-associative!
72 %************************************************************************
74 \subsection[CgMonad-environment]{Stuff for manipulating environments}
76 %************************************************************************
78 This monadery has some information that it only passes {\em
79 downwards}, as well as some ``state'' which is modified as we go
83 data CgInfoDownwards -- information only passed *downwards* by the monad
85 CompilationInfo -- COMPLETELY STATIC info about this compilation
86 -- (e.g., what flags were passed to the compiler)
88 CgBindings -- [Id -> info] : static environment
90 CLabel -- label of the current SRT
92 CLabel -- current destination for ticky counts
94 EndOfBlockInfo -- Info for stuff to do at end of basic block:
99 Module -- the module name
103 AbstractC -- code accumulated so far
104 CgBindings -- [Id -> info] : *local* bindings environment
105 -- Bindings for top-level things are given in the info-down part
109 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
110 if the expression is a @case@, what to do at the end of each
116 VirtualSpOffset -- Args Sp: trim the stack to this point at a
117 -- return; push arguments starting just
118 -- above this point on a tail call.
120 -- This is therefore the stk ptr as seen
121 -- by a case alternative.
124 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
127 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
128 that it must survive stack pointer adjustments at the end of the
134 VirtualSpOffset -- Continuation is on the stack, at the
135 -- specified location
140 CAddrMode -- Jump to this; if the continuation is for a vectored
141 -- case this might be the label of a return
142 -- vector Guaranteed to be a non-volatile
143 -- addressing mode (I think)
146 | SeqFrame -- like CaseAlts but push a seq frame too.
150 type SemiTaggingStuff
151 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
152 ([(ConTag, JoinDetails)], -- Alternatives
153 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
154 -- Maybe[3] the default is a
155 -- bind-default (Just b); that is,
156 -- it expects a ptr to the thing
157 -- in Node, bound to b
161 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
162 -- and join point label
164 -- The abstract C is executed only from a successful semitagging
165 -- venture, when a case has looked at a variable, found that it's
166 -- evaluated, and wants to load up the contents and go to the join
170 -- The OnStack case of sequelToAmode delivers an Amode which is only
171 -- valid just before the final control transfer, because it assumes
172 -- that Sp is pointing to the top word of the return address. This
173 -- seems unclean but there you go.
175 -- sequelToAmode returns an amode which refers to an info table. The info
176 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
177 -- not to handle real code pointers, just in case we're compiling for
178 -- an unregisterised/untailcallish architecture, where info pointers and
179 -- code pointers aren't the same.
181 sequelToAmode :: Sequel -> FCode CAddrMode
183 sequelToAmode (OnStack virt_sp_offset)
184 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
185 returnFC (CVal sp_rel RetRep)
187 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
188 sequelToAmode (CaseAlts amode _) = returnFC amode
189 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
191 type CgStksAndHeapUsage -- stacks and heap usage information
192 = (StackUsage, HeapUsage)
194 data Slot = Free | NonPointer
203 (Int, -- virtSp: Virtual offset of topmost allocated slot
204 [(Int,Slot)], -- free: List of free slots, in increasing order
205 Int, -- realSp: Virtual offset of real stack pointer
206 Int) -- hwSp: Highest value ever taken by virtSp
209 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
210 HeapOffset) -- realHp: Virtual offset of real heap ptr
213 NB: absolutely every one of the above Ints is really
214 a VirtualOffset of some description (the code generator
215 works entirely in terms of VirtualOffsets).
220 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
222 initUsage :: CgStksAndHeapUsage
223 initUsage = ((0,[],0,0), (0,0))
226 "envInitForAlternatives" initialises the environment for a case alternative,
227 assuming that the alternative is entered after an evaluation.
230 - zapping any volatile bindings, which aren't valid.
232 - zapping the heap usage. It should be restored by a heap check.
234 - setting the virtual AND real stack pointer fields to the given
235 virtual stack offsets. this doesn't represent any {\em code}; it is a
236 prediction of where the real stack pointer will be when we come back
237 from the case analysis.
239 - BUT LEAVING the rest of the stack-usage info because it is all
240 valid. In particular, we leave the tail stack pointers unchanged,
241 becuase the alternative has to de-allocate the original @case@
242 expression's stack. \end{itemize}
244 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
245 marks found in $e_2$.
248 stateIncUsage :: CgState -> CgState -> CgState
250 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
251 (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
254 ((v,f,r,h1 `max` h2),
255 (vH1 `max` vH2, rH1))
258 %************************************************************************
260 \subsection[CgMonad-basics]{Basic code-generation monad magic}
262 %************************************************************************
265 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
268 instance Monad FCode where
273 {-# INLINE thenFC #-}
274 {-# INLINE returnFC #-}
276 The Abstract~C is not in the environment so as to improve strictness.
279 initC :: CompilationInfo -> Code -> AbstractC
281 initC cg_info (FCode code)
282 = case (code (MkCgInfoDown
284 emptyVarEnv -- (error "initC: statics")
289 ((),MkCgState abc _ _) -> abc
291 returnFC :: a -> FCode a
292 returnFC val = FCode (\info_down state -> (val, state))
296 thenC :: Code -> FCode a -> FCode a
297 thenC (FCode m) (FCode k) =
298 FCode (\info_down state -> let (_,new_state) = m info_down state in
299 k info_down new_state)
301 listCs :: [Code] -> Code
302 listCs [] = return ()
307 mapCs :: (a -> Code) -> [a] -> Code
312 thenFC :: FCode a -> (a -> FCode c) -> FCode c
313 thenFC (FCode m) k = FCode (
316 (m_result, new_state) = m info_down state
317 (FCode kcode) = k m_result
319 kcode info_down new_state
322 listFCs :: [FCode a] -> FCode [a]
325 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
329 And the knot-tying combinator:
331 fixC :: (a -> FCode a) -> FCode a
336 result@(v,_) = fc info_down state
343 Operators for getting and setting the state and "info_down".
344 To maximise encapsulation, code should try to only get and set the
345 state it actually uses.
348 getState :: FCode CgState
349 getState = FCode $ \info_down state -> (state,state)
351 setState :: CgState -> FCode ()
352 setState state = FCode $ \info_down _ -> ((),state)
354 getUsage :: FCode CgStksAndHeapUsage
356 MkCgState absC binds usage <- getState
359 setUsage :: CgStksAndHeapUsage -> FCode ()
360 setUsage newusage = do
361 MkCgState absC binds usage <- getState
362 setState $ MkCgState absC binds newusage
364 getBinds :: FCode CgBindings
366 MkCgState absC binds usage <- getState
369 setBinds :: CgBindings -> FCode ()
370 setBinds newbinds = do
371 MkCgState absC binds usage <- getState
372 setState $ MkCgState absC newbinds usage
374 getStaticBinds :: FCode CgBindings
376 (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
379 withState :: FCode a -> CgState -> FCode (a,CgState)
380 withState (FCode fcode) newstate = FCode $ \info_down state ->
381 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
383 getInfoDown :: FCode CgInfoDownwards
384 getInfoDown = FCode $ \info_down state -> (info_down,state)
386 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
387 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
389 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
390 doFCode (FCode fcode) info_down state = fcode info_down state
394 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
395 fresh environment, except that:
396 - compilation info and statics are passed in unchanged.
397 The current environment is passed on completely unaltered, except that
398 abstract C from the fork is incorporated.
400 @forkAbsC@ takes a code and compiles it in the current environment,
401 returning the abstract C thus constructed. The current environment
402 is passed on completely unchanged. It is pretty similar to @getAbsC@,
403 except that the latter does affect the environment. ToDo: combine?
405 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
406 from the current bindings, but which is otherwise freshly initialised.
407 The Abstract~C returned is attached to the current state, but the
408 bindings and usage information is otherwise unchanged.
411 forkClosureBody :: Code -> Code
413 forkClosureBody (FCode code) = do
414 (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
415 (MkCgState absC_in binds un_usage) <- getState
416 let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
417 let ((),fork_state) = code body_info_down initialStateC
418 let MkCgState absC_fork _ _ = fork_state
419 setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
421 forkStatics :: FCode a -> FCode a
423 forkStatics (FCode fcode) = FCode (
424 \(MkCgInfoDown cg_info _ srt ticky _)
425 (MkCgState absC_in statics un_usage)
428 (result, state) = fcode rhs_info_down initialStateC
429 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
430 -- above or it becomes too strict!
431 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
433 (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
436 forkAbsC :: Code -> FCode AbstractC
437 forkAbsC (FCode code) =
439 info_down <- getInfoDown
440 (MkCgState absC1 bs usage) <- getState
441 let ((),MkCgState absC2 _ ((_, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
442 let ((v, f, r, h1), heap_usage) = usage
443 let new_usage = ((v, f, r, h1 `max` h2), heap_usage)
444 setState $ MkCgState absC1 bs new_usage
448 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
449 an fcode for the default case $d$, and compiles each in the current
450 environment. The current environment is passed on unmodified, except
452 - the worst stack high-water mark is incorporated
453 - the virtual Hp is moved on to the worst virtual Hp for the branches
456 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
458 forkAlts branch_fcodes (FCode deflt_fcode) =
460 info_down <- getInfoDown
462 let compile (FCode fc) = fc info_down in_state
463 let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
464 let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
465 setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
466 -- NB foldl. in_state is the *left* argument to stateIncUsage
467 return (branch_results, deflt_result)
471 @forkEval@ takes two blocks of code.
473 - The first meddles with the environment to set it up as expected by
474 the alternatives of a @case@ which does an eval (or gc-possible primop).
475 - The second block is the code for the alternatives.
476 (plus info for semi-tagging purposes)
478 @forkEval@ picks up the virtual stack pointer and returns a suitable
479 @EndOfBlockInfo@ for the caller to use, together with whatever value
480 is returned by the second block.
482 It uses @initEnvForAlternatives@ to initialise the environment, and
483 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
487 forkEval :: EndOfBlockInfo -- For the body
488 -> Code -- Code to set environment
489 -> FCode Sequel -- Semi-tagging info to store
490 -> FCode EndOfBlockInfo -- The new end of block info
492 forkEval body_eob_info env_code body_code
493 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
494 returnFC (EndOfBlockInfo v sequel)
496 forkEvalHelp :: EndOfBlockInfo -- For the body
497 -> Code -- Code to set environment
498 -> FCode a -- The code to do after the eval
500 a) -- Result of the FCode
502 forkEvalHelp body_eob_info env_code body_code =
504 info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
506 let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
507 let (_,MkCgState _ binds ((v,f,_,_),_)) =
508 doFCode env_code info_down_for_body state
509 let state_for_body = MkCgState AbsCNop
510 (nukeVolatileBinds binds)
512 let (value_returned, state_at_end_return) =
513 doFCode body_code info_down_for_body state_for_body
514 setState $ state `stateIncUsageEval` state_at_end_return
515 return (v,value_returned)
517 stateIncUsageEval :: CgState -> CgState -> CgState
518 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
519 (MkCgState absC2 _ ((_,_,_,h2), _))
520 = MkCgState (absC1 `mkAbsCStmts` absC2)
521 -- The AbsC coming back should consist only of nested declarations,
522 -- notably of the return vector!
524 ((v,f,r,h1 `max` h2), heap_usage)
525 -- We don't max the heap high-watermark because stateIncUsageEval is
526 -- used only in forkEval, which in turn is only used for blocks of code
527 -- which do their own heap-check.
530 %************************************************************************
532 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
534 %************************************************************************
536 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
537 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
542 absC :: AbstractC -> Code
544 state@(MkCgState absC binds usage) <- getState
545 setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
548 These two are just like @absC@, except they examine the compilation
549 info (whether SCC profiling or profiling-ctrs going) and possibly emit
553 costCentresC :: FastString -> [CAddrMode] -> Code
554 costCentresC macro args
555 | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
558 profCtrC :: FastString -> [CAddrMode] -> Code
560 | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
563 profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
564 profCtrAbsC macro args
565 | opt_DoTickyProfiling = CCallProfCtrMacro macro args
566 | otherwise = AbsCNop
569 ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node]
571 {- Try to avoid adding too many special compilation strategies here.
572 It's better to modify the header files as necessary for particular
573 targets, so that we can get away with as few variants of .hc files
578 @getAbsC@ compiles the code in the current environment, and returns
579 the abstract C thus constructed (leaving the abstract C being carried
580 around in the state untouched). @getAbsC@ does not generate any
581 in-line Abstract~C itself, but the environment it returns is that
582 obtained from the compilation.
585 getAbsC :: Code -> FCode AbstractC
587 MkCgState absC binds usage <- getState
588 ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
589 setState $ MkCgState absC binds2 usage2
594 moduleName :: FCode Module
596 (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
601 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
602 setEndOfBlockInfo eob_info code = do
603 (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
604 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
606 getEndOfBlockInfo :: FCode EndOfBlockInfo
607 getEndOfBlockInfo = do
608 (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
612 There is just one SRT for each top level binding; all the nested
613 bindings use sub-sections of this SRT. The label is passed down to
614 the nested bindings via the monad.
617 getSRTInfo :: SRT -> FCode C_SRT
618 getSRTInfo NoSRT = return NoC_SRT
619 getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
620 return (C_SRT srt_lbl off len)
622 getSRTLabel :: FCode CLabel -- Used only by cgPanic
623 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
626 setSRTLabel :: CLabel -> Code -> Code
627 setSRTLabel srt_lbl code
628 = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
629 withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
633 getTickyCtrLabel :: FCode CLabel
634 getTickyCtrLabel = do
635 (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
638 setTickyCtrLabel :: CLabel -> Code -> Code
639 setTickyCtrLabel ticky code = do
640 (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
641 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)