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,
26 setEndOfBlockInfo, getEndOfBlockInfo,
28 AStackUsage(..), BStackUsage(..), HeapUsage(..),
32 nukeDeadBindings, getUnstubbedAStackSlots,
34 -- addFreeASlots, -- no need to export it
35 addFreeBSlots, -- ToDo: Belong elsewhere
37 isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
42 costCentresC, costCentresFlag, moduleName,
44 Sequel(..), -- ToDo: unabstract?
47 -- out of general friendliness, we also export ...
49 CgInfoDownwards(..), CgState(..), -- non-abstract
51 CompilationInfo(..), IntSwitchChecker(..),
53 stableAmodeIdInfo, heapIdInfo
55 -- and to make the interface self-sufficient...
59 import Type ( primRepFromType, Type
60 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
63 import CgUsages ( getSpBRelOffset )
64 import CmdLineOpts ( GlobalSwitch(..) )
65 import Id ( idType, ConTag(..), DataCon(..) )
66 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
67 import Pretty -- debugging only?
68 import PrimRep ( getPrimRepSize, retPrimRepSize )
69 import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
70 import CostCentre -- profiling stuff
71 import StgSyn ( StgArg(..), StgLiveVars(..) )
74 infixr 9 `thenC` -- Right-associative!
78 %************************************************************************
80 \subsection[CgMonad-environment]{Stuff for manipulating environments}
82 %************************************************************************
84 This monadery has some information that it only passes {\em
85 downwards}, as well as some ``state'' which is modified as we go
89 data CgInfoDownwards -- information only passed *downwards* by the monad
91 CompilationInfo -- COMPLETELY STATIC info about this compilation
92 -- (e.g., what flags were passed to the compiler)
94 CgBindings -- [Id -> info] : static environment
96 EndOfBlockInfo -- Info for stuff to do at end of basic block:
101 FAST_STRING -- 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
112 or, if the expression is a @case@, what to do at the end of each alternative.
117 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
118 -- push arguments starting just above this point on
121 -- This is therefore the A-stk ptr as seen
122 -- by a case alternative.
124 -- Args SpA is used when we want to stub any
125 -- currently-unstubbed dead A-stack (ptr) slots;
126 -- we want to know what SpA in the continuation is
127 -- so that we don't stub any slots which are off the
128 -- top of the continuation's stack!
130 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
132 -- Two main differences:
133 -- 1. If Sequel isn't OnStack, then Args SpB points
134 -- just below the slot in which the return address
135 -- should be put. In effect, the Sequel is
136 -- a pending argument. If it is OnStack, Args SpB
137 -- points to the top word of the return address.
139 -- 2. It ain't used for stubbing because there are
145 initEobInfo = EndOfBlockInfo 0 0 InRetReg
150 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
151 that it must survive stack pointer adjustments at the end of the
156 = InRetReg -- The continuation is in RetReg
158 | OnStack VirtualSpBOffset
159 -- Continuation is on the stack, at the
160 -- specified location
162 | UpdateCode CAddrMode -- May be standard update code, or might be
163 -- the data-type-specific one.
166 CAddrMode -- Jump to this; if the continuation is for a vectored
167 -- case this might be the label of a return vector
168 -- Guaranteed to be a non-volatile addressing mode (I think)
172 type SemiTaggingStuff
173 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
174 ([(ConTag, JoinDetails)], -- Alternatives
175 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
176 -- Maybe[3] the default is a
177 -- bind-default (Just b); that is,
178 -- it expects a ptr to the thing
179 -- in Node, bound to b
183 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
184 -- and join point label
185 -- The abstract C is executed only from a successful
186 -- semitagging venture, when a case has looked at a variable, found
187 -- that it's evaluated, and wants to load up the contents and go to the
192 -- The OnStack case of sequelToAmode delivers an Amode which is only valid
193 -- just before the final control transfer, because it assumes that
194 -- SpB is pointing to the top word of the return address.
195 -- This seems unclean but there you go.
197 sequelToAmode :: Sequel -> FCode CAddrMode
199 sequelToAmode (OnStack virt_spb_offset)
200 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
201 returnFC (CVal spb_rel RetRep)
203 sequelToAmode InRetReg = returnFC (CReg RetReg)
204 --Andy/Simon's patch:
205 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
206 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
207 sequelToAmode (CaseAlts amode _) = returnFC amode
210 See the NOTES about the details of stack/heap usage tracking.
213 type CgStksAndHeapUsage -- stacks and heap usage information
214 = (AStackUsage, -- A-stack usage
215 BStackUsage, -- B-stack usage
219 (Int, -- virtSpA: Virtual offset of topmost allocated slot
220 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
221 Int, -- realSpA: Virtual offset of real stack pointer
222 Int) -- hwSpA: Highest value ever taken by virtSp
224 data StubFlag = Stubbed | NotStubbed
226 isStubbed Stubbed = True -- so the type can be abstract
227 isStubbed NotStubbed = False
230 (Int, -- virtSpB: Virtual offset of topmost allocated slot
231 [Int], -- freeB: List of free slots, in increasing order
232 Int, -- realSpB: Virtual offset of real stack pointer
233 Int) -- hwSpB: Highest value ever taken by virtSp
236 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
237 HeapOffset) -- realHp: Virtual offset of real heap ptr
239 NB: absolutely every one of the above Ints is really
240 a VirtualOffset of some description (the code generator
241 works entirely in terms of VirtualOffsets; see NOTES).
246 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
248 initUsage :: CgStksAndHeapUsage
249 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
250 initVirtHp = panic "Uninitialised virtual Hp"
251 initRealHp = panic "Uninitialised real Hp"
254 @envInitForAlternatives@ initialises the environment for a case alternative,
255 assuming that the alternative is entered after an evaluation.
259 zapping any volatile bindings, which aren't valid.
261 zapping the heap usage. It should be restored by a heap check.
263 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
264 this doesn't represent any {\em code}; it is a prediction of where the
265 real stack pointer will be when we come back from the case analysis.
267 BUT LEAVING the rest of the stack-usage info because it is all valid.
268 In particular, we leave the tail stack pointers unchanged, becuase the
269 alternative has to de-allocate the original @case@ expression's stack.
272 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
273 marks found in $e_2$.
276 stateIncUsage :: CgState -> CgState -> CgState
278 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
279 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
282 ((vA,fA,rA,hA1 `max` hA2),
283 (vB,fB,rB,hB1 `max` hB2),
284 (vH1 `maxOff` vH2, rH1))
287 %************************************************************************
289 \subsection[CgMonad-basics]{Basic code-generation monad magic}
291 %************************************************************************
294 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
295 type Code = CgInfoDownwards -> CgState -> CgState
298 {-# INLINE thenFC #-}
299 {-# INLINE returnFC #-}
301 The Abstract~C is not in the environment so as to improve strictness.
304 initC :: CompilationInfo -> Code -> AbstractC
307 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
309 MkCgState abc _ _ -> abc
311 returnFC :: a -> FCode a
313 returnFC val info_down state = (val, state)
318 -> (CgInfoDownwards -> CgState -> a)
319 -> CgInfoDownwards -> CgState -> a
321 -- thenC has both of the following types:
322 -- thenC :: Code -> Code -> Code
323 -- thenC :: Code -> FCode a -> FCode a
325 (m `thenC` k) info_down state
326 = k info_down new_state
328 new_state = m info_down state
330 listCs :: [Code] -> Code
332 listCs [] info_down state = state
333 listCs (c:cs) info_down state = stateN
335 state1 = c info_down state
336 stateN = listCs cs info_down state1
338 mapCs :: (a -> Code) -> [a] -> Code
340 mapCs f [] info_down state = state
341 mapCs f (c:cs) info_down state = stateN
343 state1 = (f c) info_down state
344 stateN = mapCs f cs info_down state1
349 -> (a -> CgInfoDownwards -> CgState -> c)
350 -> CgInfoDownwards -> CgState -> c
352 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
353 -- thenFC :: FCode a -> (a -> Code) -> Code
355 (m `thenFC` k) info_down state
356 = k m_result info_down new_state
358 (m_result, new_state) = m info_down state
360 listFCs :: [FCode a] -> FCode [a]
362 listFCs [] info_down state = ([], state)
363 listFCs (fc:fcs) info_down state = (thing : things, stateN)
365 (thing, state1) = fc info_down state
366 (things, stateN) = listFCs fcs info_down state1
368 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
370 mapFCs f [] info_down state = ([], state)
371 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
373 (thing, state1) = (f fc) info_down state
374 (things, stateN) = mapFCs f fcs info_down state1
377 And the knot-tying combinator:
379 fixC :: (a -> FCode a) -> FCode a
380 fixC fcode info_down state = result
382 result@(v, _) = fcode v 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
406 (MkCgInfoDown cg_info statics _)
407 (MkCgState absC_in binds un_usage)
408 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
410 fork_state = code body_info_down initialStateC
411 MkCgState absC_fork _ _ = fork_state
412 body_info_down = MkCgInfoDown cg_info statics initEobInfo
414 forkStatics :: FCode a -> FCode a
416 forkStatics fcode (MkCgInfoDown cg_info _ _)
417 (MkCgState absC_in statics un_usage)
418 = (result, MkCgState (AbsCStmts absC_in absC_fork) 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 initEobInfo
425 forkAbsC :: Code -> FCode AbstractC
426 forkAbsC code info_down (MkCgState absC1 bs usage)
429 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
430 code info_down (MkCgState AbsCNop bs usage)
431 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
433 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
434 new_state = MkCgState absC1 bs new_usage
437 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
438 an fcode for the default case $d$, and compiles each in the current
439 environment. The current environment is passed on unmodified, except
441 - the worst stack high-water mark is incorporated
442 - the virtual Hp is moved on to the worst virtual Hp for the branches
444 The "extra branches" arise from handling the default case:
450 Here we in effect expand to
454 C2 c -> let z = C2 c in JUMP(default)
455 C3 d e f -> let z = C2 d e f in JUMP(default)
459 The stuff for C2 and C3 are the extra branches. They are
460 handled differently by forkAlts, because their
461 heap usage is joined onto that for the default case.
464 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
466 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
467 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
469 compile fc = fc info_down in_state
471 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
472 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
474 -- The "in_state" for the default branch is got by worst-casing the
475 -- heap usages etc from the "extra_branches"
476 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
477 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
479 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
480 -- NB foldl. in_state is the *left* argument to stateIncUsage
483 @forkEval@ takes two blocks of code.
485 \item The first meddles with the environment to set it up as expected by
486 the alternatives of a @case@ which does an eval (or gc-possible primop).
487 \item The second block is the code for the alternatives.
488 (plus info for semi-tagging purposes)
490 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
491 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
492 the caller to use, together with whatever value is returned by the second block.
494 It uses @initEnvForAlternatives@ to initialise the environment, and
495 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
499 forkEval :: EndOfBlockInfo -- For the body
500 -> Code -- Code to set environment
501 -> FCode Sequel -- Semi-tagging info to store
502 -> FCode EndOfBlockInfo -- The new end of block info
504 forkEval body_eob_info env_code body_code
505 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
506 returnFC (EndOfBlockInfo vA vB sequel)
508 forkEvalHelp :: EndOfBlockInfo -- For the body
509 -> Code -- Code to set environment
510 -> FCode a -- The code to do after the eval
511 -> FCode (Int, -- SpA
513 a) -- Result of the FCode
515 forkEvalHelp body_eob_info env_code body_code
516 info_down@(MkCgInfoDown cg_info statics _) state
517 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
519 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
521 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
522 -- These vA and fA things are now set up as the body code expects them
524 state_at_end_return :: CgState
526 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
528 state_for_body :: CgState
530 state_for_body = MkCgState AbsCNop
531 (nukeVolatileBinds binds)
532 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
533 (vB,fB,vB,vB), -- to virtual ones
534 (initVirtHp, initRealHp))
536 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
537 -- In the branch, all free locations will have been stubbed
540 stateIncUsageEval :: CgState -> CgState -> CgState
541 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
542 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
543 = MkCgState (absC1 `AbsCStmts` absC2)
544 -- The AbsC coming back should consist only of nested declarations,
545 -- notably of the return vector!
547 ((vA,fA,rA,hA1 `max` hA2),
548 (vB,fB,rB,hB1 `max` hB2),
550 -- We don't max the heap high-watermark because stateIncUsageEval is
551 -- used only in forkEval, which in turn is only used for blocks of code
552 -- which do their own heap-check.
555 %************************************************************************
557 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
559 %************************************************************************
561 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
562 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
565 nopC info_down state = state
567 absC :: AbstractC -> Code
568 absC more_absC info_down state@(MkCgState absC binds usage)
569 = MkCgState (mkAbsCStmts absC more_absC) binds usage
572 These two are just like @absC@, except they examine the compilation
573 info (whether SCC profiling or profiling-ctrs going) and possibly emit
577 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
579 costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
580 state@(MkCgState absC binds usage)
581 = if sw_chkr SccProfilingOn
582 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
585 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
587 profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
588 state@(MkCgState absC binds usage)
589 = if not (sw_chkr DoTickyProfiling)
591 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
593 {- Try to avoid adding too many special compilation strategies here.
594 It's better to modify the header files as necessary for particular
595 targets, so that we can get away with as few variants of .hc files
596 as possible. 'ForConcurrent' is somewhat special anyway, as it
597 changes entry conventions pretty significantly.
601 @getAbsC@ compiles the code in the current environment, and returns
602 the abstract C thus constructed (leaving the abstract C being carried
603 around in the state untouched). @getAbsC@ does not generate any
604 in-line Abstract~C itself, but the environment it returns is that
605 obtained from the compilation.
608 getAbsC :: Code -> FCode AbstractC
610 getAbsC code info_down (MkCgState absC binds usage)
611 = (absC2, MkCgState absC binds2 usage2)
613 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
617 noBlackHolingFlag, costCentresFlag :: FCode Bool
619 noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
620 = (sw_chkr OmitBlackHoling, state)
622 costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
623 = (sw_chkr 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.
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 binds mangle_fn 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 ppCat [ppStr "for:", ppr PprShowAll name],
696 ppStr "(probably: data dependencies broken by an optimisation pass)",
697 ppStr "static binds for:",
698 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
699 ppStr "local binds for:",
700 ppAboves [ 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 . primRepFromType . 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