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
53 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
54 IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
56 import {-# SOURCE #-} CgBindery
57 import {-# SOURCE #-} CgUsages
61 import AbsCUtils ( mkAbsCStmts )
62 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
65 import HeapOffs ( maxOff,
66 SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset),
69 import CLabel ( CLabel )
71 nullIdEnv, mkIdEnv, addOneToIdEnv,
72 modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv),
73 SYN_IE(ConTag), GenId{-instance Outputable-},
76 import Maybes ( maybeToBool )
77 import Outputable ( PprStyle(..), Outputable(..) )
78 import PprType ( GenType{-instance Outputable-} )
79 import Pretty ( Doc, vcat, hsep, ptext )
80 import PrimRep ( getPrimRepSize, PrimRep(..) )
81 import StgSyn ( SYN_IE(StgLiveVars) )
82 import Type ( typePrimRep )
83 import UniqSet ( elementOfUniqSet )
84 import Util ( sortLt, panic, pprPanic )
86 infixr 9 `thenC` -- Right-associative!
90 %************************************************************************
92 \subsection[CgMonad-environment]{Stuff for manipulating environments}
94 %************************************************************************
96 This monadery has some information that it only passes {\em
97 downwards}, as well as some ``state'' which is modified as we go
101 data CgInfoDownwards -- information only passed *downwards* by the monad
103 CompilationInfo -- COMPLETELY STATIC info about this compilation
104 -- (e.g., what flags were passed to the compiler)
106 CgBindings -- [Id -> info] : static environment
108 EndOfBlockInfo -- Info for stuff to do at end of basic block:
113 FAST_STRING -- the module name
117 AbstractC -- code accumulated so far
118 CgBindings -- [Id -> info] : *local* bindings environment
119 -- Bindings for top-level things are given in the info-down part
123 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
124 if the expression is a @case@, what to do at the end of each
130 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
131 -- return; push arguments starting just
132 -- above this point on a tail call.
134 -- This is therefore the A-stk ptr as seen
135 -- by a case alternative.
137 -- Args SpA is used when we want to stub any
138 -- currently-unstubbed dead A-stack (ptr)
139 -- slots; we want to know what SpA in the
140 -- continuation is so that we don't stub any
141 -- slots which are off the top of the
142 -- continuation's stack!
144 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
145 -- Two main differences:
146 -- 1. If Sequel isn't OnStack, then Args SpB points
147 -- just below the slot in which the return address
148 -- should be put. In effect, the Sequel
149 -- is a pending argument. If it is
151 -- points to the top word of the return
154 -- 2. It ain't used for stubbing because there are
158 initEobInfo = EndOfBlockInfo 0 0 InRetReg
161 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
162 that it must survive stack pointer adjustments at the end of the
167 = InRetReg -- The continuation is in RetReg
169 | OnStack VirtualSpBOffset
170 -- Continuation is on the stack, at the
171 -- specified location
173 | UpdateCode CAddrMode -- May be standard update code, or might be
174 -- the data-type-specific one.
177 CAddrMode -- Jump to this; if the continuation is for a vectored
178 -- case this might be the label of a return
179 -- vector Guaranteed to be a non-volatile
180 -- addressing mode (I think)
183 type SemiTaggingStuff
184 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
185 ([(ConTag, JoinDetails)], -- Alternatives
186 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
187 -- Maybe[3] the default is a
188 -- bind-default (Just b); that is,
189 -- it expects a ptr to the thing
190 -- in Node, bound to b
194 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
195 -- and join point label
197 -- The abstract C is executed only from a successful semitagging
198 -- venture, when a case has looked at a variable, found that it's
199 -- evaluated, and wants to load up the contents and go to the join
203 -- The OnStack case of sequelToAmode delivers an Amode which is only
204 -- valid just before the final control transfer, because it assumes
205 -- that SpB is pointing to the top word of the return address. This
206 -- seems unclean but there you go.
208 sequelToAmode :: Sequel -> FCode CAddrMode
210 sequelToAmode (OnStack virt_spb_offset)
211 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
212 returnFC (CVal spb_rel RetRep)
214 sequelToAmode InRetReg = returnFC (CReg RetReg)
215 --Andy/Simon's patch:
216 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
217 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
218 sequelToAmode (CaseAlts amode _) = returnFC amode
221 See the NOTES about the details of stack/heap usage tracking.
224 type CgStksAndHeapUsage -- stacks and heap usage information
225 = (AStackUsage, -- A-stack usage
226 BStackUsage, -- B-stack usage
230 (Int, -- virtSpA: Virtual offset of topmost allocated slot
231 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
232 Int, -- realSpA: Virtual offset of real stack pointer
233 Int) -- hwSpA: Highest value ever taken by virtSp
235 data StubFlag = Stubbed | NotStubbed
237 isStubbed Stubbed = True -- so the type can be abstract
238 isStubbed NotStubbed = False
241 (Int, -- virtSpB: Virtual offset of topmost allocated slot
242 [Int], -- freeB: List of free slots, in increasing order
243 Int, -- realSpB: Virtual offset of real stack pointer
244 Int) -- hwSpB: Highest value ever taken by virtSp
247 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
248 HeapOffset) -- realHp: Virtual offset of real heap ptr
250 NB: absolutely every one of the above Ints is really
251 a VirtualOffset of some description (the code generator
252 works entirely in terms of VirtualOffsets; see NOTES).
257 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
259 initUsage :: CgStksAndHeapUsage
260 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
261 initVirtHp = panic "Uninitialised virtual Hp"
262 initRealHp = panic "Uninitialised real Hp"
265 @envInitForAlternatives@ initialises the environment for a case alternative,
266 assuming that the alternative is entered after an evaluation.
270 zapping any volatile bindings, which aren't valid.
272 zapping the heap usage. It should be restored by a heap check.
274 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
275 this doesn't represent any {\em code}; it is a prediction of where the
276 real stack pointer will be when we come back from the case analysis.
278 BUT LEAVING the rest of the stack-usage info because it is all valid.
279 In particular, we leave the tail stack pointers unchanged, becuase the
280 alternative has to de-allocate the original @case@ expression's stack.
283 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
284 marks found in $e_2$.
287 stateIncUsage :: CgState -> CgState -> CgState
289 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
290 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
293 ((vA,fA,rA,hA1 `max` hA2),
294 (vB,fB,rB,hB1 `max` hB2),
295 (vH1 `maxOff` vH2, rH1))
298 %************************************************************************
300 \subsection[CgMonad-basics]{Basic code-generation monad magic}
302 %************************************************************************
305 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
306 type Code = CgInfoDownwards -> CgState -> CgState
309 {-# INLINE thenFC #-}
310 {-# INLINE returnFC #-}
312 The Abstract~C is not in the environment so as to improve strictness.
315 initC :: CompilationInfo -> Code -> AbstractC
318 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
320 MkCgState abc _ _ -> abc
322 returnFC :: a -> FCode a
324 returnFC val info_down state = (val, state)
329 -> (CgInfoDownwards -> CgState -> a)
330 -> CgInfoDownwards -> CgState -> a
332 -- thenC has both of the following types:
333 -- thenC :: Code -> Code -> Code
334 -- thenC :: Code -> FCode a -> FCode a
336 thenC m k info_down state
337 = k info_down new_state
339 new_state = m info_down state
341 listCs :: [Code] -> Code
343 listCs [] info_down state = state
344 listCs (c:cs) info_down state = stateN
346 state1 = c info_down state
347 stateN = listCs cs info_down state1
349 mapCs :: (a -> Code) -> [a] -> Code
351 mapCs f [] info_down state = state
352 mapCs f (c:cs) info_down state = stateN
354 state1 = (f c) info_down state
355 stateN = mapCs f cs info_down state1
360 -> (a -> CgInfoDownwards -> CgState -> c)
361 -> CgInfoDownwards -> CgState -> c
363 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
364 -- thenFC :: FCode a -> (a -> Code) -> Code
366 thenFC m k info_down state
367 = k m_result info_down new_state
369 (m_result, new_state) = m info_down state
371 listFCs :: [FCode a] -> FCode [a]
373 listFCs [] info_down state = ([], state)
374 listFCs (fc:fcs) info_down state = (thing : things, stateN)
376 (thing, state1) = fc info_down state
377 (things, stateN) = listFCs fcs info_down state1
379 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
381 mapFCs f [] info_down state = ([], state)
382 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
384 (thing, state1) = (f fc) info_down state
385 (things, stateN) = mapFCs f fcs info_down state1
388 And the knot-tying combinator:
390 fixC :: (a -> FCode a) -> FCode a
391 fixC fcode info_down state = result
393 result@(v, _) = fcode v info_down state
397 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
398 fresh environment, except that:
399 - compilation info and statics are passed in unchanged.
400 The current environment is passed on completely unaltered, except that
401 abstract C from the fork is incorporated.
403 @forkAbsC@ takes a code and compiles it in the current environment,
404 returning the abstract C thus constructed. The current environment
405 is passed on completely unchanged. It is pretty similar to @getAbsC@,
406 except that the latter does affect the environment. ToDo: combine?
408 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
409 from the current bindings, but which is otherwise freshly initialised.
410 The Abstract~C returned is attached to the current state, but the
411 bindings and usage information is otherwise unchanged.
414 forkClosureBody :: Code -> Code
417 (MkCgInfoDown cg_info statics _)
418 (MkCgState absC_in binds un_usage)
419 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
421 fork_state = code body_info_down initialStateC
422 MkCgState absC_fork _ _ = fork_state
423 body_info_down = MkCgInfoDown cg_info statics initEobInfo
425 forkStatics :: FCode a -> FCode a
427 forkStatics fcode (MkCgInfoDown cg_info _ _)
428 (MkCgState absC_in statics un_usage)
429 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
431 (result, state) = fcode rhs_info_down initialStateC
432 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
433 -- above or it becomes too strict!
434 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
436 forkAbsC :: Code -> FCode AbstractC
437 forkAbsC code info_down (MkCgState absC1 bs usage)
440 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
441 code info_down (MkCgState AbsCNop bs usage)
442 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
444 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
445 new_state = MkCgState absC1 bs new_usage
448 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
449 an fcode for the default case $d$, and compiles each in the current
450 environment. The current environment is passed on unmodified, except
452 - the worst stack high-water mark is incorporated
453 - the virtual Hp is moved on to the worst virtual Hp for the branches
455 The "extra branches" arise from handling the default case:
461 Here we in effect expand to
465 C2 c -> let z = C2 c in JUMP(default)
466 C3 d e f -> let z = C2 d e f in JUMP(default)
470 The stuff for C2 and C3 are the extra branches. They are
471 handled differently by forkAlts, because their
472 heap usage is joined onto that for the default case.
475 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
477 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
478 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
480 compile fc = fc info_down in_state
482 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
483 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
485 -- The "in_state" for the default branch is got by worst-casing the
486 -- heap usages etc from the "extra_branches"
487 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
488 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
490 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
491 -- NB foldl. in_state is the *left* argument to stateIncUsage
494 @forkEval@ takes two blocks of code.
496 \item The first meddles with the environment to set it up as expected by
497 the alternatives of a @case@ which does an eval (or gc-possible primop).
498 \item The second block is the code for the alternatives.
499 (plus info for semi-tagging purposes)
501 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
502 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
503 the caller to use, together with whatever value is returned by the second block.
505 It uses @initEnvForAlternatives@ to initialise the environment, and
506 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
510 forkEval :: EndOfBlockInfo -- For the body
511 -> Code -- Code to set environment
512 -> FCode Sequel -- Semi-tagging info to store
513 -> FCode EndOfBlockInfo -- The new end of block info
515 forkEval body_eob_info env_code body_code
516 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
517 returnFC (EndOfBlockInfo vA vB sequel)
519 forkEvalHelp :: EndOfBlockInfo -- For the body
520 -> Code -- Code to set environment
521 -> FCode a -- The code to do after the eval
522 -> FCode (Int, -- SpA
524 a) -- Result of the FCode
526 forkEvalHelp body_eob_info env_code body_code
527 info_down@(MkCgInfoDown cg_info statics _) state
528 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
530 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
532 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
533 -- These vA and fA things are now set up as the body code expects them
535 state_at_end_return :: CgState
537 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
539 state_for_body :: CgState
541 state_for_body = MkCgState AbsCNop
542 (nukeVolatileBinds binds)
543 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
544 (vB,fB,vB,vB), -- to virtual ones
545 (initVirtHp, initRealHp))
547 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
548 -- In the branch, all free locations will have been stubbed
551 stateIncUsageEval :: CgState -> CgState -> CgState
552 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
553 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
554 = MkCgState (absC1 `AbsCStmts` absC2)
555 -- The AbsC coming back should consist only of nested declarations,
556 -- notably of the return vector!
558 ((vA,fA,rA,hA1 `max` hA2),
559 (vB,fB,rB,hB1 `max` hB2),
561 -- We don't max the heap high-watermark because stateIncUsageEval is
562 -- used only in forkEval, which in turn is only used for blocks of code
563 -- which do their own heap-check.
566 %************************************************************************
568 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
570 %************************************************************************
572 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
573 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
576 nopC info_down state = state
578 absC :: AbstractC -> Code
579 absC more_absC info_down state@(MkCgState absC binds usage)
580 = MkCgState (mkAbsCStmts absC more_absC) binds usage
583 These two are just like @absC@, except they examine the compilation
584 info (whether SCC profiling or profiling-ctrs going) and possibly emit
588 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
590 costCentresC macro args _ state@(MkCgState absC binds usage)
591 = if opt_SccProfilingOn
592 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
595 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
597 profCtrC macro args _ state@(MkCgState absC binds usage)
598 = if not opt_DoTickyProfiling
600 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
602 {- Try to avoid adding too many special compilation strategies here.
603 It's better to modify the header files as necessary for particular
604 targets, so that we can get away with as few variants of .hc files
605 as possible. 'ForConcurrent' is somewhat special anyway, as it
606 changes entry conventions pretty significantly.
610 @getAbsC@ compiles the code in the current environment, and returns
611 the abstract C thus constructed (leaving the abstract C being carried
612 around in the state untouched). @getAbsC@ does not generate any
613 in-line Abstract~C itself, but the environment it returns is that
614 obtained from the compilation.
617 getAbsC :: Code -> FCode AbstractC
619 getAbsC code info_down (MkCgState absC binds usage)
620 = (absC2, MkCgState absC binds2 usage2)
622 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
626 noBlackHolingFlag, costCentresFlag :: FCode Bool
628 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
629 costCentresFlag _ state = (opt_SccProfilingOn, state)
634 moduleName :: FCode FAST_STRING
635 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
641 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
642 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
643 = code (MkCgInfoDown c_info statics eob_info) state
645 getEndOfBlockInfo :: FCode EndOfBlockInfo
646 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
650 %************************************************************************
652 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
654 %************************************************************************
656 There are three basic routines, for adding (@addBindC@), modifying
657 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
658 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
659 on the end of each function name).
661 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
662 The name should not already be bound. (nice ASSERT, eh?)
664 addBindC :: Id -> CgIdInfo -> Code
665 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
666 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
670 addBindsC :: [(Id, CgIdInfo)] -> Code
671 addBindsC new_bindings info_down (MkCgState absC binds usage)
672 = MkCgState absC new_binds usage
674 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
680 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
681 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
682 = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
685 Lookup is expected to find a binding for the @Id@.
687 lookupBindC :: Id -> FCode CgIdInfo
688 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
689 state@(MkCgState absC local_binds usage)
692 val = case (lookupIdEnv local_binds name) of
693 Nothing -> try_static
696 try_static = case (lookupIdEnv static_binds name) of
699 -> pprPanic "lookupBindC:no info!\n"
701 hsep [ptext SLIT("for:"), ppr PprShowAll name],
702 ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
703 ptext SLIT("static binds for:"),
704 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
705 ptext SLIT("local binds for:"),
706 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
710 %************************************************************************
712 \subsection[CgStackery-deadslots]{Finding dead stack slots}
714 %************************************************************************
716 @nukeDeadBindings@ does the following:
718 \item Removes all bindings from the environment other than those
719 for variables in the argument to @nukeDeadBindings@.
720 \item Collects any stack slots so freed, and returns them to the appropriate
722 \item Moves the virtual stack pointers to point to the topmost used
726 Find dead slots on the stacks *and* remove bindings for dead variables
729 You can have multi-word slots on the B stack; if dead, such a slot
730 will be reported as {\em several} offsets (one per word).
732 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
733 set, so that no stack-stubbing will take place.
735 Probably *naughty* to look inside monad...
738 nukeDeadBindings :: StgLiveVars -- All the *live* variables
743 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
744 (vsp_b, free_b, real_b, hw_b),
746 = MkCgState abs_c (mkIdEnv bs') new_usage
748 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
749 (new_vsp_b, new_free_b, real_b, hw_b),
752 (dead_a_slots, dead_b_slots, bs')
753 = dead_slots live_vars
755 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
757 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
758 extra_free_b = sortLt (<) dead_b_slots
760 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
761 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
763 getUnstubbedAStackSlots
764 :: VirtualSpAOffset -- Ignore slots bigger than this
765 -> FCode [VirtualSpAOffset] -- Return the list of slots found
767 getUnstubbedAStackSlots tail_spa
768 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
769 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
772 Several boring auxiliary functions to do the dirty work.
775 dead_slots :: StgLiveVars
776 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
778 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
780 -- dead_slots carries accumulating parameters for
781 -- filtered bindings, dead a and b slots
782 dead_slots live_vars fbs das dbs []
783 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
785 dead_slots live_vars fbs das dbs ((v,i):bs)
786 | v `elementOfUniqSet` live_vars
787 = dead_slots live_vars ((v,i):fbs) das dbs bs
788 -- Live, so don't record it in dead slots
789 -- Instead keep it in the filtered bindings
793 MkCgIdInfo _ _ stable_loc _
795 dead_slots live_vars fbs (offsetA : das) dbs bs
798 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
800 maybe_Astk_loc = maybeAStkLoc stable_loc
801 is_Astk_loc = maybeToBool maybe_Astk_loc
802 (Just offsetA) = maybe_Astk_loc
804 maybe_Bstk_loc = maybeBStkLoc stable_loc
805 is_Bstk_loc = maybeToBool maybe_Bstk_loc
806 (Just offsetB) = maybe_Bstk_loc
808 _ -> dead_slots live_vars fbs das dbs bs
811 size = (getPrimRepSize . typePrimRep . idType) v
813 -- addFreeSlots expects *both* args to be in increasing order
814 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
815 addFreeASlots = addFreeSlots fst
817 addFreeBSlots :: [Int] -> [Int] -> [Int]
818 addFreeBSlots = addFreeSlots id
820 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
822 addFreeSlots get_offset cs [] = cs
823 addFreeSlots get_offset [] ns = ns
824 addFreeSlots get_offset (c:cs) (n:ns)
825 = if off_c < off_n then
826 (c : addFreeSlots get_offset cs (n:ns))
827 else if off_c > off_n then
828 (n : addFreeSlots get_offset (c:cs) ns)
830 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
835 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
837 trim get_offset current_sp free_slots
838 = try current_sp (reverse free_slots)
840 try csp [] = (csp, [])
842 = if csp < slot_off then
843 try csp slots -- Free slot off top of stk; ignore
845 else if csp == slot_off then
846 try (csp-1) slots -- Free slot at top of stk; trim
849 (csp, reverse (slot:slots)) -- Otherwise gap; give up
851 slot_off = get_offset slot