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"
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
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
54 import AbsCUtils ( mkAbsCStmts )
55 import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
58 import HeapOffs ( maxOff,
59 VirtualSpAOffset(..), VirtualSpBOffset(..)
62 nullIdEnv, mkIdEnv, addOneToIdEnv,
63 modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..),
64 ConTag(..), GenId{-instance Outputable-}
66 import Maybes ( maybeToBool )
67 import PprStyle ( PprStyle(..) )
68 import PprType ( GenType{-instance Outputable-} )
69 import Pretty ( ppAboves, ppCat, ppStr )
70 import PrimRep ( getPrimRepSize, PrimRep(..) )
71 import StgSyn ( StgLiveVars(..) )
72 import Type ( typePrimRep )
73 import UniqSet ( elementOfUniqSet )
74 import Util ( sortLt, panic, pprPanic )
76 infixr 9 `thenC` -- Right-associative!
80 %************************************************************************
82 \subsection[CgMonad-environment]{Stuff for manipulating environments}
84 %************************************************************************
86 This monadery has some information that it only passes {\em
87 downwards}, as well as some ``state'' which is modified as we go
91 data CgInfoDownwards -- information only passed *downwards* by the monad
93 CompilationInfo -- COMPLETELY STATIC info about this compilation
94 -- (e.g., what flags were passed to the compiler)
96 CgBindings -- [Id -> info] : static environment
98 EndOfBlockInfo -- Info for stuff to do at end of basic block:
103 FAST_STRING -- the module name
107 AbstractC -- code accumulated so far
108 CgBindings -- [Id -> info] : *local* bindings environment
109 -- Bindings for top-level things are given in the info-down part
113 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
114 if the expression is a @case@, what to do at the end of each
120 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
121 -- return; push arguments starting just
122 -- above this point on a tail call.
124 -- This is therefore the A-stk ptr as seen
125 -- by a case alternative.
127 -- Args SpA is used when we want to stub any
128 -- currently-unstubbed dead A-stack (ptr)
129 -- slots; we want to know what SpA in the
130 -- continuation is so that we don't stub any
131 -- slots which are off the top of the
132 -- continuation's stack!
134 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
135 -- Two main differences:
136 -- 1. If Sequel isn't OnStack, then Args SpB points
137 -- just below the slot in which the return address
138 -- should be put. In effect, the Sequel
139 -- is a pending argument. If it is
141 -- points to the top word of the return
144 -- 2. It ain't used for stubbing because there are
148 initEobInfo = EndOfBlockInfo 0 0 InRetReg
151 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
152 that it must survive stack pointer adjustments at the end of the
157 = InRetReg -- The continuation is in RetReg
159 | OnStack VirtualSpBOffset
160 -- Continuation is on the stack, at the
161 -- specified location
163 | UpdateCode CAddrMode -- May be standard update code, or might be
164 -- the data-type-specific one.
167 CAddrMode -- Jump to this; if the continuation is for a vectored
168 -- case this might be the label of a return
169 -- vector Guaranteed to be a non-volatile
170 -- addressing mode (I think)
173 type SemiTaggingStuff
174 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
175 ([(ConTag, JoinDetails)], -- Alternatives
176 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
177 -- Maybe[3] the default is a
178 -- bind-default (Just b); that is,
179 -- it expects a ptr to the thing
180 -- in Node, bound to b
184 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
185 -- and join point label
187 -- The abstract C is executed only from a successful semitagging
188 -- venture, when a case has looked at a variable, found that it's
189 -- evaluated, and wants to load up the contents and go to the join
193 -- The OnStack case of sequelToAmode delivers an Amode which is only
194 -- valid just before the final control transfer, because it assumes
195 -- that SpB is pointing to the top word of the return address. This
196 -- seems unclean but there you go.
198 sequelToAmode :: Sequel -> FCode CAddrMode
200 sequelToAmode (OnStack virt_spb_offset)
201 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
202 returnFC (CVal spb_rel RetRep)
204 sequelToAmode InRetReg = returnFC (CReg RetReg)
205 --Andy/Simon's patch:
206 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
207 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
208 sequelToAmode (CaseAlts amode _) = returnFC amode
211 See the NOTES about the details of stack/heap usage tracking.
214 type CgStksAndHeapUsage -- stacks and heap usage information
215 = (AStackUsage, -- A-stack usage
216 BStackUsage, -- B-stack usage
220 (Int, -- virtSpA: Virtual offset of topmost allocated slot
221 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
222 Int, -- realSpA: Virtual offset of real stack pointer
223 Int) -- hwSpA: Highest value ever taken by virtSp
225 data StubFlag = Stubbed | NotStubbed
227 isStubbed Stubbed = True -- so the type can be abstract
228 isStubbed NotStubbed = False
231 (Int, -- virtSpB: Virtual offset of topmost allocated slot
232 [Int], -- freeB: List of free slots, in increasing order
233 Int, -- realSpB: Virtual offset of real stack pointer
234 Int) -- hwSpB: Highest value ever taken by virtSp
237 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
238 HeapOffset) -- realHp: Virtual offset of real heap ptr
240 NB: absolutely every one of the above Ints is really
241 a VirtualOffset of some description (the code generator
242 works entirely in terms of VirtualOffsets; see NOTES).
247 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
249 initUsage :: CgStksAndHeapUsage
250 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
251 initVirtHp = panic "Uninitialised virtual Hp"
252 initRealHp = panic "Uninitialised real Hp"
255 @envInitForAlternatives@ initialises the environment for a case alternative,
256 assuming that the alternative is entered after an evaluation.
260 zapping any volatile bindings, which aren't valid.
262 zapping the heap usage. It should be restored by a heap check.
264 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
265 this doesn't represent any {\em code}; it is a prediction of where the
266 real stack pointer will be when we come back from the case analysis.
268 BUT LEAVING the rest of the stack-usage info because it is all valid.
269 In particular, we leave the tail stack pointers unchanged, becuase the
270 alternative has to de-allocate the original @case@ expression's stack.
273 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
274 marks found in $e_2$.
277 stateIncUsage :: CgState -> CgState -> CgState
279 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
280 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
283 ((vA,fA,rA,hA1 `max` hA2),
284 (vB,fB,rB,hB1 `max` hB2),
285 (vH1 `maxOff` vH2, rH1))
288 %************************************************************************
290 \subsection[CgMonad-basics]{Basic code-generation monad magic}
292 %************************************************************************
295 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
296 type Code = CgInfoDownwards -> CgState -> CgState
299 {-# INLINE thenFC #-}
300 {-# INLINE returnFC #-}
302 The Abstract~C is not in the environment so as to improve strictness.
305 initC :: CompilationInfo -> Code -> AbstractC
308 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
310 MkCgState abc _ _ -> abc
312 returnFC :: a -> FCode a
314 returnFC val info_down state = (val, state)
319 -> (CgInfoDownwards -> CgState -> a)
320 -> CgInfoDownwards -> CgState -> a
322 -- thenC has both of the following types:
323 -- thenC :: Code -> Code -> Code
324 -- thenC :: Code -> FCode a -> FCode a
326 (m `thenC` k) info_down state
327 = k info_down new_state
329 new_state = m info_down state
331 listCs :: [Code] -> Code
333 listCs [] info_down state = state
334 listCs (c:cs) info_down state = stateN
336 state1 = c info_down state
337 stateN = listCs cs info_down state1
339 mapCs :: (a -> Code) -> [a] -> Code
341 mapCs f [] info_down state = state
342 mapCs f (c:cs) info_down state = stateN
344 state1 = (f c) info_down state
345 stateN = mapCs f cs info_down state1
350 -> (a -> CgInfoDownwards -> CgState -> c)
351 -> CgInfoDownwards -> CgState -> c
353 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
354 -- thenFC :: FCode a -> (a -> Code) -> Code
356 (m `thenFC` k) info_down state
357 = k m_result info_down new_state
359 (m_result, new_state) = m info_down state
361 listFCs :: [FCode a] -> FCode [a]
363 listFCs [] info_down state = ([], state)
364 listFCs (fc:fcs) info_down state = (thing : things, stateN)
366 (thing, state1) = fc info_down state
367 (things, stateN) = listFCs fcs info_down state1
369 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
371 mapFCs f [] info_down state = ([], state)
372 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
374 (thing, state1) = (f fc) info_down state
375 (things, stateN) = mapFCs f fcs info_down state1
378 And the knot-tying combinator:
380 fixC :: (a -> FCode a) -> FCode a
381 fixC fcode info_down state = result
383 result@(v, _) = fcode v info_down state
387 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
388 fresh environment, except that:
389 - compilation info and statics are passed in unchanged.
390 The current environment is passed on completely unaltered, except that
391 abstract C from the fork is incorporated.
393 @forkAbsC@ takes a code and compiles it in the current environment,
394 returning the abstract C thus constructed. The current environment
395 is passed on completely unchanged. It is pretty similar to @getAbsC@,
396 except that the latter does affect the environment. ToDo: combine?
398 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
399 from the current bindings, but which is otherwise freshly initialised.
400 The Abstract~C returned is attached to the current state, but the
401 bindings and usage information is otherwise unchanged.
404 forkClosureBody :: Code -> Code
407 (MkCgInfoDown cg_info statics _)
408 (MkCgState absC_in binds un_usage)
409 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
411 fork_state = code body_info_down initialStateC
412 MkCgState absC_fork _ _ = fork_state
413 body_info_down = MkCgInfoDown cg_info statics initEobInfo
415 forkStatics :: FCode a -> FCode a
417 forkStatics fcode (MkCgInfoDown cg_info _ _)
418 (MkCgState absC_in statics un_usage)
419 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
421 (result, state) = fcode rhs_info_down initialStateC
422 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
423 -- above or it becomes too strict!
424 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
426 forkAbsC :: Code -> FCode AbstractC
427 forkAbsC code info_down (MkCgState absC1 bs usage)
430 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
431 code info_down (MkCgState AbsCNop bs usage)
432 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
434 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
435 new_state = MkCgState absC1 bs new_usage
438 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
439 an fcode for the default case $d$, and compiles each in the current
440 environment. The current environment is passed on unmodified, except
442 - the worst stack high-water mark is incorporated
443 - the virtual Hp is moved on to the worst virtual Hp for the branches
445 The "extra branches" arise from handling the default case:
451 Here we in effect expand to
455 C2 c -> let z = C2 c in JUMP(default)
456 C3 d e f -> let z = C2 d e f in JUMP(default)
460 The stuff for C2 and C3 are the extra branches. They are
461 handled differently by forkAlts, because their
462 heap usage is joined onto that for the default case.
465 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
467 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
468 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
470 compile fc = fc info_down in_state
472 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
473 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
475 -- The "in_state" for the default branch is got by worst-casing the
476 -- heap usages etc from the "extra_branches"
477 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
478 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
480 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
481 -- NB foldl. in_state is the *left* argument to stateIncUsage
484 @forkEval@ takes two blocks of code.
486 \item The first meddles with the environment to set it up as expected by
487 the alternatives of a @case@ which does an eval (or gc-possible primop).
488 \item The second block is the code for the alternatives.
489 (plus info for semi-tagging purposes)
491 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
492 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
493 the caller to use, together with whatever value is returned by the second block.
495 It uses @initEnvForAlternatives@ to initialise the environment, and
496 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
500 forkEval :: EndOfBlockInfo -- For the body
501 -> Code -- Code to set environment
502 -> FCode Sequel -- Semi-tagging info to store
503 -> FCode EndOfBlockInfo -- The new end of block info
505 forkEval body_eob_info env_code body_code
506 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
507 returnFC (EndOfBlockInfo vA vB sequel)
509 forkEvalHelp :: EndOfBlockInfo -- For the body
510 -> Code -- Code to set environment
511 -> FCode a -- The code to do after the eval
512 -> FCode (Int, -- SpA
514 a) -- Result of the FCode
516 forkEvalHelp body_eob_info env_code body_code
517 info_down@(MkCgInfoDown cg_info statics _) state
518 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
520 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
522 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
523 -- These vA and fA things are now set up as the body code expects them
525 state_at_end_return :: CgState
527 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
529 state_for_body :: CgState
531 state_for_body = MkCgState AbsCNop
532 (nukeVolatileBinds binds)
533 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
534 (vB,fB,vB,vB), -- to virtual ones
535 (initVirtHp, initRealHp))
537 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
538 -- In the branch, all free locations will have been stubbed
541 stateIncUsageEval :: CgState -> CgState -> CgState
542 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
543 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
544 = MkCgState (absC1 `AbsCStmts` absC2)
545 -- The AbsC coming back should consist only of nested declarations,
546 -- notably of the return vector!
548 ((vA,fA,rA,hA1 `max` hA2),
549 (vB,fB,rB,hB1 `max` hB2),
551 -- We don't max the heap high-watermark because stateIncUsageEval is
552 -- used only in forkEval, which in turn is only used for blocks of code
553 -- which do their own heap-check.
556 %************************************************************************
558 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
560 %************************************************************************
562 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
563 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
566 nopC info_down state = state
568 absC :: AbstractC -> Code
569 absC more_absC info_down state@(MkCgState absC binds usage)
570 = MkCgState (mkAbsCStmts absC more_absC) binds usage
573 These two are just like @absC@, except they examine the compilation
574 info (whether SCC profiling or profiling-ctrs going) and possibly emit
578 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
580 costCentresC macro args _ state@(MkCgState absC binds usage)
581 = if opt_SccProfilingOn
582 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
585 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
587 profCtrC macro args _ state@(MkCgState absC binds usage)
588 = if not opt_DoTickyProfiling
590 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
592 {- Try to avoid adding too many special compilation strategies here.
593 It's better to modify the header files as necessary for particular
594 targets, so that we can get away with as few variants of .hc files
595 as possible. 'ForConcurrent' is somewhat special anyway, as it
596 changes entry conventions pretty significantly.
600 @getAbsC@ compiles the code in the current environment, and returns
601 the abstract C thus constructed (leaving the abstract C being carried
602 around in the state untouched). @getAbsC@ does not generate any
603 in-line Abstract~C itself, but the environment it returns is that
604 obtained from the compilation.
607 getAbsC :: Code -> FCode AbstractC
609 getAbsC code info_down (MkCgState absC binds usage)
610 = (absC2, MkCgState absC binds2 usage2)
612 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
616 noBlackHolingFlag, costCentresFlag :: FCode Bool
618 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
619 costCentresFlag _ state = (opt_SccProfilingOn, state)
624 moduleName :: FCode FAST_STRING
625 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
631 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
632 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
633 = code (MkCgInfoDown c_info statics eob_info) state
635 getEndOfBlockInfo :: FCode EndOfBlockInfo
636 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
640 %************************************************************************
642 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
644 %************************************************************************
646 There are three basic routines, for adding (@addBindC@), modifying
647 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
648 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
649 on the end of each function name).
651 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
652 The name should not already be bound.
654 addBindC :: Id -> CgIdInfo -> Code
655 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
656 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
660 addBindsC :: [(Id, CgIdInfo)] -> Code
661 addBindsC new_bindings info_down (MkCgState absC binds usage)
662 = MkCgState absC new_binds usage
664 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
670 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
671 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
672 = MkCgState absC (modifyIdEnv binds mangle_fn name) usage
675 Lookup is expected to find a binding for the @Id@.
677 lookupBindC :: Id -> FCode CgIdInfo
678 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
679 state@(MkCgState absC local_binds usage)
682 val = case (lookupIdEnv local_binds name) of
683 Nothing -> try_static
686 try_static = case (lookupIdEnv static_binds name) of
689 -> pprPanic "lookupBindC:no info!\n"
691 ppCat [ppStr "for:", ppr PprShowAll name],
692 ppStr "(probably: data dependencies broken by an optimisation pass)",
693 ppStr "static binds for:",
694 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
695 ppStr "local binds for:",
696 ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
700 %************************************************************************
702 \subsection[CgStackery-deadslots]{Finding dead stack slots}
704 %************************************************************************
706 @nukeDeadBindings@ does the following:
708 \item Removes all bindings from the environment other than those
709 for variables in the argument to @nukeDeadBindings@.
710 \item Collects any stack slots so freed, and returns them to the appropriate
712 \item Moves the virtual stack pointers to point to the topmost used
716 Find dead slots on the stacks *and* remove bindings for dead variables
719 You can have multi-word slots on the B stack; if dead, such a slot
720 will be reported as {\em several} offsets (one per word).
722 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
723 set, so that no stack-stubbing will take place.
725 Probably *naughty* to look inside monad...
728 nukeDeadBindings :: StgLiveVars -- All the *live* variables
733 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
734 (vsp_b, free_b, real_b, hw_b),
736 = MkCgState abs_c (mkIdEnv bs') new_usage
738 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
739 (new_vsp_b, new_free_b, real_b, hw_b),
742 (dead_a_slots, dead_b_slots, bs')
743 = dead_slots live_vars
745 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
747 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
748 extra_free_b = sortLt (<) dead_b_slots
750 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
751 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
753 getUnstubbedAStackSlots
754 :: VirtualSpAOffset -- Ignore slots bigger than this
755 -> FCode [VirtualSpAOffset] -- Return the list of slots found
757 getUnstubbedAStackSlots tail_spa
758 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
759 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
762 Several boring auxiliary functions to do the dirty work.
765 dead_slots :: StgLiveVars
766 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
768 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
770 -- dead_slots carries accumulating parameters for
771 -- filtered bindings, dead a and b slots
772 dead_slots live_vars fbs das dbs []
773 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
775 dead_slots live_vars fbs das dbs ((v,i):bs)
776 | v `elementOfUniqSet` live_vars
777 = dead_slots live_vars ((v,i):fbs) das dbs bs
778 -- Live, so don't record it in dead slots
779 -- Instead keep it in the filtered bindings
783 MkCgIdInfo _ _ stable_loc _
785 dead_slots live_vars fbs (offsetA : das) dbs bs
788 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
790 maybe_Astk_loc = maybeAStkLoc stable_loc
791 is_Astk_loc = maybeToBool maybe_Astk_loc
792 (Just offsetA) = maybe_Astk_loc
794 maybe_Bstk_loc = maybeBStkLoc stable_loc
795 is_Bstk_loc = maybeToBool maybe_Bstk_loc
796 (Just offsetB) = maybe_Bstk_loc
798 _ -> dead_slots live_vars fbs das dbs bs
801 size = (getPrimRepSize . typePrimRep . idType) v
803 -- addFreeSlots expects *both* args to be in increasing order
804 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
805 addFreeASlots = addFreeSlots fst
807 addFreeBSlots :: [Int] -> [Int] -> [Int]
808 addFreeBSlots = addFreeSlots id
810 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
812 addFreeSlots get_offset cs [] = cs
813 addFreeSlots get_offset [] ns = ns
814 addFreeSlots get_offset (c:cs) (n:ns)
815 = if off_c < off_n then
816 (c : addFreeSlots get_offset cs (n:ns))
817 else if off_c > off_n then
818 (n : addFreeSlots get_offset (c:cs) ns)
820 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
825 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
827 trim get_offset current_sp free_slots
828 = try current_sp (reverse free_slots)
830 try csp [] = (csp, [])
832 = if csp < slot_off then
833 try csp slots -- Free slot off top of stk; ignore
835 else if csp == slot_off then
836 try (csp-1) slots -- Free slot at top of stk; trim
839 (csp, reverse (slot:slots)) -- Otherwise gap; give up
841 slot_off = get_offset slot