2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.38 2003/05/14 09:13:56 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 )
57 import StgSyn ( SRT(..) )
58 import AbsCUtils ( mkAbsCStmts )
59 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
60 import Module ( Module )
61 import DataCon ( ConTag )
65 import PrimRep ( PrimRep(..) )
66 import SMRep ( StgHalfWord, hALF_WORD )
70 infixr 9 `thenC` -- Right-associative!
74 %************************************************************************
76 \subsection[CgMonad-environment]{Stuff for manipulating environments}
78 %************************************************************************
80 This monadery has some information that it only passes {\em
81 downwards}, as well as some ``state'' which is modified as we go
85 data CgInfoDownwards -- information only passed *downwards* by the monad
87 CompilationInfo -- COMPLETELY STATIC info about this compilation
88 -- (e.g., what flags were passed to the compiler)
90 CgBindings -- [Id -> info] : static environment
92 CLabel -- label of the current SRT
94 CLabel -- current destination for ticky counts
96 EndOfBlockInfo -- Info for stuff to do at end of basic block:
101 Module -- the module name
105 AbstractC -- code accumulated so far
106 CgBindings -- [Id -> info] : *local* bindings environment
107 -- Bindings for top-level things are given in the info-down part
111 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
112 if the expression is a @case@, what to do at the end of each
118 VirtualSpOffset -- Args Sp: trim the stack to this point at a
119 -- return; push arguments starting just
120 -- above this point on a tail call.
122 -- This is therefore the stk ptr as seen
123 -- by a case alternative.
126 initEobInfo = EndOfBlockInfo 0 (OnStack 0)
129 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
130 that it must survive stack pointer adjustments at the end of the
136 VirtualSpOffset -- Continuation is on the stack, at the
137 -- specified location
142 CAddrMode -- Jump to this; if the continuation is for a vectored
143 -- case this might be the label of a return
144 -- vector Guaranteed to be a non-volatile
145 -- addressing mode (I think)
148 Bool -- True <=> polymorphic, push a SEQ frame too
151 type SemiTaggingStuff
152 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
153 ([(ConTag, JoinDetails)], -- Alternatives
154 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
155 -- Maybe[3] the default is a
156 -- bind-default (Just b); that is,
157 -- it expects a ptr to the thing
158 -- in Node, bound to b
162 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
163 -- and join point label
165 -- The abstract C is executed only from a successful semitagging
166 -- venture, when a case has looked at a variable, found that it's
167 -- evaluated, and wants to load up the contents and go to the join
171 -- The OnStack case of sequelToAmode delivers an Amode which is only
172 -- valid just before the final control transfer, because it assumes
173 -- that Sp is pointing to the top word of the return address. This
174 -- seems unclean but there you go.
176 -- sequelToAmode returns an amode which refers to an info table. The info
177 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind. We're careful
178 -- not to handle real code pointers, just in case we're compiling for
179 -- an unregisterised/untailcallish architecture, where info pointers and
180 -- code pointers aren't the same.
182 sequelToAmode :: Sequel -> FCode CAddrMode
184 sequelToAmode (OnStack virt_sp_offset)
185 = getSpRelOffset virt_sp_offset `thenFC` \ sp_rel ->
186 returnFC (CVal sp_rel RetRep)
188 sequelToAmode UpdateCode = returnFC (CLbl mkUpdInfoLabel RetRep)
190 sequelToAmode (CaseAlts amode _ False) = returnFC amode
191 sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep)
193 type CgStksAndHeapUsage -- stacks and heap usage information
194 = (StackUsage, HeapUsage)
196 data Slot = Free | NonPointer
205 (Int, -- virtSp: Virtual offset of topmost allocated slot
206 Int, -- frameSp: End of the current stack frame
207 [(Int,Slot)], -- free: List of free slots, in increasing order
208 Int, -- realSp: Virtual offset of real stack pointer
209 Int) -- hwSp: Highest value ever taken by virtSp
211 -- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between
212 -- Free and NonPointer in the free list is needed any more. It used
213 -- to be needed because we constructed bitmaps from the free list, but
214 -- now we construct bitmaps by finding all the live pointer bindings
215 -- instead. Non-pointer stack slots (i.e. saved cost centres) can
216 -- just be removed from the free list instead of being recorded as a
220 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
221 HeapOffset) -- realHp: Virtual offset of real heap ptr
224 NB: absolutely every one of the above Ints is really
225 a VirtualOffset of some description (the code generator
226 works entirely in terms of VirtualOffsets).
231 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
233 initUsage :: CgStksAndHeapUsage
234 initUsage = ((0,0,[],0,0), (0,0))
237 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
238 marks found in $e_2$.
241 stateIncUsage :: CgState -> CgState -> CgState
243 stateIncUsage (MkCgState abs_c bs ((v,t,f,r,h1),(vH1,rH1)))
244 (MkCgState _ _ ((_,_,_,_,h2),(vH2, _)))
247 ((v,t,f,r,h1 `max` h2),
248 (vH1 `max` vH2, rH1))
251 %************************************************************************
253 \subsection[CgMonad-basics]{Basic code-generation monad magic}
255 %************************************************************************
258 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
261 instance Monad FCode where
266 {-# INLINE thenFC #-}
267 {-# INLINE returnFC #-}
269 The Abstract~C is not in the environment so as to improve strictness.
272 initC :: CompilationInfo -> Code -> AbstractC
274 initC cg_info (FCode code)
275 = case (code (MkCgInfoDown
277 emptyVarEnv -- (error "initC: statics")
282 ((),MkCgState abc _ _) -> abc
284 returnFC :: a -> FCode a
285 returnFC val = FCode (\info_down state -> (val, state))
289 thenC :: Code -> FCode a -> FCode a
290 thenC (FCode m) (FCode k) =
291 FCode (\info_down state -> let (_,new_state) = m info_down state in
292 k info_down new_state)
294 listCs :: [Code] -> Code
295 listCs [] = return ()
300 mapCs :: (a -> Code) -> [a] -> Code
305 thenFC :: FCode a -> (a -> FCode c) -> FCode c
306 thenFC (FCode m) k = FCode (
309 (m_result, new_state) = m info_down state
310 (FCode kcode) = k m_result
312 kcode info_down new_state
315 listFCs :: [FCode a] -> FCode [a]
318 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
322 And the knot-tying combinator:
324 fixC :: (a -> FCode a) -> FCode a
329 result@(v,_) = fc info_down state
336 Operators for getting and setting the state and "info_down".
337 To maximise encapsulation, code should try to only get and set the
338 state it actually uses.
341 getState :: FCode CgState
342 getState = FCode $ \info_down state -> (state,state)
344 setState :: CgState -> FCode ()
345 setState state = FCode $ \info_down _ -> ((),state)
347 getUsage :: FCode CgStksAndHeapUsage
349 MkCgState absC binds usage <- getState
352 setUsage :: CgStksAndHeapUsage -> FCode ()
353 setUsage newusage = do
354 MkCgState absC binds usage <- getState
355 setState $ MkCgState absC binds newusage
357 getBinds :: FCode CgBindings
359 MkCgState absC binds usage <- getState
362 setBinds :: CgBindings -> FCode ()
363 setBinds newbinds = do
364 MkCgState absC binds usage <- getState
365 setState $ MkCgState absC newbinds usage
367 getStaticBinds :: FCode CgBindings
369 (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
372 withState :: FCode a -> CgState -> FCode (a,CgState)
373 withState (FCode fcode) newstate = FCode $ \info_down state ->
374 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
376 getInfoDown :: FCode CgInfoDownwards
377 getInfoDown = FCode $ \info_down state -> (info_down,state)
379 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
380 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
382 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
383 doFCode (FCode fcode) info_down state = fcode info_down state
387 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
388 fresh environment, except that:
389 - compilation info and statics are passed in unchanged.
390 The current environment is passed on completely unaltered, except that
391 abstract C from the fork is incorporated.
393 @forkAbsC@ takes a code and compiles it in the current environment,
394 returning the abstract C thus constructed. The current environment
395 is passed on completely unchanged. It is pretty similar to @getAbsC@,
396 except that the latter does affect the environment. ToDo: combine?
398 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
399 from the current bindings, but which is otherwise freshly initialised.
400 The Abstract~C returned is attached to the current state, but the
401 bindings and usage information is otherwise unchanged.
404 forkClosureBody :: Code -> Code
406 forkClosureBody (FCode code) = do
407 (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
408 (MkCgState absC_in binds un_usage) <- getState
409 let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
410 let ((),fork_state) = code body_info_down initialStateC
411 let MkCgState absC_fork _ _ = fork_state
412 setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
414 forkStatics :: FCode a -> FCode a
416 forkStatics (FCode fcode) = FCode (
417 \(MkCgInfoDown cg_info _ srt ticky _)
418 (MkCgState absC_in statics un_usage)
421 (result, state) = fcode rhs_info_down initialStateC
422 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
423 -- above or it becomes too strict!
424 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
426 (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
429 forkAbsC :: Code -> FCode AbstractC
430 forkAbsC (FCode code) =
432 info_down <- getInfoDown
433 (MkCgState absC1 bs usage) <- getState
434 let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
435 let ((v, t, f, r, h1), heap_usage) = usage
436 let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage)
437 setState $ MkCgState absC1 bs new_usage
441 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
442 an fcode for the default case $d$, and compiles each in the current
443 environment. The current environment is passed on unmodified, except
445 - the worst stack high-water mark is incorporated
446 - the virtual Hp is moved on to the worst virtual Hp for the branches
449 forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
451 forkAlts branch_fcodes (FCode deflt_fcode) =
453 info_down <- getInfoDown
455 let compile (FCode fc) = fc info_down in_state
456 let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
457 let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
458 setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
459 -- NB foldl. in_state is the *left* argument to stateIncUsage
460 return (branch_results, deflt_result)
464 @forkEval@ takes two blocks of code.
466 - The first meddles with the environment to set it up as expected by
467 the alternatives of a @case@ which does an eval (or gc-possible primop).
468 - The second block is the code for the alternatives.
469 (plus info for semi-tagging purposes)
471 @forkEval@ picks up the virtual stack pointer and returns a suitable
472 @EndOfBlockInfo@ for the caller to use, together with whatever value
473 is returned by the second block.
475 It uses @initEnvForAlternatives@ to initialise the environment, and
476 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
480 forkEval :: EndOfBlockInfo -- For the body
481 -> Code -- Code to set environment
482 -> FCode Sequel -- Semi-tagging info to store
483 -> FCode EndOfBlockInfo -- The new end of block info
485 forkEval body_eob_info env_code body_code
486 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
487 returnFC (EndOfBlockInfo v sequel)
489 forkEvalHelp :: EndOfBlockInfo -- For the body
490 -> Code -- Code to set environment
491 -> FCode a -- The code to do after the eval
493 a) -- Result of the FCode
495 forkEvalHelp body_eob_info env_code body_code =
497 info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
499 let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
500 let (_,MkCgState _ binds ((v,t,f,_,_),_)) =
501 doFCode env_code info_down_for_body state
502 let state_for_body = MkCgState AbsCNop
503 (nukeVolatileBinds binds)
505 let (value_returned, state_at_end_return) =
506 doFCode body_code info_down_for_body state_for_body
507 setState $ state `stateIncUsageEval` state_at_end_return
508 return (v,value_returned)
510 stateIncUsageEval :: CgState -> CgState -> CgState
511 stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage))
512 (MkCgState absC2 _ ((_,_,_,_,h2), _))
513 = MkCgState (absC1 `mkAbsCStmts` absC2)
514 -- The AbsC coming back should consist only of nested declarations,
515 -- notably of the return vector!
517 ((v,t,f,r,h1 `max` h2), heap_usage)
518 -- We don't max the heap high-watermark because stateIncUsageEval is
519 -- used only in forkEval, which in turn is only used for blocks of code
520 -- which do their own heap-check.
523 %************************************************************************
525 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
527 %************************************************************************
529 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
530 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
535 absC :: AbstractC -> Code
537 state@(MkCgState absC binds usage) <- getState
538 setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
541 These two are just like @absC@, except they examine the compilation
542 info (whether SCC profiling or profiling-ctrs going) and possibly emit
546 costCentresC :: FastString -> [CAddrMode] -> Code
547 costCentresC macro args
548 | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
551 profCtrC :: FastString -> [CAddrMode] -> Code
553 | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
556 profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
557 profCtrAbsC macro args
558 | opt_DoTickyProfiling = CCallProfCtrMacro macro args
559 | otherwise = AbsCNop
562 ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node]
564 {- Try to avoid adding too many special compilation strategies here.
565 It's better to modify the header files as necessary for particular
566 targets, so that we can get away with as few variants of .hc files
571 @getAbsC@ compiles the code in the current environment, and returns
572 the abstract C thus constructed (leaving the abstract C being carried
573 around in the state untouched). @getAbsC@ does not generate any
574 in-line Abstract~C itself, but the environment it returns is that
575 obtained from the compilation.
578 getAbsC :: Code -> FCode AbstractC
580 MkCgState absC binds usage <- getState
581 ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
582 setState $ MkCgState absC binds2 usage2
587 moduleName :: FCode Module
589 (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
594 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
595 setEndOfBlockInfo eob_info code = do
596 (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
597 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
599 getEndOfBlockInfo :: FCode EndOfBlockInfo
600 getEndOfBlockInfo = do
601 (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
605 There is just one SRT for each top level binding; all the nested
606 bindings use sub-sections of this SRT. The label is passed down to
607 the nested bindings via the monad.
610 getSRTInfo :: Name -> SRT -> FCode C_SRT
611 getSRTInfo id NoSRT = return NoC_SRT
612 getSRTInfo id (SRT off len bmp)
613 | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do
614 srt_lbl <- getSRTLabel
615 let srt_desc_lbl = mkSRTDescLabel id
616 absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
617 return (C_SRT srt_desc_lbl 0 srt_escape)
619 srt_lbl <- getSRTLabel
620 return (C_SRT srt_lbl off (fromIntegral (head bmp)))
622 srt_escape = (-1) :: StgHalfWord
624 getSRTLabel :: FCode CLabel -- Used only by cgPanic
625 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
628 setSRTLabel :: CLabel -> FCode a -> FCode a
629 setSRTLabel srt_lbl code
630 = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
631 withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
635 getTickyCtrLabel :: FCode CLabel
636 getTickyCtrLabel = do
637 (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
640 setTickyCtrLabel :: CLabel -> Code -> Code
641 setTickyCtrLabel ticky code = do
642 (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
643 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)