2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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"
14 SYN_IE(FCode), -- type
16 initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
17 returnFC, fixC, absC, nopC, getAbsC,
19 forkClosureBody, forkStatics, forkAlts, forkEval,
20 forkEvalHelp, forkAbsC,
21 SYN_IE(SemiTaggingStuff),
23 addBindC, addBindsC, modifyBindC, lookupBindC,
26 setEndOfBlockInfo, getEndOfBlockInfo,
28 SYN_IE(AStackUsage), SYN_IE(BStackUsage), SYN_IE(HeapUsage),
32 nukeDeadBindings, getUnstubbedAStackSlots,
34 -- addFreeASlots, -- no need to export it
35 addFreeBSlots, -- ToDo: Belong elsewhere
40 costCentresC, costCentresFlag, moduleName,
42 Sequel(..), -- ToDo: unabstract?
45 -- out of general friendliness, we also export ...
46 CgInfoDownwards(..), CgState(..), -- non-abstract
51 IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
55 import AbsCUtils ( mkAbsCStmts )
56 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
59 import HeapOffs ( maxOff,
60 SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
63 import CLabel ( CLabel )
65 nullIdEnv, mkIdEnv, addOneToIdEnv,
66 modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv),
67 SYN_IE(ConTag), GenId{-instance Outputable-},
70 import Maybes ( maybeToBool )
71 import Outputable ( PprStyle(..), Outputable(..) )
72 import PprType ( GenType{-instance Outputable-} )
73 import Pretty ( Doc, vcat, hsep, ptext )
74 import PrimRep ( getPrimRepSize, PrimRep(..) )
75 import StgSyn ( SYN_IE(StgLiveVars) )
76 import Type ( typePrimRep )
77 import UniqSet ( elementOfUniqSet )
78 import Util ( sortLt, panic, pprPanic )
80 infixr 9 `thenC` -- Right-associative!
84 %************************************************************************
86 \subsection[CgMonad-environment]{Stuff for manipulating environments}
88 %************************************************************************
90 This monadery has some information that it only passes {\em
91 downwards}, as well as some ``state'' which is modified as we go
95 data CgInfoDownwards -- information only passed *downwards* by the monad
97 CompilationInfo -- COMPLETELY STATIC info about this compilation
98 -- (e.g., what flags were passed to the compiler)
100 CgBindings -- [Id -> info] : static environment
102 EndOfBlockInfo -- Info for stuff to do at end of basic block:
107 FAST_STRING -- the module name
111 AbstractC -- code accumulated so far
112 CgBindings -- [Id -> info] : *local* bindings environment
113 -- Bindings for top-level things are given in the info-down part
117 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
118 if the expression is a @case@, what to do at the end of each
124 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
125 -- return; push arguments starting just
126 -- above this point on a tail call.
128 -- This is therefore the A-stk ptr as seen
129 -- by a case alternative.
131 -- Args SpA is used when we want to stub any
132 -- currently-unstubbed dead A-stack (ptr)
133 -- slots; we want to know what SpA in the
134 -- continuation is so that we don't stub any
135 -- slots which are off the top of the
136 -- continuation's stack!
138 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
139 -- Two main differences:
140 -- 1. If Sequel isn't OnStack, then Args SpB points
141 -- just below the slot in which the return address
142 -- should be put. In effect, the Sequel
143 -- is a pending argument. If it is
145 -- points to the top word of the return
148 -- 2. It ain't used for stubbing because there are
152 initEobInfo = EndOfBlockInfo 0 0 InRetReg
155 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
156 that it must survive stack pointer adjustments at the end of the
161 = InRetReg -- The continuation is in RetReg
163 | OnStack VirtualSpBOffset
164 -- Continuation is on the stack, at the
165 -- specified location
167 | UpdateCode CAddrMode -- May be standard update code, or might be
168 -- the data-type-specific one.
171 CAddrMode -- Jump to this; if the continuation is for a vectored
172 -- case this might be the label of a return
173 -- vector Guaranteed to be a non-volatile
174 -- addressing mode (I think)
177 type SemiTaggingStuff
178 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
179 ([(ConTag, JoinDetails)], -- Alternatives
180 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
181 -- Maybe[3] the default is a
182 -- bind-default (Just b); that is,
183 -- it expects a ptr to the thing
184 -- in Node, bound to b
188 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
189 -- and join point label
191 -- The abstract C is executed only from a successful semitagging
192 -- venture, when a case has looked at a variable, found that it's
193 -- evaluated, and wants to load up the contents and go to the join
197 -- The OnStack case of sequelToAmode delivers an Amode which is only
198 -- valid just before the final control transfer, because it assumes
199 -- that SpB is pointing to the top word of the return address. This
200 -- seems unclean but there you go.
202 sequelToAmode :: Sequel -> FCode CAddrMode
204 sequelToAmode (OnStack virt_spb_offset)
205 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
206 returnFC (CVal spb_rel RetRep)
208 sequelToAmode InRetReg = returnFC (CReg RetReg)
209 --Andy/Simon's patch:
210 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
211 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
212 sequelToAmode (CaseAlts amode _) = returnFC amode
215 See the NOTES about the details of stack/heap usage tracking.
218 type CgStksAndHeapUsage -- stacks and heap usage information
219 = (AStackUsage, -- A-stack usage
220 BStackUsage, -- B-stack usage
224 (Int, -- virtSpA: Virtual offset of topmost allocated slot
225 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
226 Int, -- realSpA: Virtual offset of real stack pointer
227 Int) -- hwSpA: Highest value ever taken by virtSp
229 data StubFlag = Stubbed | NotStubbed
231 isStubbed Stubbed = True -- so the type can be abstract
232 isStubbed NotStubbed = False
235 (Int, -- virtSpB: Virtual offset of topmost allocated slot
236 [Int], -- freeB: List of free slots, in increasing order
237 Int, -- realSpB: Virtual offset of real stack pointer
238 Int) -- hwSpB: Highest value ever taken by virtSp
241 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
242 HeapOffset) -- realHp: Virtual offset of real heap ptr
244 NB: absolutely every one of the above Ints is really
245 a VirtualOffset of some description (the code generator
246 works entirely in terms of VirtualOffsets; see NOTES).
251 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
253 initUsage :: CgStksAndHeapUsage
254 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
255 initVirtHp = panic "Uninitialised virtual Hp"
256 initRealHp = panic "Uninitialised real Hp"
259 @envInitForAlternatives@ initialises the environment for a case alternative,
260 assuming that the alternative is entered after an evaluation.
264 zapping any volatile bindings, which aren't valid.
266 zapping the heap usage. It should be restored by a heap check.
268 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
269 this doesn't represent any {\em code}; it is a prediction of where the
270 real stack pointer will be when we come back from the case analysis.
272 BUT LEAVING the rest of the stack-usage info because it is all valid.
273 In particular, we leave the tail stack pointers unchanged, becuase the
274 alternative has to de-allocate the original @case@ expression's stack.
277 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
278 marks found in $e_2$.
281 stateIncUsage :: CgState -> CgState -> CgState
283 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
284 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
287 ((vA,fA,rA,hA1 `max` hA2),
288 (vB,fB,rB,hB1 `max` hB2),
289 (vH1 `maxOff` vH2, rH1))
292 %************************************************************************
294 \subsection[CgMonad-basics]{Basic code-generation monad magic}
296 %************************************************************************
299 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
300 type Code = CgInfoDownwards -> CgState -> CgState
303 {-# INLINE thenFC #-}
304 {-# INLINE returnFC #-}
306 The Abstract~C is not in the environment so as to improve strictness.
309 initC :: CompilationInfo -> Code -> AbstractC
312 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
314 MkCgState abc _ _ -> abc
316 returnFC :: a -> FCode a
318 returnFC val info_down state = (val, state)
323 -> (CgInfoDownwards -> CgState -> a)
324 -> CgInfoDownwards -> CgState -> a
326 -- thenC has both of the following types:
327 -- thenC :: Code -> Code -> Code
328 -- thenC :: Code -> FCode a -> FCode a
330 thenC m k info_down state
331 = k info_down new_state
333 new_state = m info_down state
335 listCs :: [Code] -> Code
337 listCs [] info_down state = state
338 listCs (c:cs) info_down state = stateN
340 state1 = c info_down state
341 stateN = listCs cs info_down state1
343 mapCs :: (a -> Code) -> [a] -> Code
345 mapCs f [] info_down state = state
346 mapCs f (c:cs) info_down state = stateN
348 state1 = (f c) info_down state
349 stateN = mapCs f cs info_down state1
354 -> (a -> CgInfoDownwards -> CgState -> c)
355 -> CgInfoDownwards -> CgState -> c
357 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
358 -- thenFC :: FCode a -> (a -> Code) -> Code
360 thenFC m k info_down state
361 = k m_result info_down new_state
363 (m_result, new_state) = m info_down state
365 listFCs :: [FCode a] -> FCode [a]
367 listFCs [] info_down state = ([], state)
368 listFCs (fc:fcs) info_down state = (thing : things, stateN)
370 (thing, state1) = fc info_down state
371 (things, stateN) = listFCs fcs info_down state1
373 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
375 mapFCs f [] info_down state = ([], state)
376 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
378 (thing, state1) = (f fc) info_down state
379 (things, stateN) = mapFCs f fcs info_down state1
382 And the knot-tying combinator:
384 fixC :: (a -> FCode a) -> FCode a
385 fixC fcode info_down state = result
387 result@(v, _) = fcode v info_down state
391 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
392 fresh environment, except that:
393 - compilation info and statics are passed in unchanged.
394 The current environment is passed on completely unaltered, except that
395 abstract C from the fork is incorporated.
397 @forkAbsC@ takes a code and compiles it in the current environment,
398 returning the abstract C thus constructed. The current environment
399 is passed on completely unchanged. It is pretty similar to @getAbsC@,
400 except that the latter does affect the environment. ToDo: combine?
402 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
403 from the current bindings, but which is otherwise freshly initialised.
404 The Abstract~C returned is attached to the current state, but the
405 bindings and usage information is otherwise unchanged.
408 forkClosureBody :: Code -> Code
411 (MkCgInfoDown cg_info statics _)
412 (MkCgState absC_in binds un_usage)
413 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
415 fork_state = code body_info_down initialStateC
416 MkCgState absC_fork _ _ = fork_state
417 body_info_down = MkCgInfoDown cg_info statics initEobInfo
419 forkStatics :: FCode a -> FCode a
421 forkStatics fcode (MkCgInfoDown cg_info _ _)
422 (MkCgState absC_in statics un_usage)
423 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
425 (result, state) = fcode rhs_info_down initialStateC
426 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
427 -- above or it becomes too strict!
428 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
430 forkAbsC :: Code -> FCode AbstractC
431 forkAbsC code info_down (MkCgState absC1 bs usage)
434 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
435 code info_down (MkCgState AbsCNop bs usage)
436 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
438 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
439 new_state = MkCgState absC1 bs new_usage
442 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
443 an fcode for the default case $d$, and compiles each in the current
444 environment. The current environment is passed on unmodified, except
446 - the worst stack high-water mark is incorporated
447 - the virtual Hp is moved on to the worst virtual Hp for the branches
449 The "extra branches" arise from handling the default case:
455 Here we in effect expand to
459 C2 c -> let z = C2 c in JUMP(default)
460 C3 d e f -> let z = C2 d e f in JUMP(default)
464 The stuff for C2 and C3 are the extra branches. They are
465 handled differently by forkAlts, because their
466 heap usage is joined onto that for the default case.
469 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
471 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
472 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
474 compile fc = fc info_down in_state
476 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
477 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
479 -- The "in_state" for the default branch is got by worst-casing the
480 -- heap usages etc from the "extra_branches"
481 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
482 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
484 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
485 -- NB foldl. in_state is the *left* argument to stateIncUsage
488 @forkEval@ takes two blocks of code.
490 \item The first meddles with the environment to set it up as expected by
491 the alternatives of a @case@ which does an eval (or gc-possible primop).
492 \item The second block is the code for the alternatives.
493 (plus info for semi-tagging purposes)
495 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
496 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
497 the caller to use, together with whatever value is returned by the second block.
499 It uses @initEnvForAlternatives@ to initialise the environment, and
500 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
504 forkEval :: EndOfBlockInfo -- For the body
505 -> Code -- Code to set environment
506 -> FCode Sequel -- Semi-tagging info to store
507 -> FCode EndOfBlockInfo -- The new end of block info
509 forkEval body_eob_info env_code body_code
510 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
511 returnFC (EndOfBlockInfo vA vB sequel)
513 forkEvalHelp :: EndOfBlockInfo -- For the body
514 -> Code -- Code to set environment
515 -> FCode a -- The code to do after the eval
516 -> FCode (Int, -- SpA
518 a) -- Result of the FCode
520 forkEvalHelp body_eob_info env_code body_code
521 info_down@(MkCgInfoDown cg_info statics _) state
522 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
524 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
526 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
527 -- These vA and fA things are now set up as the body code expects them
529 state_at_end_return :: CgState
531 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
533 state_for_body :: CgState
535 state_for_body = MkCgState AbsCNop
536 (nukeVolatileBinds binds)
537 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
538 (vB,fB,vB,vB), -- to virtual ones
539 (initVirtHp, initRealHp))
541 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
542 -- In the branch, all free locations will have been stubbed
545 stateIncUsageEval :: CgState -> CgState -> CgState
546 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
547 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
548 = MkCgState (absC1 `AbsCStmts` absC2)
549 -- The AbsC coming back should consist only of nested declarations,
550 -- notably of the return vector!
552 ((vA,fA,rA,hA1 `max` hA2),
553 (vB,fB,rB,hB1 `max` hB2),
555 -- We don't max the heap high-watermark because stateIncUsageEval is
556 -- used only in forkEval, which in turn is only used for blocks of code
557 -- which do their own heap-check.
560 %************************************************************************
562 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
564 %************************************************************************
566 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
567 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
570 nopC info_down state = state
572 absC :: AbstractC -> Code
573 absC more_absC info_down state@(MkCgState absC binds usage)
574 = MkCgState (mkAbsCStmts absC more_absC) binds usage
577 These two are just like @absC@, except they examine the compilation
578 info (whether SCC profiling or profiling-ctrs going) and possibly emit
582 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
584 costCentresC macro args _ state@(MkCgState absC binds usage)
585 = if opt_SccProfilingOn
586 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
589 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
591 profCtrC macro args _ state@(MkCgState absC binds usage)
592 = if not opt_DoTickyProfiling
594 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
596 {- Try to avoid adding too many special compilation strategies here.
597 It's better to modify the header files as necessary for particular
598 targets, so that we can get away with as few variants of .hc files
599 as possible. 'ForConcurrent' is somewhat special anyway, as it
600 changes entry conventions pretty significantly.
604 @getAbsC@ compiles the code in the current environment, and returns
605 the abstract C thus constructed (leaving the abstract C being carried
606 around in the state untouched). @getAbsC@ does not generate any
607 in-line Abstract~C itself, but the environment it returns is that
608 obtained from the compilation.
611 getAbsC :: Code -> FCode AbstractC
613 getAbsC code info_down (MkCgState absC binds usage)
614 = (absC2, MkCgState absC binds2 usage2)
616 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
620 noBlackHolingFlag, costCentresFlag :: FCode Bool
622 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
623 costCentresFlag _ state = (opt_SccProfilingOn, state)
628 moduleName :: FCode FAST_STRING
629 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
635 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
636 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
637 = code (MkCgInfoDown c_info statics eob_info) state
639 getEndOfBlockInfo :: FCode EndOfBlockInfo
640 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
644 %************************************************************************
646 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
648 %************************************************************************
650 There are three basic routines, for adding (@addBindC@), modifying
651 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
652 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
653 on the end of each function name).
655 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
656 The name should not already be bound. (nice ASSERT, eh?)
658 addBindC :: Id -> CgIdInfo -> Code
659 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
660 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
664 addBindsC :: [(Id, CgIdInfo)] -> Code
665 addBindsC new_bindings info_down (MkCgState absC binds usage)
666 = MkCgState absC new_binds usage
668 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
674 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
675 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
676 = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
679 Lookup is expected to find a binding for the @Id@.
681 lookupBindC :: Id -> FCode CgIdInfo
682 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
683 state@(MkCgState absC local_binds usage)
686 val = case (lookupIdEnv local_binds name) of
687 Nothing -> try_static
690 try_static = case (lookupIdEnv static_binds name) of
693 -> pprPanic "lookupBindC:no info!\n"
695 hsep [ptext SLIT("for:"), ppr PprShowAll name],
696 ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
697 ptext SLIT("static binds for:"),
698 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
699 ptext SLIT("local binds for:"),
700 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
704 %************************************************************************
706 \subsection[CgStackery-deadslots]{Finding dead stack slots}
708 %************************************************************************
710 @nukeDeadBindings@ does the following:
712 \item Removes all bindings from the environment other than those
713 for variables in the argument to @nukeDeadBindings@.
714 \item Collects any stack slots so freed, and returns them to the appropriate
716 \item Moves the virtual stack pointers to point to the topmost used
720 Find dead slots on the stacks *and* remove bindings for dead variables
723 You can have multi-word slots on the B stack; if dead, such a slot
724 will be reported as {\em several} offsets (one per word).
726 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
727 set, so that no stack-stubbing will take place.
729 Probably *naughty* to look inside monad...
732 nukeDeadBindings :: StgLiveVars -- All the *live* variables
737 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
738 (vsp_b, free_b, real_b, hw_b),
740 = MkCgState abs_c (mkIdEnv bs') new_usage
742 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
743 (new_vsp_b, new_free_b, real_b, hw_b),
746 (dead_a_slots, dead_b_slots, bs')
747 = dead_slots live_vars
749 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
751 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
752 extra_free_b = sortLt (<) dead_b_slots
754 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
755 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
757 getUnstubbedAStackSlots
758 :: VirtualSpAOffset -- Ignore slots bigger than this
759 -> FCode [VirtualSpAOffset] -- Return the list of slots found
761 getUnstubbedAStackSlots tail_spa
762 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
763 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
766 Several boring auxiliary functions to do the dirty work.
769 dead_slots :: StgLiveVars
770 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
772 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
774 -- dead_slots carries accumulating parameters for
775 -- filtered bindings, dead a and b slots
776 dead_slots live_vars fbs das dbs []
777 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
779 dead_slots live_vars fbs das dbs ((v,i):bs)
780 | v `elementOfUniqSet` live_vars
781 = dead_slots live_vars ((v,i):fbs) das dbs bs
782 -- Live, so don't record it in dead slots
783 -- Instead keep it in the filtered bindings
787 MkCgIdInfo _ _ stable_loc _
789 dead_slots live_vars fbs (offsetA : das) dbs bs
792 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
794 maybe_Astk_loc = maybeAStkLoc stable_loc
795 is_Astk_loc = maybeToBool maybe_Astk_loc
796 (Just offsetA) = maybe_Astk_loc
798 maybe_Bstk_loc = maybeBStkLoc stable_loc
799 is_Bstk_loc = maybeToBool maybe_Bstk_loc
800 (Just offsetB) = maybe_Bstk_loc
802 _ -> dead_slots live_vars fbs das dbs bs
805 size = (getPrimRepSize . typePrimRep . idType) v
807 -- addFreeSlots expects *both* args to be in increasing order
808 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
809 addFreeASlots = addFreeSlots fst
811 addFreeBSlots :: [Int] -> [Int] -> [Int]
812 addFreeBSlots = addFreeSlots id
814 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
816 addFreeSlots get_offset cs [] = cs
817 addFreeSlots get_offset [] ns = ns
818 addFreeSlots get_offset (c:cs) (n:ns)
819 = if off_c < off_n then
820 (c : addFreeSlots get_offset cs (n:ns))
821 else if off_c > off_n then
822 (n : addFreeSlots get_offset (c:cs) ns)
824 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
829 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
831 trim get_offset current_sp free_slots
832 = try current_sp (reverse free_slots)
834 try csp [] = (csp, [])
836 = if csp < slot_off then
837 try csp slots -- Free slot off top of stk; ignore
839 else if csp == slot_off then
840 try (csp-1) slots -- Free slot at top of stk; trim
843 (csp, reverse (slot:slots)) -- Otherwise gap; give up
845 slot_off = get_offset slot