2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CgMonad]{The code generation monad}
6 See the beginning of the top-level @CodeGen@ module, to see how this
7 monadic stuff fits into the Big Picture.
10 #include "HsVersions.h"
16 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
17 returnFC, fixC, absC, nopC, getAbsC,
19 forkClosureBody, forkStatics, forkAlts, forkEval,
20 forkEvalHelp, forkAbsC,
23 addBindC, addBindsC, modifyBindC, lookupBindC,
27 setEndOfBlockInfo, getEndOfBlockInfo,
29 AStackUsage(..), BStackUsage(..), HeapUsage(..),
32 --UNUSED: grabStackSizeC,
34 nukeDeadBindings, getUnstubbedAStackSlots,
36 -- addFreeASlots, -- no need to export it
37 addFreeBSlots, -- ToDo: Belong elsewhere
39 isSwitchSetC, isStringSwitchSetC,
42 profCtrC, --UNUSED: concurrentC,
44 costCentresC, costCentresFlag, moduleName,
46 Sequel(..), -- ToDo: unabstract?
49 -- out of general friendliness, we also export ...
51 CgInfoDownwards(..), CgState(..), -- non-abstract
54 GlobalSwitch, -- abstract
56 stableAmodeIdInfo, heapIdInfo,
58 -- and to make the interface self-sufficient...
59 AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..),
60 Unique, HeapOffset, CostCentre, IsCafCC,
61 Id, UniqSet(..), UniqFM,
62 VirtualSpAOffset(..), VirtualSpBOffset(..),
63 VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..),
68 import AbsUniType ( kindFromType, UniType
69 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
72 import CgUsages ( getSpBRelOffset )
73 import CmdLineOpts ( GlobalSwitch(..) )
74 import Id ( getIdUniType, ConTag(..), DataCon(..) )
75 import IdEnv -- ops on CgBindings use these
76 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
77 import Pretty -- debugging only?
78 import PrimKind ( getKindSize, retKindSize )
79 import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
80 import CostCentre -- profiling stuff
81 import StgSyn ( PlainStgAtom(..), PlainStgLiveVars(..) )
82 import Unique ( UniqueSupply )
85 infixr 9 `thenC` -- Right-associative!
89 %************************************************************************
91 \subsection[CgMonad-environment]{Stuff for manipulating environments}
93 %************************************************************************
95 This monadery has some information that it only passes {\em
96 downwards}, as well as some ``state'' which is modified as we go
100 data CgInfoDownwards -- information only passed *downwards* by the monad
102 CompilationInfo -- COMPLETELY STATIC info about this compilation
103 -- (e.g., what flags were passed to the compiler)
105 CgBindings -- [Id -> info] : static environment
107 EndOfBlockInfo -- Info for stuff to do at end of basic block:
112 (GlobalSwitch -> Bool)
113 -- use it to look up whatever we like in command-line flags
114 FAST_STRING -- the module name
119 AbstractC -- code accumulated so far
120 CgBindings -- [Id -> info] : *local* bindings environment
121 -- Bindings for top-level things are given in the info-down part
125 @EndOfBlockInfo@ tells what to do at the end of this block of code
126 or, if the expression is a @case@, what to do at the end of each alternative.
131 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
132 -- push arguments starting just above this point on
135 -- This is therefore the A-stk ptr as seen
136 -- by a case alternative.
138 -- Args SpA is used when we want to stub any
139 -- currently-unstubbed dead A-stack (ptr) slots;
140 -- we want to know what SpA in the continuation is
141 -- so that we don't stub any slots which are off the
142 -- top of the continuation's stack!
144 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
146 -- Two main differences:
147 -- 1. If Sequel isn't OnStack, then Args SpB points
148 -- just below the slot in which the return address
149 -- should be put. In effect, the Sequel is
150 -- a pending argument. If it is OnStack, Args SpB
151 -- points to the top word of the return address.
153 -- 2. It ain't used for stubbing because there are
159 initEobInfo = EndOfBlockInfo 0 0 InRetReg
164 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
165 that it must survive stack pointer adjustments at the end of the
170 = InRetReg -- The continuation is in RetReg
172 | OnStack VirtualSpBOffset
173 -- Continuation is on the stack, at the
174 -- specified location
177 --UNUSED: | RestoreCostCentre
179 | UpdateCode CAddrMode -- May be standard update code, or might be
180 -- the data-type-specific one.
183 CAddrMode -- Jump to this; if the continuation is for a vectored
184 -- case this might be the label of a return vector
185 -- Guaranteed to be a non-volatile addressing mode (I think)
189 type SemiTaggingStuff
190 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
191 ([(ConTag, JoinDetails)], -- Alternatives
192 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
193 -- Maybe[3] the default is a
194 -- bind-default (Just b); that is,
195 -- it expects a ptr to the thing
196 -- in Node, bound to b
200 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
201 -- and join point label
202 -- The abstract C is executed only from a successful
203 -- semitagging venture, when a case has looked at a variable, found
204 -- that it's evaluated, and wants to load up the contents and go to the
209 -- The OnStack case of sequelToAmode delivers an Amode which is only valid
210 -- just before the final control transfer, because it assumes that
211 -- SpB is pointing to the top word of the return address.
212 -- This seems unclean but there you go.
214 sequelToAmode :: Sequel -> FCode CAddrMode
216 sequelToAmode (OnStack virt_spb_offset)
217 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
218 returnFC (CVal spb_rel RetKind)
220 sequelToAmode InRetReg = returnFC (CReg RetReg)
221 --UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl
222 --Andy/Simon's patch:
223 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
224 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
225 sequelToAmode (CaseAlts amode _) = returnFC amode
227 -- ToDo: move/do something
228 --UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
231 See the NOTES about the details of stack/heap usage tracking.
234 type CgStksAndHeapUsage -- stacks and heap usage information
235 = (AStackUsage, -- A-stack usage
236 BStackUsage, -- B-stack usage
240 (Int, -- virtSpA: Virtual offset of topmost allocated slot
241 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
242 Int, -- realSpA: Virtual offset of real stack pointer
243 Int) -- hwSpA: Highest value ever taken by virtSp
245 data StubFlag = Stubbed | NotStubbed
247 isStubbed Stubbed = True -- so the type can be abstract
248 isStubbed NotStubbed = False
251 (Int, -- virtSpB: Virtual offset of topmost allocated slot
252 [Int], -- freeB: List of free slots, in increasing order
253 Int, -- realSpB: Virtual offset of real stack pointer
254 Int) -- hwSpB: Highest value ever taken by virtSp
257 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
258 HeapOffset) -- realHp: Virtual offset of real heap ptr
260 NB: absolutely every one of the above Ints is really
261 a VirtualOffset of some description (the code generator
262 works entirely in terms of VirtualOffsets; see NOTES).
267 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
269 initUsage :: CgStksAndHeapUsage
270 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
271 initVirtHp = panic "Uninitialised virtual Hp"
272 initRealHp = panic "Uninitialised real Hp"
275 @envInitForAlternatives@ initialises the environment for a case alternative,
276 assuming that the alternative is entered after an evaluation.
280 zapping any volatile bindings, which aren't valid.
282 zapping the heap usage. It should be restored by a heap check.
284 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
285 this doesn't represent any {\em code}; it is a prediction of where the
286 real stack pointer will be when we come back from the case analysis.
288 BUT LEAVING the rest of the stack-usage info because it is all valid.
289 In particular, we leave the tail stack pointers unchanged, becuase the
290 alternative has to de-allocate the original @case@ expression's stack.
293 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
294 marks found in $e_2$.
297 stateIncUsage :: CgState -> CgState -> CgState
299 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
300 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
303 ((vA,fA,rA,hA1 `max` hA2),
304 (vB,fB,rB,hB1 `max` hB2),
305 (vH1 `maxOff` vH2, rH1))
308 %************************************************************************
310 \subsection[CgMonad-basics]{Basic code-generation monad magic}
312 %************************************************************************
315 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
316 type Code = CgInfoDownwards -> CgState -> CgState
318 #ifdef __GLASGOW_HASKELL__
320 {-# INLINE thenFC #-}
321 {-# INLINE returnFC #-}
324 The Abstract~C is not in the environment so as to improve strictness.
327 initC :: CompilationInfo -> Code -> AbstractC
330 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
332 MkCgState abc _ _ -> abc
334 returnFC :: a -> FCode a
336 returnFC val info_down state = (val, state)
341 -> (CgInfoDownwards -> CgState -> a)
342 -> CgInfoDownwards -> CgState -> a
344 -- thenC has both of the following types:
345 -- thenC :: Code -> Code -> Code
346 -- thenC :: Code -> FCode a -> FCode a
348 (m `thenC` k) info_down state
349 = k info_down new_state
351 new_state = m info_down state
353 listCs :: [Code] -> Code
355 listCs [] info_down state = state
356 listCs (c:cs) info_down state = stateN
358 state1 = c info_down state
359 stateN = listCs cs info_down state1
361 mapCs :: (a -> Code) -> [a] -> Code
363 mapCs f [] info_down state = state
364 mapCs f (c:cs) info_down state = stateN
366 state1 = (f c) info_down state
367 stateN = mapCs f cs info_down state1
372 -> (a -> CgInfoDownwards -> CgState -> c)
373 -> CgInfoDownwards -> CgState -> c
375 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
376 -- thenFC :: FCode a -> (a -> Code) -> Code
378 (m `thenFC` k) info_down state
379 = k m_result info_down new_state
381 (m_result, new_state) = m info_down state
383 listFCs :: [FCode a] -> FCode [a]
385 listFCs [] info_down state = ([], state)
386 listFCs (fc:fcs) info_down state = (thing : things, stateN)
388 (thing, state1) = fc info_down state
389 (things, stateN) = listFCs fcs info_down state1
391 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
393 mapFCs f [] info_down state = ([], state)
394 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
396 (thing, state1) = (f fc) info_down state
397 (things, stateN) = mapFCs f fcs info_down state1
400 And the knot-tying combinator:
402 fixC :: (a -> FCode a) -> FCode a
403 fixC fcode info_down state = result
405 result@(v, _) = fcode v info_down state
409 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
410 fresh environment, except that:
411 - compilation info and statics are passed in unchanged.
412 The current environment is passed on completely unaltered, except that
413 abstract C from the fork is incorporated.
415 @forkAbsC@ takes a code and compiles it in the current environment,
416 returning the abstract C thus constructed. The current environment
417 is passed on completely unchanged. It is pretty similar to @getAbsC@,
418 except that the latter does affect the environment. ToDo: combine?
420 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
421 from the current bindings, but which is otherwise freshly initialised.
422 The Abstract~C returned is attached to the current state, but the
423 bindings and usage information is otherwise unchanged.
426 forkClosureBody :: Code -> Code
429 (MkCgInfoDown cg_info statics _)
430 (MkCgState absC_in binds un_usage)
431 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
433 fork_state = code body_info_down initialStateC
434 MkCgState absC_fork _ _ = fork_state
435 body_info_down = MkCgInfoDown cg_info statics initEobInfo
437 forkStatics :: FCode a -> FCode a
439 forkStatics fcode (MkCgInfoDown cg_info _ _)
440 (MkCgState absC_in statics un_usage)
441 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
443 (result, state) = fcode rhs_info_down initialStateC
444 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
445 -- above or it becomes too strict!
446 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
448 forkAbsC :: Code -> FCode AbstractC
449 forkAbsC code info_down (MkCgState absC1 bs usage)
452 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
453 code info_down (MkCgState AbsCNop bs usage)
454 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
456 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
457 new_state = MkCgState absC1 bs new_usage
460 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
461 an fcode for the default case $d$, and compiles each in the current
462 environment. The current environment is passed on unmodified, except
464 - the worst stack high-water mark is incorporated
465 - the virtual Hp is moved on to the worst virtual Hp for the branches
467 The "extra branches" arise from handling the default case:
473 Here we in effect expand to
477 C2 c -> let z = C2 c in JUMP(default)
478 C3 d e f -> let z = C2 d e f in JUMP(default)
482 The stuff for C2 and C3 are the extra branches. They are
483 handled differently by forkAlts, because their
484 heap usage is joined onto that for the default case.
487 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
489 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
490 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
492 compile fc = fc info_down in_state
494 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
495 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
497 -- The "in_state" for the default branch is got by worst-casing the
498 -- heap usages etc from the "extra_branches"
499 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
500 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
502 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
503 -- NB foldl. in_state is the *left* argument to stateIncUsage
506 @forkEval@ takes two blocks of code.
508 \item The first meddles with the environment to set it up as expected by
509 the alternatives of a @case@ which does an eval (or gc-possible primop).
510 \item The second block is the code for the alternatives.
511 (plus info for semi-tagging purposes)
513 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
514 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
515 the caller to use, together with whatever value is returned by the second block.
517 It uses @initEnvForAlternatives@ to initialise the environment, and
518 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
522 forkEval :: EndOfBlockInfo -- For the body
523 -> Code -- Code to set environment
524 -> FCode Sequel -- Semi-tagging info to store
525 -> FCode EndOfBlockInfo -- The new end of block info
527 forkEval body_eob_info env_code body_code
528 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
529 returnFC (EndOfBlockInfo vA vB sequel)
531 forkEvalHelp :: EndOfBlockInfo -- For the body
532 -> Code -- Code to set environment
533 -> FCode a -- The code to do after the eval
534 -> FCode (Int, -- SpA
536 a) -- Result of the FCode
538 forkEvalHelp body_eob_info env_code body_code
539 info_down@(MkCgInfoDown cg_info statics _) state
540 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
542 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
544 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
545 -- These vA and fA things are now set up as the body code expects them
547 state_at_end_return :: CgState
549 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
551 state_for_body :: CgState
553 state_for_body = MkCgState AbsCNop
554 (nukeVolatileBinds binds)
555 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
556 (vB,fB,vB,vB), -- to virtual ones
557 (initVirtHp, initRealHp))
559 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
560 -- In the branch, all free locations will have been stubbed
563 stateIncUsageEval :: CgState -> CgState -> CgState
564 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
565 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
566 = MkCgState (absC1 `AbsCStmts` absC2)
567 -- The AbsC coming back should consist only of nested declarations,
568 -- notably of the return vector!
570 ((vA,fA,rA,hA1 `max` hA2),
571 (vB,fB,rB,hB1 `max` hB2),
573 -- We don't max the heap high-watermark because stateIncUsageEval is
574 -- used only in forkEval, which in turn is only used for blocks of code
575 -- which do their own heap-check.
578 %************************************************************************
580 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
582 %************************************************************************
584 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
585 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
588 nopC info_down state = state
590 absC :: AbstractC -> Code
591 absC more_absC info_down state@(MkCgState absC binds usage)
592 = MkCgState (mkAbsCStmts absC more_absC) binds usage
595 These two are just like @absC@, except they examine the compilation
596 info (whether SCC profiling or profiling-ctrs going) and possibly emit
600 isSwitchSetC :: GlobalSwitch -> FCode Bool
602 isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
603 = (sw_chkr switch, state)
605 isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
607 isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
608 = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
610 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
612 costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
613 state@(MkCgState absC binds usage)
614 = if sw_chkr SccProfilingOn
615 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
618 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
620 profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
621 state@(MkCgState absC binds usage)
622 = if not (sw_chkr DoTickyProfiling)
624 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
626 {- Try to avoid adding too many special compilation strategies here.
627 It's better to modify the header files as necessary for particular targets,
628 so that we can get away with as few variants of .hc files as possible.
629 'ForConcurrent' is somewhat special anyway, as it changes entry conventions
630 pretty significantly.
633 -- if compiling for concurrency...
635 {- UNUSED, as it happens:
636 concurrentC :: AbstractC -> Code
638 concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
639 state@(MkCgState absC binds usage)
640 = if not (sw_chkr ForConcurrent)
642 else MkCgState (mkAbsCStmts absC more_absC) binds usage
646 @getAbsC@ compiles the code in the current environment, and returns
647 the abstract C thus constructed (leaving the abstract C being carried
648 around in the state untouched). @getAbsC@ does not generate any
649 in-line Abstract~C itself, but the environment it returns is that
650 obtained from the compilation.
653 getAbsC :: Code -> FCode AbstractC
655 getAbsC code info_down (MkCgState absC binds usage)
656 = (absC2, MkCgState absC binds2 usage2)
658 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
662 noBlackHolingFlag, costCentresFlag :: FCode Bool
664 noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
665 = (sw_chkr OmitBlackHoling, state)
667 costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
668 = (sw_chkr SccProfilingOn, state)
673 moduleName :: FCode FAST_STRING
674 moduleName (MkCgInfoDown (MkCompInfo _ mod_name) _ _) state
680 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
681 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
682 = code (MkCgInfoDown c_info statics eob_info) state
684 getEndOfBlockInfo :: FCode EndOfBlockInfo
685 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
689 %************************************************************************
691 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
693 %************************************************************************
695 There are three basic routines, for adding (@addBindC@), modifying
696 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
697 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
698 on the end of each function name).
700 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
701 The name should not already be bound.
703 addBindC :: Id -> CgIdInfo -> Code
704 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
705 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
709 addBindsC :: [(Id, CgIdInfo)] -> Code
710 addBindsC new_bindings info_down (MkCgState absC binds usage)
711 = MkCgState absC new_binds usage
713 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
719 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
720 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
721 = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
724 Lookup is expected to find a binding for the @Id@.
726 lookupBindC :: Id -> FCode CgIdInfo
727 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
728 state@(MkCgState absC local_binds usage)
731 val = case (lookupIdEnv local_binds name) of
732 Nothing -> try_static
735 try_static = case (lookupIdEnv static_binds name) of
738 -> pprPanic "lookupBindC:no info!\n"
740 ppCat [ppStr "for:", ppr PprShowAll name],
741 ppStr "(probably: data dependencies broken by an optimisation pass)",
742 ppStr "static binds for:",
743 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
744 ppStr "local binds for:",
745 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
749 For dumping debug information, we also have the ability to grab the
750 local bindings environment.
752 ToDo: Maybe do the pretty-printing here to restrict what people do
753 with the environment.
757 grabBindsC :: FCode CgBindings
758 grabBindsC info_down state@(MkCgState absC binds usage)
765 grabStackSizeC :: FCode (Int, Int)
766 grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
767 = panic "grabStackSizeC" -- (vA, vB)
771 %************************************************************************
773 \subsection[CgStackery-deadslots]{Finding dead stack slots}
775 %************************************************************************
777 @nukeDeadBindings@ does the following:
779 \item Removes all bindings from the environment other than those
780 for variables in the argument to @nukeDeadBindings@.
781 \item Collects any stack slots so freed, and returns them to the appropriate
783 \item Moves the virtual stack pointers to point to the topmost used
787 Find dead slots on the stacks *and* remove bindings for dead variables
790 You can have multi-word slots on the B stack; if dead, such a slot
791 will be reported as {\em several} offsets (one per word).
793 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
794 set, so that no stack-stubbing will take place.
796 Probably *naughty* to look inside monad...
799 nukeDeadBindings :: PlainStgLiveVars -- All the *live* variables
804 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
805 (vsp_b, free_b, real_b, hw_b),
807 = MkCgState abs_c (mkIdEnv bs') new_usage
809 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
810 (new_vsp_b, new_free_b, real_b, hw_b),
813 (dead_a_slots, dead_b_slots, bs')
814 = dead_slots live_vars
816 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
817 --OLD: (getIdEnvMapping binds)
819 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
820 extra_free_b = sortLt (<) dead_b_slots
822 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
823 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
825 getUnstubbedAStackSlots
826 :: VirtualSpAOffset -- Ignore slots bigger than this
827 -> FCode [VirtualSpAOffset] -- Return the list of slots found
829 getUnstubbedAStackSlots tail_spa
830 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
831 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
834 Several boring auxiliary functions to do the dirty work.
837 dead_slots :: PlainStgLiveVars
838 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
840 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
842 -- dead_slots carries accumulating parameters for
843 -- filtered bindings, dead a and b slots
844 dead_slots live_vars fbs das dbs []
845 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
847 dead_slots live_vars fbs das dbs ((v,i):bs)
848 | v `elementOfUniqSet` live_vars
849 = dead_slots live_vars ((v,i):fbs) das dbs bs
850 -- Live, so don't record it in dead slots
851 -- Instead keep it in the filtered bindings
855 MkCgIdInfo _ _ stable_loc _
857 dead_slots live_vars fbs (offsetA : das) dbs bs
860 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
862 maybe_Astk_loc = maybeAStkLoc stable_loc
863 is_Astk_loc = maybeToBool maybe_Astk_loc
864 (Just offsetA) = maybe_Astk_loc
866 maybe_Bstk_loc = maybeBStkLoc stable_loc
867 is_Bstk_loc = maybeToBool maybe_Bstk_loc
868 (Just offsetB) = maybe_Bstk_loc
870 _ -> dead_slots live_vars fbs das dbs bs
873 size = (getKindSize . kindFromType . getIdUniType) v
875 -- addFreeSlots expects *both* args to be in increasing order
876 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
877 addFreeASlots = addFreeSlots fst
879 addFreeBSlots :: [Int] -> [Int] -> [Int]
880 addFreeBSlots = addFreeSlots id
882 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
884 addFreeSlots get_offset cs [] = cs
885 addFreeSlots get_offset [] ns = ns
886 addFreeSlots get_offset (c:cs) (n:ns)
887 = if off_c < off_n then
888 (c : addFreeSlots get_offset cs (n:ns))
889 else if off_c > off_n then
890 (n : addFreeSlots get_offset (c:cs) ns)
892 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
897 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
899 trim get_offset current_sp free_slots
900 = try current_sp (reverse free_slots)
902 try csp [] = (csp, [])
904 = if csp < slot_off then
905 try csp slots -- Free slot off top of stk; ignore
907 else if csp == slot_off then
908 try (csp-1) slots -- Free slot at top of stk; trim
911 (csp, reverse (slot:slots)) -- Otherwise gap; give up
913 slot_off = get_offset slot