2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.32 2001/11/23 11:46:31 simonmar 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(..) )
67 infixr 9 `thenC` -- Right-associative!
71 %************************************************************************
73 \subsection[CgMonad-environment]{Stuff for manipulating environments}
75 %************************************************************************
77 This monadery has some information that it only passes {\em
78 downwards}, as well as some ``state'' which is modified as we go
82 data CgInfoDownwards -- information only passed *downwards* by the monad
84 CompilationInfo -- COMPLETELY STATIC info about this compilation
85 -- (e.g., what flags were passed to the compiler)
87 CgBindings -- [Id -> info] : static environment
89 CLabel -- label of the current SRT
91 CLabel -- current destination for ticky counts
93 EndOfBlockInfo -- Info for stuff to do at end of basic block:
98 Module -- the module name
102 AbstractC -- code accumulated so far
103 CgBindings -- [Id -> info] : *local* bindings environment
104 -- Bindings for top-level things are given in the info-down part
108 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
109 if the expression is a @case@, what to do at the end of each
115 VirtualSpOffset -- Args Sp: trim the stack to this point at a
116 -- return; push arguments starting just
117 -- above this point on a tail call.
119 -- This is therefore the stk ptr as seen
120 -- by a case alternative.
123 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
126 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
127 that it must survive stack pointer adjustments at the end of the
133 VirtualSpOffset -- Continuation is on the stack, at the
134 -- specified location
139 CAddrMode -- Jump to this; if the continuation is for a vectored
140 -- case this might be the label of a return
141 -- vector Guaranteed to be a non-volatile
142 -- addressing mode (I think)
145 | SeqFrame -- like CaseAlts but push a seq frame too.
149 type SemiTaggingStuff
150 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
151 ([(ConTag, JoinDetails)], -- Alternatives
152 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
153 -- Maybe[3] the default is a
154 -- bind-default (Just b); that is,
155 -- it expects a ptr to the thing
156 -- in Node, bound to b
160 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
161 -- and join point label
163 -- The abstract C is executed only from a successful semitagging
164 -- venture, when a case has looked at a variable, found that it's
165 -- evaluated, and wants to load up the contents and go to the join
169 -- The OnStack case of sequelToAmode delivers an Amode which is only
170 -- valid just before the final control transfer, because it assumes
171 -- that Sp is pointing to the top word of the return address. This
172 -- seems unclean but there you go.
174 -- sequelToAmode returns an amode which refers to an info table. The info
175 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
176 -- not to handle real code pointers, just in case we're compiling for
177 -- an unregisterised/untailcallish architecture, where info pointers and
178 -- code pointers aren't the same.
180 sequelToAmode :: Sequel -> FCode CAddrMode
182 sequelToAmode (OnStack virt_sp_offset)
183 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
184 returnFC (CVal sp_rel RetRep)
186 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
187 sequelToAmode (CaseAlts amode _) = returnFC amode
188 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
190 type CgStksAndHeapUsage -- stacks and heap usage information
191 = (StackUsage, HeapUsage)
193 data Slot = Free | NonPointer
202 (Int, -- virtSp: Virtual offset of topmost allocated slot
203 [(Int,Slot)], -- free: List of free slots, in increasing order
204 Int, -- realSp: Virtual offset of real stack pointer
205 Int) -- hwSp: Highest value ever taken by virtSp
208 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
209 HeapOffset) -- realHp: Virtual offset of real heap ptr
212 NB: absolutely every one of the above Ints is really
213 a VirtualOffset of some description (the code generator
214 works entirely in terms of VirtualOffsets).
219 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
221 initUsage :: CgStksAndHeapUsage
222 initUsage = ((0,[],0,0), (0,0))
225 "envInitForAlternatives" initialises the environment for a case alternative,
226 assuming that the alternative is entered after an evaluation.
229 - zapping any volatile bindings, which aren't valid.
231 - zapping the heap usage. It should be restored by a heap check.
233 - setting the virtual AND real stack pointer fields to the given
234 virtual stack offsets. this doesn't represent any {\em code}; it is a
235 prediction of where the real stack pointer will be when we come back
236 from the case analysis.
238 - BUT LEAVING the rest of the stack-usage info because it is all
239 valid. In particular, we leave the tail stack pointers unchanged,
240 becuase the alternative has to de-allocate the original @case@
241 expression's stack. \end{itemize}
243 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
244 marks found in $e_2$.
247 stateIncUsage :: CgState -> CgState -> CgState
249 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
250 (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
253 ((v,f,r,h1 `max` h2),
254 (vH1 `max` vH2, rH1))
257 %************************************************************************
259 \subsection[CgMonad-basics]{Basic code-generation monad magic}
261 %************************************************************************
264 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
267 instance Monad FCode where
272 {-# INLINE thenFC #-}
273 {-# INLINE returnFC #-}
275 The Abstract~C is not in the environment so as to improve strictness.
278 initC :: CompilationInfo -> Code -> AbstractC
280 initC cg_info (FCode code)
281 = case (code (MkCgInfoDown
283 emptyVarEnv -- (error "initC: statics")
288 ((),MkCgState abc _ _) -> abc
290 returnFC :: a -> FCode a
291 returnFC val = FCode (\info_down state -> (val, state))
295 thenC :: Code -> FCode a -> FCode a
296 thenC (FCode m) (FCode k) =
297 FCode (\info_down state -> let (_,new_state) = m info_down state in
298 k info_down new_state)
300 listCs :: [Code] -> Code
301 listCs [] = return ()
306 mapCs :: (a -> Code) -> [a] -> Code
311 thenFC :: FCode a -> (a -> FCode c) -> FCode c
312 thenFC (FCode m) k = FCode (
315 (m_result, new_state) = m info_down state
316 (FCode kcode) = k m_result
318 kcode info_down new_state
321 listFCs :: [FCode a] -> FCode [a]
324 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
328 And the knot-tying combinator:
330 fixC :: (a -> FCode a) -> FCode a
335 result@(v,_) = fc info_down state
342 Operators for getting and setting the state and "info_down".
343 To maximise encapsulation, code should try to only get and set the
344 state it actually uses.
347 getState :: FCode CgState
348 getState = FCode $ \info_down state -> (state,state)
350 setState :: CgState -> FCode ()
351 setState state = FCode $ \info_down _ -> ((),state)
353 getUsage :: FCode CgStksAndHeapUsage
355 MkCgState absC binds usage <- getState
358 setUsage :: CgStksAndHeapUsage -> FCode ()
359 setUsage newusage = do
360 MkCgState absC binds usage <- getState
361 setState $ MkCgState absC binds newusage
363 getBinds :: FCode CgBindings
365 MkCgState absC binds usage <- getState
368 setBinds :: CgBindings -> FCode ()
369 setBinds newbinds = do
370 MkCgState absC binds usage <- getState
371 setState $ MkCgState absC newbinds usage
373 getStaticBinds :: FCode CgBindings
375 (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
378 withState :: FCode a -> CgState -> FCode (a,CgState)
379 withState (FCode fcode) newstate = FCode $ \info_down state ->
380 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
382 getInfoDown :: FCode CgInfoDownwards
383 getInfoDown = FCode $ \info_down state -> (info_down,state)
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
393 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
394 fresh environment, except that:
395 - compilation info and statics are passed in unchanged.
396 The current environment is passed on completely unaltered, except that
397 abstract C from the fork is incorporated.
399 @forkAbsC@ takes a code and compiles it in the current environment,
400 returning the abstract C thus constructed. The current environment
401 is passed on completely unchanged. It is pretty similar to @getAbsC@,
402 except that the latter does affect the environment. ToDo: combine?
404 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
405 from the current bindings, but which is otherwise freshly initialised.
406 The Abstract~C returned is attached to the current state, but the
407 bindings and usage information is otherwise unchanged.
410 forkClosureBody :: Code -> Code
412 forkClosureBody (FCode code) = do
413 (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
414 (MkCgState absC_in binds un_usage) <- getState
415 let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
416 let ((),fork_state) = code body_info_down initialStateC
417 let MkCgState absC_fork _ _ = fork_state
418 setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
420 forkStatics :: FCode a -> FCode a
422 forkStatics (FCode fcode) = FCode (
423 \(MkCgInfoDown cg_info _ srt ticky _)
424 (MkCgState absC_in statics un_usage)
427 (result, state) = fcode rhs_info_down initialStateC
428 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
429 -- above or it becomes too strict!
430 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
432 (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
435 forkAbsC :: Code -> FCode AbstractC
436 forkAbsC (FCode code) =
438 info_down <- getInfoDown
439 (MkCgState absC1 bs usage) <- getState
440 let ((),MkCgState absC2 _ ((_, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
441 let ((v, f, r, h1), heap_usage) = usage
442 let new_usage = ((v, f, r, h1 `max` h2), heap_usage)
443 setState $ MkCgState absC1 bs new_usage
447 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
448 an fcode for the default case $d$, and compiles each in the current
449 environment. The current environment is passed on unmodified, except
451 - the worst stack high-water mark is incorporated
452 - the virtual Hp is moved on to the worst virtual Hp for the branches
455 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
457 forkAlts branch_fcodes (FCode deflt_fcode) =
459 info_down <- getInfoDown
461 let compile (FCode fc) = fc info_down in_state
462 let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
463 let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
464 setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
465 -- NB foldl. in_state is the *left* argument to stateIncUsage
466 return (branch_results, deflt_result)
470 @forkEval@ takes two blocks of code.
472 - The first meddles with the environment to set it up as expected by
473 the alternatives of a @case@ which does an eval (or gc-possible primop).
474 - The second block is the code for the alternatives.
475 (plus info for semi-tagging purposes)
477 @forkEval@ picks up the virtual stack pointer and returns a suitable
478 @EndOfBlockInfo@ for the caller to use, together with whatever value
479 is returned by the second block.
481 It uses @initEnvForAlternatives@ to initialise the environment, and
482 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
486 forkEval :: EndOfBlockInfo -- For the body
487 -> Code -- Code to set environment
488 -> FCode Sequel -- Semi-tagging info to store
489 -> FCode EndOfBlockInfo -- The new end of block info
491 forkEval body_eob_info env_code body_code
492 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
493 returnFC (EndOfBlockInfo v sequel)
495 forkEvalHelp :: EndOfBlockInfo -- For the body
496 -> Code -- Code to set environment
497 -> FCode a -- The code to do after the eval
499 a) -- Result of the FCode
501 forkEvalHelp body_eob_info env_code body_code =
503 info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
505 let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
506 let (_,MkCgState _ binds ((v,f,_,_),_)) =
507 doFCode env_code info_down_for_body state
508 let state_for_body = MkCgState AbsCNop
509 (nukeVolatileBinds binds)
511 let (value_returned, state_at_end_return) =
512 doFCode body_code info_down_for_body state_for_body
513 setState $ state `stateIncUsageEval` state_at_end_return
514 return (v,value_returned)
516 stateIncUsageEval :: CgState -> CgState -> CgState
517 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
518 (MkCgState absC2 _ ((_,_,_,h2), _))
519 = MkCgState (absC1 `mkAbsCStmts` absC2)
520 -- The AbsC coming back should consist only of nested declarations,
521 -- notably of the return vector!
523 ((v,f,r,h1 `max` h2), heap_usage)
524 -- We don't max the heap high-watermark because stateIncUsageEval is
525 -- used only in forkEval, which in turn is only used for blocks of code
526 -- which do their own heap-check.
529 %************************************************************************
531 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
533 %************************************************************************
535 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
536 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
541 absC :: AbstractC -> Code
543 state@(MkCgState absC binds usage) <- getState
544 setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
547 These two are just like @absC@, except they examine the compilation
548 info (whether SCC profiling or profiling-ctrs going) and possibly emit
552 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
553 costCentresC macro args
554 | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
557 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
559 | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
562 profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
563 profCtrAbsC macro args
564 | opt_DoTickyProfiling = CCallProfCtrMacro macro args
565 | otherwise = AbsCNop
568 ldvEnter = costCentresC SLIT("LDV_ENTER") [CReg node]
570 {- Try to avoid adding too many special compilation strategies here.
571 It's better to modify the header files as necessary for particular
572 targets, so that we can get away with as few variants of .hc files
577 @getAbsC@ compiles the code in the current environment, and returns
578 the abstract C thus constructed (leaving the abstract C being carried
579 around in the state untouched). @getAbsC@ does not generate any
580 in-line Abstract~C itself, but the environment it returns is that
581 obtained from the compilation.
584 getAbsC :: Code -> FCode AbstractC
586 MkCgState absC binds usage <- getState
587 ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
588 setState $ MkCgState absC binds2 usage2
593 moduleName :: FCode Module
595 (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
600 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
601 setEndOfBlockInfo eob_info code = do
602 (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
603 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
605 getEndOfBlockInfo :: FCode EndOfBlockInfo
606 getEndOfBlockInfo = do
607 (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
612 getSRTInfo :: SRT -> FCode C_SRT
613 getSRTInfo NoSRT = return NoC_SRT
614 getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
615 return (C_SRT srt_lbl off len)
617 getSRTLabel :: FCode CLabel -- Used only by cgPanic
618 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
621 setSRTLabel :: CLabel -> Code -> Code
622 setSRTLabel srt_lbl code
623 = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
624 withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
628 getTickyCtrLabel :: FCode CLabel
629 getTickyCtrLabel = do
630 (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
633 setTickyCtrLabel :: CLabel -> Code -> Code
634 setTickyCtrLabel ticky code = do
635 (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
636 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)