2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.25 2000/09/04 14:07:29 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(..) )
59 infixr 9 `thenC` -- Right-associative!
63 %************************************************************************
65 \subsection[CgMonad-environment]{Stuff for manipulating environments}
67 %************************************************************************
69 This monadery has some information that it only passes {\em
70 downwards}, as well as some ``state'' which is modified as we go
74 data CgInfoDownwards -- information only passed *downwards* by the monad
76 CompilationInfo -- COMPLETELY STATIC info about this compilation
77 -- (e.g., what flags were passed to the compiler)
79 CgBindings -- [Id -> info] : static environment
81 CLabel -- label of the current SRT
83 CLabel -- current destination for ticky counts
85 EndOfBlockInfo -- Info for stuff to do at end of basic block:
90 Module -- the module name
94 AbstractC -- code accumulated so far
95 CgBindings -- [Id -> info] : *local* bindings environment
96 -- Bindings for top-level things are given in the info-down part
100 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
101 if the expression is a @case@, what to do at the end of each
107 VirtualSpOffset -- Args Sp: trim the stack to this point at a
108 -- return; push arguments starting just
109 -- above this point on a tail call.
111 -- This is therefore the stk ptr as seen
112 -- by a case alternative.
115 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
118 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
119 that it must survive stack pointer adjustments at the end of the
125 VirtualSpOffset -- Continuation is on the stack, at the
126 -- specified location
131 CAddrMode -- Jump to this; if the continuation is for a vectored
132 -- case this might be the label of a return
133 -- vector Guaranteed to be a non-volatile
134 -- addressing mode (I think)
137 | SeqFrame -- like CaseAlts but push a seq frame too.
141 type SemiTaggingStuff
142 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
143 ([(ConTag, JoinDetails)], -- Alternatives
144 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
145 -- Maybe[3] the default is a
146 -- bind-default (Just b); that is,
147 -- it expects a ptr to the thing
148 -- in Node, bound to b
152 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
153 -- and join point label
155 -- The abstract C is executed only from a successful semitagging
156 -- venture, when a case has looked at a variable, found that it's
157 -- evaluated, and wants to load up the contents and go to the join
161 -- The OnStack case of sequelToAmode delivers an Amode which is only
162 -- valid just before the final control transfer, because it assumes
163 -- that Sp is pointing to the top word of the return address. This
164 -- seems unclean but there you go.
166 -- sequelToAmode returns an amode which refers to an info table. The info
167 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
168 -- not to handle real code pointers, just in case we're compiling for
169 -- an unregisterised/untailcallish architecture, where info pointers and
170 -- code pointers aren't the same.
172 sequelToAmode :: Sequel -> FCode CAddrMode
174 sequelToAmode (OnStack virt_sp_offset)
175 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
176 returnFC (CVal sp_rel RetRep)
178 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
179 sequelToAmode (CaseAlts amode _) = returnFC amode
180 sequelToAmode (SeqFrame _ _) = panic "sequelToAmode: SeqFrame"
182 type CgStksAndHeapUsage -- stacks and heap usage information
183 = (StackUsage, HeapUsage)
185 data Slot = Free | NonPointer
194 (Int, -- virtSp: Virtual offset of topmost allocated slot
195 [(Int,Slot)], -- free: List of free slots, in increasing order
196 Int, -- realSp: Virtual offset of real stack pointer
197 Int) -- hwSp: Highest value ever taken by virtSp
200 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
201 HeapOffset) -- realHp: Virtual offset of real heap ptr
204 NB: absolutely every one of the above Ints is really
205 a VirtualOffset of some description (the code generator
206 works entirely in terms of VirtualOffsets).
211 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
213 initUsage :: CgStksAndHeapUsage
214 initUsage = ((0,[],0,0), (0,0))
217 "envInitForAlternatives" initialises the environment for a case alternative,
218 assuming that the alternative is entered after an evaluation.
221 - zapping any volatile bindings, which aren't valid.
223 - zapping the heap usage. It should be restored by a heap check.
225 - setting the virtual AND real stack pointer fields to the given
226 virtual stack offsets. this doesn't represent any {\em code}; it is a
227 prediction of where the real stack pointer will be when we come back
228 from the case analysis.
230 - BUT LEAVING the rest of the stack-usage info because it is all
231 valid. In particular, we leave the tail stack pointers unchanged,
232 becuase the alternative has to de-allocate the original @case@
233 expression's stack. \end{itemize}
235 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
236 marks found in $e_2$.
239 stateIncUsage :: CgState -> CgState -> CgState
241 stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
242 (MkCgState _ _ ((_,_,_,h2),(vH2, _)))
245 ((v,f,r,h1 `max` h2),
246 (vH1 `max` vH2, rH1))
249 %************************************************************************
251 \subsection[CgMonad-basics]{Basic code-generation monad magic}
253 %************************************************************************
256 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
257 type Code = CgInfoDownwards -> CgState -> CgState
260 {-# INLINE thenFC #-}
261 {-# INLINE returnFC #-}
263 The Abstract~C is not in the environment so as to improve strictness.
266 initC :: CompilationInfo -> Code -> AbstractC
269 = case (code (MkCgInfoDown
271 (error "initC: statics")
276 MkCgState abc _ _ -> abc
278 returnFC :: a -> FCode a
280 returnFC val info_down state = (val, state)
285 -> (CgInfoDownwards -> CgState -> a)
286 -> CgInfoDownwards -> CgState -> a
288 -- thenC has both of the following types:
289 -- thenC :: Code -> Code -> Code
290 -- thenC :: Code -> FCode a -> FCode a
292 thenC m k info_down state
293 = k info_down new_state
295 new_state = m info_down state
297 listCs :: [Code] -> Code
299 listCs [] info_down state = state
300 listCs (c:cs) info_down state = stateN
302 state1 = c info_down state
303 stateN = listCs cs info_down state1
305 mapCs :: (a -> Code) -> [a] -> Code
307 mapCs f [] info_down state = state
308 mapCs f (c:cs) info_down state = stateN
310 state1 = (f c) info_down state
311 stateN = mapCs f cs info_down state1
316 -> (a -> CgInfoDownwards -> CgState -> c)
317 -> CgInfoDownwards -> CgState -> c
319 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
320 -- thenFC :: FCode a -> (a -> Code) -> Code
322 thenFC m k info_down state
323 = k m_result info_down new_state
325 (m_result, new_state) = m info_down state
327 listFCs :: [FCode a] -> FCode [a]
329 listFCs [] info_down state = ([], state)
330 listFCs (fc:fcs) info_down state = (thing : things, stateN)
332 (thing, state1) = fc info_down state
333 (things, stateN) = listFCs fcs info_down state1
335 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
337 mapFCs f [] info_down state = ([], state)
338 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
340 (thing, state1) = (f fc) info_down state
341 (things, stateN) = mapFCs f fcs info_down state1
344 And the knot-tying combinator:
346 fixC :: (a -> FCode a) -> FCode a
347 fixC fcode info_down state = result
349 result@(v, _) = fcode v info_down state
353 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
354 fresh environment, except that:
355 - compilation info and statics are passed in unchanged.
356 The current environment is passed on completely unaltered, except that
357 abstract C from the fork is incorporated.
359 @forkAbsC@ takes a code and compiles it in the current environment,
360 returning the abstract C thus constructed. The current environment
361 is passed on completely unchanged. It is pretty similar to @getAbsC@,
362 except that the latter does affect the environment. ToDo: combine?
364 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
365 from the current bindings, but which is otherwise freshly initialised.
366 The Abstract~C returned is attached to the current state, but the
367 bindings and usage information is otherwise unchanged.
370 forkClosureBody :: Code -> Code
373 (MkCgInfoDown cg_info statics srt ticky _)
374 (MkCgState absC_in binds un_usage)
375 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
377 fork_state = code body_info_down initialStateC
378 MkCgState absC_fork _ _ = fork_state
379 body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
381 forkStatics :: FCode a -> FCode a
383 forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
384 (MkCgState absC_in statics un_usage)
385 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
387 (result, state) = fcode rhs_info_down initialStateC
388 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
389 -- above or it becomes too strict!
390 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
392 forkAbsC :: Code -> FCode AbstractC
393 forkAbsC code info_down (MkCgState absC1 bs usage)
396 MkCgState absC2 _ ((_, _, _,h2), _) =
397 code info_down (MkCgState AbsCNop bs usage)
398 ((v, f, r, h1), heap_usage) = usage
400 new_usage = ((v, f, r, h1 `max` h2), heap_usage)
401 new_state = MkCgState absC1 bs new_usage
404 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
405 an fcode for the default case $d$, and compiles each in the current
406 environment. The current environment is passed on unmodified, except
408 - the worst stack high-water mark is incorporated
409 - the virtual Hp is moved on to the worst virtual Hp for the branches
412 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
414 forkAlts branch_fcodes deflt_fcode info_down in_state
415 = ((branch_results , deflt_result), out_state)
417 compile fc = fc info_down in_state
419 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
421 (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
423 out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
424 -- NB foldl. in_state is the *left* argument to stateIncUsage
427 @forkEval@ takes two blocks of code.
429 - The first meddles with the environment to set it up as expected by
430 the alternatives of a @case@ which does an eval (or gc-possible primop).
431 - The second block is the code for the alternatives.
432 (plus info for semi-tagging purposes)
434 @forkEval@ picks up the virtual stack pointer and returns a suitable
435 @EndOfBlockInfo@ for the caller to use, together with whatever value
436 is returned by the second block.
438 It uses @initEnvForAlternatives@ to initialise the environment, and
439 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
443 forkEval :: EndOfBlockInfo -- For the body
444 -> Code -- Code to set environment
445 -> FCode Sequel -- Semi-tagging info to store
446 -> FCode EndOfBlockInfo -- The new end of block info
448 forkEval body_eob_info env_code body_code
449 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
450 returnFC (EndOfBlockInfo v sequel)
452 forkEvalHelp :: EndOfBlockInfo -- For the body
453 -> Code -- Code to set environment
454 -> FCode a -- The code to do after the eval
456 a) -- Result of the FCode
458 forkEvalHelp body_eob_info env_code body_code
459 info_down@(MkCgInfoDown cg_info statics srt ticky _) state
460 = ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
462 info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
464 (MkCgState _ binds ((v,f,_,_), _)) = env_code info_down_for_body state
465 -- These v and f things are now set up as the body code expects them
467 (value_returned, state_at_end_return)
468 = body_code info_down_for_body state_for_body
470 state_for_body = MkCgState AbsCNop
471 (nukeVolatileBinds binds)
475 stateIncUsageEval :: CgState -> CgState -> CgState
476 stateIncUsageEval (MkCgState absC1 bs ((v,f,r,h1),heap_usage))
477 (MkCgState absC2 _ ((_,_,_,h2), _))
478 = MkCgState (absC1 `mkAbsCStmts` absC2)
479 -- The AbsC coming back should consist only of nested declarations,
480 -- notably of the return vector!
482 ((v,f,r,h1 `max` h2), heap_usage)
483 -- We don't max the heap high-watermark because stateIncUsageEval is
484 -- used only in forkEval, which in turn is only used for blocks of code
485 -- which do their own heap-check.
488 %************************************************************************
490 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
492 %************************************************************************
494 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
495 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
498 nopC info_down state = state
500 absC :: AbstractC -> Code
501 absC more_absC info_down state@(MkCgState absC binds usage)
502 = MkCgState (mkAbsCStmts absC more_absC) binds usage
505 These two are just like @absC@, except they examine the compilation
506 info (whether SCC profiling or profiling-ctrs going) and possibly emit
510 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
512 costCentresC macro args _ state@(MkCgState absC binds usage)
513 = if opt_SccProfilingOn
514 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
517 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
519 profCtrC macro args _ state@(MkCgState absC binds usage)
520 = if not opt_DoTickyProfiling
522 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
524 profCtrAbsC :: FAST_STRING -> [CAddrMode] -> AbstractC
526 profCtrAbsC macro args
527 = if not opt_DoTickyProfiling
529 else CCallProfCtrMacro macro args
531 {- Try to avoid adding too many special compilation strategies here.
532 It's better to modify the header files as necessary for particular
533 targets, so that we can get away with as few variants of .hc files
538 @getAbsC@ compiles the code in the current environment, and returns
539 the abstract C thus constructed (leaving the abstract C being carried
540 around in the state untouched). @getAbsC@ does not generate any
541 in-line Abstract~C itself, but the environment it returns is that
542 obtained from the compilation.
545 getAbsC :: Code -> FCode AbstractC
547 getAbsC code info_down (MkCgState absC binds usage)
548 = (absC2, MkCgState absC binds2 usage2)
550 (MkCgState absC2 binds2 usage2)
551 = code info_down (MkCgState AbsCNop binds usage)
556 moduleName :: FCode Module
557 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) state
563 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
564 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics srt ticky _) state
565 = code (MkCgInfoDown c_info statics srt ticky eob_info) state
567 getEndOfBlockInfo :: FCode EndOfBlockInfo
568 getEndOfBlockInfo (MkCgInfoDown c_info statics _ _ eob_info) state
573 getSRTLabel :: FCode CLabel
574 getSRTLabel (MkCgInfoDown _ _ srt _ _) state
577 setSRTLabel :: CLabel -> Code -> Code
578 setSRTLabel srt code (MkCgInfoDown c_info statics _ ticky eob_info) state
579 = code (MkCgInfoDown c_info statics srt ticky eob_info) state
583 getTickyCtrLabel :: FCode CLabel
584 getTickyCtrLabel (MkCgInfoDown _ _ _ ticky _) state
587 setTickyCtrLabel :: CLabel -> Code -> Code
588 setTickyCtrLabel ticky code (MkCgInfoDown c_info statics srt _ eob_info) state
589 = code (MkCgInfoDown c_info statics srt ticky eob_info) state