2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.23 1999/10/13 16:39:16 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,
27 setTickyCtrLabel, getTickyCtrLabel,
29 StackUsage, Slot(..), HeapUsage,
31 profCtrC, profCtrAbsC,
33 costCentresC, moduleName,
35 Sequel(..), -- ToDo: unabstract?
38 -- out of general friendliness, we also export ...
39 CgInfoDownwards(..), CgState(..), -- non-abstract
43 #include "HsVersions.h"
45 import {-# SOURCE #-} CgBindery ( CgIdInfo, CgBindings, nukeVolatileBinds )
46 import {-# SOURCE #-} CgUsages ( getSpRelOffset )
49 import AbsCUtils ( mkAbsCStmts )
50 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
51 import CLabel ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
52 import Module ( Module )
53 import DataCon ( ConTag )
56 import PrimRep ( 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 CLabel -- current destination for ticky counts
86 EndOfBlockInfo -- Info for stuff to do at end of basic block:
91 Module -- the module name
95 AbstractC -- code accumulated so far
96 CgBindings -- [Id -> info] : *local* bindings environment
97 -- Bindings for top-level things are given in the info-down part
101 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
102 if the expression is a @case@, what to do at the end of each
108 VirtualSpOffset -- Args Sp: trim the stack to this point at a
109 -- return; push arguments starting just
110 -- above this point on a tail call.
112 -- This is therefore the stk ptr as seen
113 -- by a case alternative.
116 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
119 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
120 that it must survive stack pointer adjustments at the end of the
126 VirtualSpOffset -- Continuation is on the stack, at the
127 -- specified location
132 CAddrMode -- Jump to this; if the continuation is for a vectored
133 -- case this might be the label of a return
134 -- vector Guaranteed to be a non-volatile
135 -- addressing mode (I think)
138 | SeqFrame -- like CaseAlts but push a seq frame too.
142 type SemiTaggingStuff
143 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
144 ([(ConTag, JoinDetails)], -- Alternatives
145 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
146 -- Maybe[3] the default is a
147 -- bind-default (Just b); that is,
148 -- it expects a ptr to the thing
149 -- in Node, bound to b
153 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
154 -- and join point label
156 -- The abstract C is executed only from a successful semitagging
157 -- venture, when a case has looked at a variable, found that it's
158 -- evaluated, and wants to load up the contents and go to the join
162 -- The OnStack case of sequelToAmode delivers an Amode which is only
163 -- valid just before the final control transfer, because it assumes
164 -- that Sp is pointing to the top word of the return address. This
165 -- seems unclean but there you go.
167 -- sequelToAmode returns an amode which refers to an info table. The info
168 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
169 -- not to handle real code pointers, just in case we're compiling for
170 -- an unregisterised/untailcallish architecture, where info pointers and
171 -- code pointers aren't the same.
173 sequelToAmode :: Sequel -> FCode CAddrMode
175 sequelToAmode (OnStack virt_sp_offset)
176 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
177 returnFC (CVal sp_rel RetRep)
179 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
180 sequelToAmode (CaseAlts amode _) = returnFC amode
181 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
183 type CgStksAndHeapUsage -- stacks and heap usage information
184 = (StackUsage, HeapUsage)
186 data Slot = Free | NonPointer
195 (Int, -- virtSp: Virtual offset of topmost allocated slot
196 [(Int,Slot)], -- free: List of free slots, in increasing order
197 Int, -- realSp: Virtual offset of real stack pointer
198 Int) -- hwSp: Highest value ever taken by virtSp
201 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
202 HeapOffset) -- realHp: Virtual offset of real heap ptr
205 NB: absolutely every one of the above Ints is really
206 a VirtualOffset of some description (the code generator
207 works entirely in terms of VirtualOffsets).
212 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
214 initUsage :: CgStksAndHeapUsage
215 initUsage = ((0,[],0,0), (0,0))
218 "envInitForAlternatives" initialises the environment for a case alternative,
219 assuming that the alternative is entered after an evaluation.
222 - zapping any volatile bindings, which aren't valid.
224 - zapping the heap usage. It should be restored by a heap check.
226 - setting the virtual AND real stack pointer fields to the given
227 virtual stack offsets. this doesn't represent any {\em code}; it is a
228 prediction of where the real stack pointer will be when we come back
229 from the case analysis.
231 - BUT LEAVING the rest of the stack-usage info because it is all
232 valid. In particular, we leave the tail stack pointers unchanged,
233 becuase the alternative has to de-allocate the original @case@
234 expression's stack. \end{itemize}
236 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
237 marks found in $e_2$.
240 stateIncUsage :: CgState -> CgState -> CgState
242 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
243 (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
246 ((v,f,r,h1 `max` h2),
247 (vH1 `max` vH2, rH1))
250 %************************************************************************
252 \subsection[CgMonad-basics]{Basic code-generation monad magic}
254 %************************************************************************
257 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
258 type Code = CgInfoDownwards -> CgState -> CgState
261 {-# INLINE thenFC #-}
262 {-# INLINE returnFC #-}
264 The Abstract~C is not in the environment so as to improve strictness.
267 initC :: CompilationInfo -> Code -> AbstractC
270 = case (code (MkCgInfoDown
272 (error "initC: statics")
277 MkCgState abc _ _ -> abc
279 returnFC :: a -> FCode a
281 returnFC val info_down state = (val, state)
286 -> (CgInfoDownwards -> CgState -> a)
287 -> CgInfoDownwards -> CgState -> a
289 -- thenC has both of the following types:
290 -- thenC :: Code -> Code -> Code
291 -- thenC :: Code -> FCode a -> FCode a
293 thenC m k info_down state
294 = k info_down new_state
296 new_state = m info_down state
298 listCs :: [Code] -> Code
300 listCs [] info_down state = state
301 listCs (c:cs) info_down state = stateN
303 state1 = c info_down state
304 stateN = listCs cs info_down state1
306 mapCs :: (a -> Code) -> [a] -> Code
308 mapCs f [] info_down state = state
309 mapCs f (c:cs) info_down state = stateN
311 state1 = (f c) info_down state
312 stateN = mapCs f cs info_down state1
317 -> (a -> CgInfoDownwards -> CgState -> c)
318 -> CgInfoDownwards -> CgState -> c
320 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
321 -- thenFC :: FCode a -> (a -> Code) -> Code
323 thenFC m k info_down state
324 = k m_result info_down new_state
326 (m_result, new_state) = m info_down state
328 listFCs :: [FCode a] -> FCode [a]
330 listFCs [] info_down state = ([], state)
331 listFCs (fc:fcs) info_down state = (thing : things, stateN)
333 (thing, state1) = fc info_down state
334 (things, stateN) = listFCs fcs info_down state1
336 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
338 mapFCs f [] info_down state = ([], state)
339 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
341 (thing, state1) = (f fc) info_down state
342 (things, stateN) = mapFCs f fcs info_down state1
345 And the knot-tying combinator:
347 fixC :: (a -> FCode a) -> FCode a
348 fixC fcode info_down state = result
350 result@(v, _) = fcode v info_down state
354 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
355 fresh environment, except that:
356 - compilation info and statics are passed in unchanged.
357 The current environment is passed on completely unaltered, except that
358 abstract C from the fork is incorporated.
360 @forkAbsC@ takes a code and compiles it in the current environment,
361 returning the abstract C thus constructed. The current environment
362 is passed on completely unchanged. It is pretty similar to @getAbsC@,
363 except that the latter does affect the environment. ToDo: combine?
365 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
366 from the current bindings, but which is otherwise freshly initialised.
367 The Abstract~C returned is attached to the current state, but the
368 bindings and usage information is otherwise unchanged.
371 forkClosureBody :: Code -> Code
374 (MkCgInfoDown cg_info statics srt ticky _)
375 (MkCgState absC_in binds un_usage)
376 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
378 fork_state = code body_info_down initialStateC
379 MkCgState absC_fork _ _ = fork_state
380 body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
382 forkStatics :: FCode a -> FCode a
384 forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
385 (MkCgState absC_in statics un_usage)
386 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
388 (result, state) = fcode rhs_info_down initialStateC
389 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
390 -- above or it becomes too strict!
391 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
393 forkAbsC :: Code -> FCode AbstractC
394 forkAbsC code info_down (MkCgState absC1 bs usage)
397 MkCgState absC2 _ ((_, _, _,h2), _) =
398 code info_down (MkCgState AbsCNop bs usage)
399 ((v, f, r, h1), heap_usage) = usage
401 new_usage = ((v, f, r, h1 `max` h2), heap_usage)
402 new_state = MkCgState absC1 bs new_usage
405 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
406 an fcode for the default case $d$, and compiles each in the current
407 environment. The current environment is passed on unmodified, except
409 - the worst stack high-water mark is incorporated
410 - the virtual Hp is moved on to the worst virtual Hp for the branches
413 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
415 forkAlts branch_fcodes deflt_fcode info_down in_state
416 = ((branch_results , deflt_result), out_state)
418 compile fc = fc info_down in_state
420 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
422 (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
424 out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
425 -- NB foldl. in_state is the *left* argument to stateIncUsage
428 @forkEval@ takes two blocks of code.
430 - The first meddles with the environment to set it up as expected by
431 the alternatives of a @case@ which does an eval (or gc-possible primop).
432 - The second block is the code for the alternatives.
433 (plus info for semi-tagging purposes)
435 @forkEval@ picks up the virtual stack pointer and returns a suitable
436 @EndOfBlockInfo@ for the caller to use, together with whatever value
437 is returned by the second block.
439 It uses @initEnvForAlternatives@ to initialise the environment, and
440 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
444 forkEval :: EndOfBlockInfo -- For the body
445 -> Code -- Code to set environment
446 -> FCode Sequel -- Semi-tagging info to store
447 -> FCode EndOfBlockInfo -- The new end of block info
449 forkEval body_eob_info env_code body_code
450 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
451 returnFC (EndOfBlockInfo v sequel)
453 forkEvalHelp :: EndOfBlockInfo -- For the body
454 -> Code -- Code to set environment
455 -> FCode a -- The code to do after the eval
457 a) -- Result of the FCode
459 forkEvalHelp body_eob_info env_code body_code
460 info_down@(MkCgInfoDown cg_info statics srt ticky _) state
461 = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
463 info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
465 (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
466 -- These v and f things are now set up as the body code expects them
468 (value_returned, state_at_end_return)
469 = body_code info_down_for_body state_for_body
471 state_for_body = MkCgState AbsCNop
472 (nukeVolatileBinds binds)
476 stateIncUsageEval :: CgState -> CgState -> CgState
477 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
478 (MkCgState absC2 _ ((_,_,_,h2), _))
479 = MkCgState (absC1 `AbsCStmts` absC2)
480 -- The AbsC coming back should consist only of nested declarations,
481 -- notably of the return vector!
483 ((v,f,r,h1 `max` h2), heap_usage)
484 -- We don't max the heap high-watermark because stateIncUsageEval is
485 -- used only in forkEval, which in turn is only used for blocks of code
486 -- which do their own heap-check.
489 %************************************************************************
491 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
493 %************************************************************************
495 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
496 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
499 nopC info_down state = state
501 absC :: AbstractC -> Code
502 absC more_absC info_down state@(MkCgState absC binds usage)
503 = MkCgState (mkAbsCStmts absC more_absC) binds usage
506 These two are just like @absC@, except they examine the compilation
507 info (whether SCC profiling or profiling-ctrs going) and possibly emit
511 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
513 costCentresC macro args _ state@(MkCgState absC binds usage)
514 = if opt_SccProfilingOn
515 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
518 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
520 profCtrC macro args _ state@(MkCgState absC binds usage)
521 = if not opt_DoTickyProfiling
523 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
525 profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
527 profCtrAbsC macro args
528 = if not opt_DoTickyProfiling
530 else CCallProfCtrMacro macro args
532 {- Try to avoid adding too many special compilation strategies here.
533 It's better to modify the header files as necessary for particular
534 targets, so that we can get away with as few variants of .hc files
539 @getAbsC@ compiles the code in the current environment, and returns
540 the abstract C thus constructed (leaving the abstract C being carried
541 around in the state untouched). @getAbsC@ does not generate any
542 in-line Abstract~C itself, but the environment it returns is that
543 obtained from the compilation.
546 getAbsC :: Code -> FCode AbstractC
548 getAbsC code info_down (MkCgState absC binds usage)
549 = (absC2, MkCgState absC binds2 usage2)
551 (MkCgState absC2 binds2 usage2)
552 = code info_down (MkCgState AbsCNop binds usage)
557 moduleName :: FCode Module
558 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
564 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
565 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt ticky _) state
566 = code (MkCgInfoDown c_info statics srt ticky eob_info) state
568 getEndOfBlockInfo :: FCode EndOfBlockInfo
569 getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
574 getSRTLabel :: FCode CLabel
575 getSRTLabel (MkCgInfoDown _ _ srt _ _) state
578 setSRTLabel :: CLabel -> Code -> Code
579 setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
580 = code (MkCgInfoDown c_info statics srt ticky eob_info) state
584 getTickyCtrLabel :: FCode CLabel
585 getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
588 setTickyCtrLabel :: CLabel -> Code -> Code
589 setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
590 = code (MkCgInfoDown c_info statics srt ticky eob_info) state