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, getIntSwitchChkrC,
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
53 CompilationInfo(..), IntSwitchChecker(..),
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 IntSwitchChecker-- similar; for flags that have an Int assoc.
115 -- with them, notably number of regs available.
116 FAST_STRING -- the module name
118 type IntSwitchChecker = (Int -> GlobalSwitch) -> Maybe Int
122 AbstractC -- code accumulated so far
123 CgBindings -- [Id -> info] : *local* bindings environment
124 -- Bindings for top-level things are given in the info-down part
128 @EndOfBlockInfo@ tells what to do at the end of this block of code
129 or, if the expression is a @case@, what to do at the end of each alternative.
134 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
135 -- push arguments starting just above this point on
138 -- This is therefore the A-stk ptr as seen
139 -- by a case alternative.
141 -- Args SpA is used when we want to stub any
142 -- currently-unstubbed dead A-stack (ptr) slots;
143 -- we want to know what SpA in the continuation is
144 -- so that we don't stub any slots which are off the
145 -- top of the continuation's stack!
147 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
149 -- Two main differences:
150 -- 1. If Sequel isn't OnStack, then Args SpB points
151 -- just below the slot in which the return address
152 -- should be put. In effect, the Sequel is
153 -- a pending argument. If it is OnStack, Args SpB
154 -- points to the top word of the return address.
156 -- 2. It ain't used for stubbing because there are
162 initEobInfo = EndOfBlockInfo 0 0 InRetReg
167 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
168 that it must survive stack pointer adjustments at the end of the
173 = InRetReg -- The continuation is in RetReg
175 | OnStack VirtualSpBOffset
176 -- Continuation is on the stack, at the
177 -- specified location
180 --UNUSED: | RestoreCostCentre
182 | UpdateCode CAddrMode -- May be standard update code, or might be
183 -- the data-type-specific one.
186 CAddrMode -- Jump to this; if the continuation is for a vectored
187 -- case this might be the label of a return vector
188 -- Guaranteed to be a non-volatile addressing mode (I think)
192 type SemiTaggingStuff
193 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
194 ([(ConTag, JoinDetails)], -- Alternatives
195 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
196 -- Maybe[3] the default is a
197 -- bind-default (Just b); that is,
198 -- it expects a ptr to the thing
199 -- in Node, bound to b
203 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
204 -- and join point label
205 -- The abstract C is executed only from a successful
206 -- semitagging venture, when a case has looked at a variable, found
207 -- that it's evaluated, and wants to load up the contents and go to the
212 -- The OnStack case of sequelToAmode delivers an Amode which is only valid
213 -- just before the final control transfer, because it assumes that
214 -- SpB is pointing to the top word of the return address.
215 -- This seems unclean but there you go.
217 sequelToAmode :: Sequel -> FCode CAddrMode
219 sequelToAmode (OnStack virt_spb_offset)
220 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
221 returnFC (CVal spb_rel RetKind)
223 sequelToAmode InRetReg = returnFC (CReg RetReg)
224 --UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl
225 --Andy/Simon's patch:
226 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
227 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
228 sequelToAmode (CaseAlts amode _) = returnFC amode
230 -- ToDo: move/do something
231 --UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl"
234 See the NOTES about the details of stack/heap usage tracking.
237 type CgStksAndHeapUsage -- stacks and heap usage information
238 = (AStackUsage, -- A-stack usage
239 BStackUsage, -- B-stack usage
243 (Int, -- virtSpA: Virtual offset of topmost allocated slot
244 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
245 Int, -- realSpA: Virtual offset of real stack pointer
246 Int) -- hwSpA: Highest value ever taken by virtSp
248 data StubFlag = Stubbed | NotStubbed
250 isStubbed Stubbed = True -- so the type can be abstract
251 isStubbed NotStubbed = False
254 (Int, -- virtSpB: Virtual offset of topmost allocated slot
255 [Int], -- freeB: List of free slots, in increasing order
256 Int, -- realSpB: Virtual offset of real stack pointer
257 Int) -- hwSpB: Highest value ever taken by virtSp
260 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
261 HeapOffset) -- realHp: Virtual offset of real heap ptr
263 NB: absolutely every one of the above Ints is really
264 a VirtualOffset of some description (the code generator
265 works entirely in terms of VirtualOffsets; see NOTES).
270 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
272 initUsage :: CgStksAndHeapUsage
273 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
274 initVirtHp = panic "Uninitialised virtual Hp"
275 initRealHp = panic "Uninitialised real Hp"
278 @envInitForAlternatives@ initialises the environment for a case alternative,
279 assuming that the alternative is entered after an evaluation.
283 zapping any volatile bindings, which aren't valid.
285 zapping the heap usage. It should be restored by a heap check.
287 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
288 this doesn't represent any {\em code}; it is a prediction of where the
289 real stack pointer will be when we come back from the case analysis.
291 BUT LEAVING the rest of the stack-usage info because it is all valid.
292 In particular, we leave the tail stack pointers unchanged, becuase the
293 alternative has to de-allocate the original @case@ expression's stack.
296 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
297 marks found in $e_2$.
300 stateIncUsage :: CgState -> CgState -> CgState
302 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
303 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
306 ((vA,fA,rA,hA1 `max` hA2),
307 (vB,fB,rB,hB1 `max` hB2),
308 (vH1 `maxOff` vH2, rH1))
311 %************************************************************************
313 \subsection[CgMonad-basics]{Basic code-generation monad magic}
315 %************************************************************************
318 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
319 type Code = CgInfoDownwards -> CgState -> CgState
321 #ifdef __GLASGOW_HASKELL__
323 {-# INLINE thenFC #-}
324 {-# INLINE returnFC #-}
327 The Abstract~C is not in the environment so as to improve strictness.
330 initC :: CompilationInfo -> Code -> AbstractC
333 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
335 MkCgState abc _ _ -> abc
337 returnFC :: a -> FCode a
339 returnFC val info_down state = (val, state)
344 -> (CgInfoDownwards -> CgState -> a)
345 -> CgInfoDownwards -> CgState -> a
347 -- thenC has both of the following types:
348 -- thenC :: Code -> Code -> Code
349 -- thenC :: Code -> FCode a -> FCode a
351 (m `thenC` k) info_down state
352 = k info_down new_state
354 new_state = m info_down state
356 listCs :: [Code] -> Code
358 listCs [] info_down state = state
359 listCs (c:cs) info_down state = stateN
361 state1 = c info_down state
362 stateN = listCs cs info_down state1
364 mapCs :: (a -> Code) -> [a] -> Code
366 mapCs f [] info_down state = state
367 mapCs f (c:cs) info_down state = stateN
369 state1 = (f c) info_down state
370 stateN = mapCs f cs info_down state1
375 -> (a -> CgInfoDownwards -> CgState -> c)
376 -> CgInfoDownwards -> CgState -> c
378 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
379 -- thenFC :: FCode a -> (a -> Code) -> Code
381 (m `thenFC` k) info_down state
382 = k m_result info_down new_state
384 (m_result, new_state) = m info_down state
386 listFCs :: [FCode a] -> FCode [a]
388 listFCs [] info_down state = ([], state)
389 listFCs (fc:fcs) info_down state = (thing : things, stateN)
391 (thing, state1) = fc info_down state
392 (things, stateN) = listFCs fcs info_down state1
394 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
396 mapFCs f [] info_down state = ([], state)
397 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
399 (thing, state1) = (f fc) info_down state
400 (things, stateN) = mapFCs f fcs info_down state1
403 And the knot-tying combinator:
405 fixC :: (a -> FCode a) -> FCode a
406 fixC fcode info_down state = result
408 result@(v, _) = fcode v info_down state
412 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
413 fresh environment, except that:
414 - compilation info and statics are passed in unchanged.
415 The current environment is passed on completely unaltered, except that
416 abstract C from the fork is incorporated.
418 @forkAbsC@ takes a code and compiles it in the current environment,
419 returning the abstract C thus constructed. The current environment
420 is passed on completely unchanged. It is pretty similar to @getAbsC@,
421 except that the latter does affect the environment. ToDo: combine?
423 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
424 from the current bindings, but which is otherwise freshly initialised.
425 The Abstract~C returned is attached to the current state, but the
426 bindings and usage information is otherwise unchanged.
429 forkClosureBody :: Code -> Code
432 (MkCgInfoDown cg_info statics _)
433 (MkCgState absC_in binds un_usage)
434 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
436 fork_state = code body_info_down initialStateC
437 MkCgState absC_fork _ _ = fork_state
438 body_info_down = MkCgInfoDown cg_info statics initEobInfo
440 forkStatics :: FCode a -> FCode a
442 forkStatics fcode (MkCgInfoDown cg_info _ _)
443 (MkCgState absC_in statics un_usage)
444 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
446 (result, state) = fcode rhs_info_down initialStateC
447 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
448 -- above or it becomes too strict!
449 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
451 forkAbsC :: Code -> FCode AbstractC
452 forkAbsC code info_down (MkCgState absC1 bs usage)
455 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
456 code info_down (MkCgState AbsCNop bs usage)
457 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
459 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
460 new_state = MkCgState absC1 bs new_usage
463 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
464 an fcode for the default case $d$, and compiles each in the current
465 environment. The current environment is passed on unmodified, except
467 - the worst stack high-water mark is incorporated
468 - the virtual Hp is moved on to the worst virtual Hp for the branches
470 The "extra branches" arise from handling the default case:
476 Here we in effect expand to
480 C2 c -> let z = C2 c in JUMP(default)
481 C3 d e f -> let z = C2 d e f in JUMP(default)
485 The stuff for C2 and C3 are the extra branches. They are
486 handled differently by forkAlts, because their
487 heap usage is joined onto that for the default case.
490 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
492 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
493 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
495 compile fc = fc info_down in_state
497 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
498 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
500 -- The "in_state" for the default branch is got by worst-casing the
501 -- heap usages etc from the "extra_branches"
502 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
503 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
505 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
506 -- NB foldl. in_state is the *left* argument to stateIncUsage
509 @forkEval@ takes two blocks of code.
511 \item The first meddles with the environment to set it up as expected by
512 the alternatives of a @case@ which does an eval (or gc-possible primop).
513 \item The second block is the code for the alternatives.
514 (plus info for semi-tagging purposes)
516 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
517 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
518 the caller to use, together with whatever value is returned by the second block.
520 It uses @initEnvForAlternatives@ to initialise the environment, and
521 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
525 forkEval :: EndOfBlockInfo -- For the body
526 -> Code -- Code to set environment
527 -> FCode Sequel -- Semi-tagging info to store
528 -> FCode EndOfBlockInfo -- The new end of block info
530 forkEval body_eob_info env_code body_code
531 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
532 returnFC (EndOfBlockInfo vA vB sequel)
534 forkEvalHelp :: EndOfBlockInfo -- For the body
535 -> Code -- Code to set environment
536 -> FCode a -- The code to do after the eval
537 -> FCode (Int, -- SpA
539 a) -- Result of the FCode
541 forkEvalHelp body_eob_info env_code body_code
542 info_down@(MkCgInfoDown cg_info statics _) state
543 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
545 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
547 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
548 -- These vA and fA things are now set up as the body code expects them
550 state_at_end_return :: CgState
552 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
554 state_for_body :: CgState
556 state_for_body = MkCgState AbsCNop
557 (nukeVolatileBinds binds)
558 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
559 (vB,fB,vB,vB), -- to virtual ones
560 (initVirtHp, initRealHp))
562 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
563 -- In the branch, all free locations will have been stubbed
566 stateIncUsageEval :: CgState -> CgState -> CgState
567 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
568 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
569 = MkCgState (absC1 `AbsCStmts` absC2)
570 -- The AbsC coming back should consist only of nested declarations,
571 -- notably of the return vector!
573 ((vA,fA,rA,hA1 `max` hA2),
574 (vB,fB,rB,hB1 `max` hB2),
576 -- We don't max the heap high-watermark because stateIncUsageEval is
577 -- used only in forkEval, which in turn is only used for blocks of code
578 -- which do their own heap-check.
581 %************************************************************************
583 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
585 %************************************************************************
587 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
588 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
591 nopC info_down state = state
593 absC :: AbstractC -> Code
594 absC more_absC info_down state@(MkCgState absC binds usage)
595 = MkCgState (mkAbsCStmts absC more_absC) binds usage
598 These two are just like @absC@, except they examine the compilation
599 info (whether SCC profiling or profiling-ctrs going) and possibly emit
603 isSwitchSetC :: GlobalSwitch -> FCode Bool
605 isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
606 = (sw_chkr switch, state)
608 isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
610 isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
611 = (sw_chkr (switch (panic "isStringSwitchSetC")), state)
613 getIntSwitchChkrC :: FCode IntSwitchChecker
615 getIntSwitchChkrC (MkCgInfoDown (MkCompInfo _ isw_chkr _) _ _) state
618 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
620 costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
621 state@(MkCgState absC binds usage)
622 = if sw_chkr SccProfilingOn
623 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
626 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
628 profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
629 state@(MkCgState absC binds usage)
630 = if not (sw_chkr DoTickyProfiling)
632 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
634 {- Try to avoid adding too many special compilation strategies here.
635 It's better to modify the header files as necessary for particular targets,
636 so that we can get away with as few variants of .hc files as possible.
637 'ForConcurrent' is somewhat special anyway, as it changes entry conventions
638 pretty significantly.
641 -- if compiling for concurrency...
643 {- UNUSED, as it happens:
644 concurrentC :: AbstractC -> Code
646 concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
647 state@(MkCgState absC binds usage)
648 = if not (sw_chkr ForConcurrent)
650 else MkCgState (mkAbsCStmts absC more_absC) binds usage
654 @getAbsC@ compiles the code in the current environment, and returns
655 the abstract C thus constructed (leaving the abstract C being carried
656 around in the state untouched). @getAbsC@ does not generate any
657 in-line Abstract~C itself, but the environment it returns is that
658 obtained from the compilation.
661 getAbsC :: Code -> FCode AbstractC
663 getAbsC code info_down (MkCgState absC binds usage)
664 = (absC2, MkCgState absC binds2 usage2)
666 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
670 noBlackHolingFlag, costCentresFlag :: FCode Bool
672 noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
673 = (sw_chkr OmitBlackHoling, state)
675 costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
676 = (sw_chkr SccProfilingOn, state)
681 moduleName :: FCode FAST_STRING
682 moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state
688 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
689 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
690 = code (MkCgInfoDown c_info statics eob_info) state
692 getEndOfBlockInfo :: FCode EndOfBlockInfo
693 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
697 %************************************************************************
699 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
701 %************************************************************************
703 There are three basic routines, for adding (@addBindC@), modifying
704 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
705 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
706 on the end of each function name).
708 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
709 The name should not already be bound.
711 addBindC :: Id -> CgIdInfo -> Code
712 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
713 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
717 addBindsC :: [(Id, CgIdInfo)] -> Code
718 addBindsC new_bindings info_down (MkCgState absC binds usage)
719 = MkCgState absC new_binds usage
721 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
727 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
728 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
729 = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
732 Lookup is expected to find a binding for the @Id@.
734 lookupBindC :: Id -> FCode CgIdInfo
735 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
736 state@(MkCgState absC local_binds usage)
739 val = case (lookupIdEnv local_binds name) of
740 Nothing -> try_static
743 try_static = case (lookupIdEnv static_binds name) of
746 -> pprPanic "lookupBindC:no info!\n"
748 ppCat [ppStr "for:", ppr PprShowAll name],
749 ppStr "(probably: data dependencies broken by an optimisation pass)",
750 ppStr "static binds for:",
751 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
752 ppStr "local binds for:",
753 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
757 For dumping debug information, we also have the ability to grab the
758 local bindings environment.
760 ToDo: Maybe do the pretty-printing here to restrict what people do
761 with the environment.
765 grabBindsC :: FCode CgBindings
766 grabBindsC info_down state@(MkCgState absC binds usage)
773 grabStackSizeC :: FCode (Int, Int)
774 grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _))
775 = panic "grabStackSizeC" -- (vA, vB)
779 %************************************************************************
781 \subsection[CgStackery-deadslots]{Finding dead stack slots}
783 %************************************************************************
785 @nukeDeadBindings@ does the following:
787 \item Removes all bindings from the environment other than those
788 for variables in the argument to @nukeDeadBindings@.
789 \item Collects any stack slots so freed, and returns them to the appropriate
791 \item Moves the virtual stack pointers to point to the topmost used
795 Find dead slots on the stacks *and* remove bindings for dead variables
798 You can have multi-word slots on the B stack; if dead, such a slot
799 will be reported as {\em several} offsets (one per word).
801 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
802 set, so that no stack-stubbing will take place.
804 Probably *naughty* to look inside monad...
807 nukeDeadBindings :: PlainStgLiveVars -- All the *live* variables
812 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
813 (vsp_b, free_b, real_b, hw_b),
815 = MkCgState abs_c (mkIdEnv bs') new_usage
817 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
818 (new_vsp_b, new_free_b, real_b, hw_b),
821 (dead_a_slots, dead_b_slots, bs')
822 = dead_slots live_vars
824 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
825 --OLD: (getIdEnvMapping binds)
827 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
828 extra_free_b = sortLt (<) dead_b_slots
830 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
831 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
833 getUnstubbedAStackSlots
834 :: VirtualSpAOffset -- Ignore slots bigger than this
835 -> FCode [VirtualSpAOffset] -- Return the list of slots found
837 getUnstubbedAStackSlots tail_spa
838 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
839 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
842 Several boring auxiliary functions to do the dirty work.
845 dead_slots :: PlainStgLiveVars
846 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
848 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
850 -- dead_slots carries accumulating parameters for
851 -- filtered bindings, dead a and b slots
852 dead_slots live_vars fbs das dbs []
853 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
855 dead_slots live_vars fbs das dbs ((v,i):bs)
856 | v `elementOfUniqSet` live_vars
857 = dead_slots live_vars ((v,i):fbs) das dbs bs
858 -- Live, so don't record it in dead slots
859 -- Instead keep it in the filtered bindings
863 MkCgIdInfo _ _ stable_loc _
865 dead_slots live_vars fbs (offsetA : das) dbs bs
868 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
870 maybe_Astk_loc = maybeAStkLoc stable_loc
871 is_Astk_loc = maybeToBool maybe_Astk_loc
872 (Just offsetA) = maybe_Astk_loc
874 maybe_Bstk_loc = maybeBStkLoc stable_loc
875 is_Bstk_loc = maybeToBool maybe_Bstk_loc
876 (Just offsetB) = maybe_Bstk_loc
878 _ -> dead_slots live_vars fbs das dbs bs
881 size = (getKindSize . kindFromType . getIdUniType) v
883 -- addFreeSlots expects *both* args to be in increasing order
884 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
885 addFreeASlots = addFreeSlots fst
887 addFreeBSlots :: [Int] -> [Int] -> [Int]
888 addFreeBSlots = addFreeSlots id
890 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
892 addFreeSlots get_offset cs [] = cs
893 addFreeSlots get_offset [] ns = ns
894 addFreeSlots get_offset (c:cs) (n:ns)
895 = if off_c < off_n then
896 (c : addFreeSlots get_offset cs (n:ns))
897 else if off_c > off_n then
898 (n : addFreeSlots get_offset (c:cs) ns)
900 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
905 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
907 trim get_offset current_sp free_slots
908 = try current_sp (reverse free_slots)
910 try csp [] = (csp, [])
912 = if csp < slot_off then
913 try csp slots -- Free slot off top of stk; ignore
915 else if csp == slot_off then
916 try (csp-1) slots -- Free slot at top of stk; trim
919 (csp, reverse (slot:slots)) -- Otherwise gap; give up
921 slot_off = get_offset slot