2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 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 )
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 (Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
155 -- The default branch expects a
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)
189 sequelToAmode (CaseAlts amode _ False) = returnFC amode
190 sequelToAmode (CaseAlts amode _ True) = returnFC (CLbl mkSeqInfoLabel RetRep)
192 type CgStksAndHeapUsage -- stacks and heap usage information
193 = (StackUsage, HeapUsage)
195 data Slot = Free | NonPointer
204 (Int, -- virtSp: Virtual offset of topmost allocated slot
205 Int, -- frameSp: End of the current stack frame
206 [(Int,Slot)], -- free: List of free slots, in increasing order
207 Int, -- realSp: Virtual offset of real stack pointer
208 Int) -- hwSp: Highest value ever taken by virtSp
210 -- ToDo (SDM, 7 Jan 2003): I'm not sure that the distinction between
211 -- Free and NonPointer in the free list is needed any more. It used
212 -- to be needed because we constructed bitmaps from the free list, but
213 -- now we construct bitmaps by finding all the live pointer bindings
214 -- instead. Non-pointer stack slots (i.e. saved cost centres) can
215 -- just be removed from the free list instead of being recorded as a
219 (HeapOffset, -- virtHp: Virtual offset of highest-allocated word
220 HeapOffset) -- realHp: Virtual offset of real heap ptr
223 NB: absolutely every one of the above Ints is really
224 a VirtualOffset of some description (the code generator
225 works entirely in terms of VirtualOffsets).
230 initialStateC = MkCgState AbsCNop emptyVarEnv initUsage
232 initUsage :: CgStksAndHeapUsage
233 initUsage = ((0,0,[],0,0), (0,0))
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,t,f,r,h1),(vH1,rH1)))
243 (MkCgState _ _ ((_,_,_,_,h2),(vH2, _)))
246 ((v,t,f,r,h1 `max` h2),
247 (vH1 `max` vH2, rH1))
250 %************************************************************************
252 \subsection[CgMonad-basics]{Basic code-generation monad magic}
254 %************************************************************************
257 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
260 instance Monad FCode where
265 {-# INLINE thenFC #-}
266 {-# INLINE returnFC #-}
268 The Abstract~C is not in the environment so as to improve strictness.
271 initC :: CompilationInfo -> Code -> AbstractC
273 initC cg_info (FCode code)
274 = case (code (MkCgInfoDown
276 emptyVarEnv -- (error "initC: statics")
281 ((),MkCgState abc _ _) -> abc
283 returnFC :: a -> FCode a
284 returnFC val = FCode (\info_down state -> (val, state))
288 thenC :: Code -> FCode a -> FCode a
289 thenC (FCode m) (FCode k) =
290 FCode (\info_down state -> let (_,new_state) = m info_down state in
291 k info_down new_state)
293 listCs :: [Code] -> Code
294 listCs [] = return ()
299 mapCs :: (a -> Code) -> [a] -> Code
304 thenFC :: FCode a -> (a -> FCode c) -> FCode c
305 thenFC (FCode m) k = FCode (
308 (m_result, new_state) = m info_down state
309 (FCode kcode) = k m_result
311 kcode info_down new_state
314 listFCs :: [FCode a] -> FCode [a]
317 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
321 And the knot-tying combinator:
323 fixC :: (a -> FCode a) -> FCode a
328 result@(v,_) = fc info_down state
335 Operators for getting and setting the state and "info_down".
336 To maximise encapsulation, code should try to only get and set the
337 state it actually uses.
340 getState :: FCode CgState
341 getState = FCode $ \info_down state -> (state,state)
343 setState :: CgState -> FCode ()
344 setState state = FCode $ \info_down _ -> ((),state)
346 getUsage :: FCode CgStksAndHeapUsage
348 MkCgState absC binds usage <- getState
351 setUsage :: CgStksAndHeapUsage -> FCode ()
352 setUsage newusage = do
353 MkCgState absC binds usage <- getState
354 setState $ MkCgState absC binds newusage
356 getBinds :: FCode CgBindings
358 MkCgState absC binds usage <- getState
361 setBinds :: CgBindings -> FCode ()
362 setBinds newbinds = do
363 MkCgState absC binds usage <- getState
364 setState $ MkCgState absC newbinds usage
366 getStaticBinds :: FCode CgBindings
368 (MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
371 withState :: FCode a -> CgState -> FCode (a,CgState)
372 withState (FCode fcode) newstate = FCode $ \info_down state ->
373 let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
375 getInfoDown :: FCode CgInfoDownwards
376 getInfoDown = FCode $ \info_down state -> (info_down,state)
378 withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
379 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
381 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
382 doFCode (FCode fcode) info_down state = fcode info_down state
386 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
387 fresh environment, except that:
388 - compilation info and statics are passed in unchanged.
389 The current environment is passed on completely unaltered, except that
390 abstract C from the fork is incorporated.
392 @forkAbsC@ takes a code and compiles it in the current environment,
393 returning the abstract C thus constructed. The current environment
394 is passed on completely unchanged. It is pretty similar to @getAbsC@,
395 except that the latter does affect the environment. ToDo: combine?
397 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
398 from the current bindings, but which is otherwise freshly initialised.
399 The Abstract~C returned is attached to the current state, but the
400 bindings and usage information is otherwise unchanged.
403 forkClosureBody :: Code -> Code
405 forkClosureBody (FCode code) = do
406 (MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
407 (MkCgState absC_in binds un_usage) <- getState
408 let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
409 let ((),fork_state) = code body_info_down initialStateC
410 let MkCgState absC_fork _ _ = fork_state
411 setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
413 forkStatics :: FCode a -> FCode a
415 forkStatics (FCode fcode) = FCode (
416 \(MkCgInfoDown cg_info _ srt ticky _)
417 (MkCgState absC_in statics un_usage)
420 (result, state) = fcode rhs_info_down initialStateC
421 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
422 -- above or it becomes too strict!
423 rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
425 (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
428 forkAbsC :: Code -> FCode AbstractC
429 forkAbsC (FCode code) =
431 info_down <- getInfoDown
432 (MkCgState absC1 bs usage) <- getState
433 let ((),MkCgState absC2 _ ((_, _, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
434 let ((v, t, f, r, h1), heap_usage) = usage
435 let new_usage = ((v, t, f, r, h1 `max` h2), heap_usage)
436 setState $ MkCgState absC1 bs new_usage
440 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
441 an fcode for the default case $d$, and compiles each in the current
442 environment. The current environment is passed on unmodified, except
444 - the worst stack high-water mark is incorporated
445 - the virtual Hp is moved on to the worst virtual Hp for the branches
448 forkAlts :: [FCode a] -> FCode [a]
450 forkAlts branch_fcodes
451 = do info_down <- getInfoDown
453 let compile (FCode fc) = fc info_down in_state
454 let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
455 setState $ foldl stateIncUsage in_state branch_out_states
456 -- NB foldl. in_state is the *left* argument to stateIncUsage
457 return branch_results
460 @forkEval@ takes two blocks of code.
462 - The first meddles with the environment to set it up as expected by
463 the alternatives of a @case@ which does an eval (or gc-possible primop).
464 - The second block is the code for the alternatives.
465 (plus info for semi-tagging purposes)
467 @forkEval@ picks up the virtual stack pointer and returns a suitable
468 @EndOfBlockInfo@ for the caller to use, together with whatever value
469 is returned by the second block.
471 It uses @initEnvForAlternatives@ to initialise the environment, and
472 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
476 forkEval :: EndOfBlockInfo -- For the body
477 -> Code -- Code to set environment
478 -> FCode Sequel -- Semi-tagging info to store
479 -> FCode EndOfBlockInfo -- The new end of block info
481 forkEval body_eob_info env_code body_code
482 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (v, sequel) ->
483 returnFC (EndOfBlockInfo v sequel)
485 forkEvalHelp :: EndOfBlockInfo -- For the body
486 -> Code -- Code to set environment
487 -> FCode a -- The code to do after the eval
489 a) -- Result of the FCode
491 forkEvalHelp body_eob_info env_code body_code =
493 info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
495 let info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info
496 let (_,MkCgState _ binds ((v,t,f,_,_),_)) =
497 doFCode env_code info_down_for_body state
498 let state_for_body = MkCgState AbsCNop
499 (nukeVolatileBinds binds)
501 let (value_returned, state_at_end_return) =
502 doFCode body_code info_down_for_body state_for_body
503 setState $ state `stateIncUsageEval` state_at_end_return
504 return (v,value_returned)
506 stateIncUsageEval :: CgState -> CgState -> CgState
507 stateIncUsageEval (MkCgState absC1 bs ((v,t,f,r,h1),heap_usage))
508 (MkCgState absC2 _ ((_,_,_,_,h2), _))
509 = MkCgState (absC1 `mkAbsCStmts` absC2)
510 -- The AbsC coming back should consist only of nested declarations,
511 -- notably of the return vector!
513 ((v,t,f,r,h1 `max` h2), heap_usage)
514 -- We don't max the heap high-watermark because stateIncUsageEval is
515 -- used only in forkEval, which in turn is only used for blocks of code
516 -- which do their own heap-check.
519 %************************************************************************
521 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
523 %************************************************************************
525 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
526 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
531 absC :: AbstractC -> Code
533 state@(MkCgState absC binds usage) <- getState
534 setState $ MkCgState (mkAbsCStmts absC more_absC) binds usage
537 These two are just like @absC@, except they examine the compilation
538 info (whether SCC profiling or profiling-ctrs going) and possibly emit
542 costCentresC :: FastString -> [CAddrMode] -> Code
543 costCentresC macro args
544 | opt_SccProfilingOn = absC (CCallProfCCMacro macro args)
547 profCtrC :: FastString -> [CAddrMode] -> Code
549 | opt_DoTickyProfiling = absC (CCallProfCtrMacro macro args)
552 profCtrAbsC :: FastString -> [CAddrMode] -> AbstractC
553 profCtrAbsC macro args
554 | opt_DoTickyProfiling = CCallProfCtrMacro macro args
555 | otherwise = AbsCNop
558 ldvEnter = costCentresC FSLIT("LDV_ENTER") [CReg node]
560 {- Try to avoid adding too many special compilation strategies here.
561 It's better to modify the header files as necessary for particular
562 targets, so that we can get away with as few variants of .hc files
567 @getAbsC@ compiles the code in the current environment, and returns
568 the abstract C thus constructed (leaving the abstract C being carried
569 around in the state untouched). @getAbsC@ does not generate any
570 in-line Abstract~C itself, but the environment it returns is that
571 obtained from the compilation.
574 getAbsC :: Code -> FCode AbstractC
576 MkCgState absC binds usage <- getState
577 ((),MkCgState absC2 binds2 usage2) <- withState code (MkCgState AbsCNop binds usage)
578 setState $ MkCgState absC binds2 usage2
583 moduleName :: FCode Module
585 (MkCgInfoDown (MkCompInfo mod_name) _ _ _ _) <- getInfoDown
590 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
591 setEndOfBlockInfo eob_info code = do
592 (MkCgInfoDown c_info statics srt ticky _) <- getInfoDown
593 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
595 getEndOfBlockInfo :: FCode EndOfBlockInfo
596 getEndOfBlockInfo = do
597 (MkCgInfoDown c_info statics _ _ eob_info) <- getInfoDown
601 There is just one SRT for each top level binding; all the nested
602 bindings use sub-sections of this SRT. The label is passed down to
603 the nested bindings via the monad.
606 getSRTInfo :: Name -> SRT -> FCode C_SRT
607 getSRTInfo id NoSRT = return NoC_SRT
608 getSRTInfo id (SRT off len bmp)
609 | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do
610 srt_lbl <- getSRTLabel
611 let srt_desc_lbl = mkSRTDescLabel id
612 absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
613 return (C_SRT srt_desc_lbl 0 srt_escape)
615 srt_lbl <- getSRTLabel
616 return (C_SRT srt_lbl off (fromIntegral (head bmp)))
618 srt_escape = (-1) :: StgHalfWord
620 getSRTLabel :: FCode CLabel -- Used only by cgPanic
621 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
624 setSRTLabel :: CLabel -> FCode a -> FCode a
625 setSRTLabel srt_lbl code
626 = do MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
627 withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
631 getTickyCtrLabel :: FCode CLabel
632 getTickyCtrLabel = do
633 (MkCgInfoDown _ _ _ ticky _) <- getInfoDown
636 setTickyCtrLabel :: CLabel -> Code -> Code
637 setTickyCtrLabel ticky code = do
638 (MkCgInfoDown c_info statics srt _ eob_info) <- getInfoDown
639 withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)