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 PprStyle ( PprStyle(..) )
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 )
79 #if __GLASGOW_HASKELL__ >= 202
80 import Outputable ( Outputable(..) )
83 infixr 9 `thenC` -- Right-associative!
87 %************************************************************************
89 \subsection[CgMonad-environment]{Stuff for manipulating environments}
91 %************************************************************************
93 This monadery has some information that it only passes {\em
94 downwards}, as well as some ``state'' which is modified as we go
98 data CgInfoDownwards -- information only passed *downwards* by the monad
100 CompilationInfo -- COMPLETELY STATIC info about this compilation
101 -- (e.g., what flags were passed to the compiler)
103 CgBindings -- [Id -> info] : static environment
105 EndOfBlockInfo -- Info for stuff to do at end of basic block:
110 FAST_STRING -- the module name
114 AbstractC -- code accumulated so far
115 CgBindings -- [Id -> info] : *local* bindings environment
116 -- Bindings for top-level things are given in the info-down part
120 @EndOfBlockInfo@ tells what to do at the end of this block of code or,
121 if the expression is a @case@, what to do at the end of each
127 VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
128 -- return; push arguments starting just
129 -- above this point on a tail call.
131 -- This is therefore the A-stk ptr as seen
132 -- by a case alternative.
134 -- Args SpA is used when we want to stub any
135 -- currently-unstubbed dead A-stack (ptr)
136 -- slots; we want to know what SpA in the
137 -- continuation is so that we don't stub any
138 -- slots which are off the top of the
139 -- continuation's stack!
141 VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
142 -- Two main differences:
143 -- 1. If Sequel isn't OnStack, then Args SpB points
144 -- just below the slot in which the return address
145 -- should be put. In effect, the Sequel
146 -- is a pending argument. If it is
148 -- points to the top word of the return
151 -- 2. It ain't used for stubbing because there are
155 initEobInfo = EndOfBlockInfo 0 0 InRetReg
158 Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
159 that it must survive stack pointer adjustments at the end of the
164 = InRetReg -- The continuation is in RetReg
166 | OnStack VirtualSpBOffset
167 -- Continuation is on the stack, at the
168 -- specified location
170 | UpdateCode CAddrMode -- May be standard update code, or might be
171 -- the data-type-specific one.
174 CAddrMode -- Jump to this; if the continuation is for a vectored
175 -- case this might be the label of a return
176 -- vector Guaranteed to be a non-volatile
177 -- addressing mode (I think)
180 type SemiTaggingStuff
181 = Maybe -- Maybe[1] we don't have any semi-tagging stuff...
182 ([(ConTag, JoinDetails)], -- Alternatives
183 Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
184 -- Maybe[3] the default is a
185 -- bind-default (Just b); that is,
186 -- it expects a ptr to the thing
187 -- in Node, bound to b
191 = (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
192 -- and join point label
194 -- The abstract C is executed only from a successful semitagging
195 -- venture, when a case has looked at a variable, found that it's
196 -- evaluated, and wants to load up the contents and go to the join
200 -- The OnStack case of sequelToAmode delivers an Amode which is only
201 -- valid just before the final control transfer, because it assumes
202 -- that SpB is pointing to the top word of the return address. This
203 -- seems unclean but there you go.
205 sequelToAmode :: Sequel -> FCode CAddrMode
207 sequelToAmode (OnStack virt_spb_offset)
208 = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel ->
209 returnFC (CVal spb_rel RetRep)
211 sequelToAmode InRetReg = returnFC (CReg RetReg)
212 --Andy/Simon's patch:
213 --WAS: sequelToAmode (UpdateCode amode) = returnFC amode
214 sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg)
215 sequelToAmode (CaseAlts amode _) = returnFC amode
218 See the NOTES about the details of stack/heap usage tracking.
221 type CgStksAndHeapUsage -- stacks and heap usage information
222 = (AStackUsage, -- A-stack usage
223 BStackUsage, -- B-stack usage
227 (Int, -- virtSpA: Virtual offset of topmost allocated slot
228 [(Int,StubFlag)], -- freeA: List of free slots, in increasing order
229 Int, -- realSpA: Virtual offset of real stack pointer
230 Int) -- hwSpA: Highest value ever taken by virtSp
232 data StubFlag = Stubbed | NotStubbed
234 isStubbed Stubbed = True -- so the type can be abstract
235 isStubbed NotStubbed = False
238 (Int, -- virtSpB: Virtual offset of topmost allocated slot
239 [Int], -- freeB: List of free slots, in increasing order
240 Int, -- realSpB: Virtual offset of real stack pointer
241 Int) -- hwSpB: Highest value ever taken by virtSp
244 (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word
245 HeapOffset) -- realHp: Virtual offset of real heap ptr
247 NB: absolutely every one of the above Ints is really
248 a VirtualOffset of some description (the code generator
249 works entirely in terms of VirtualOffsets; see NOTES).
254 initialStateC = MkCgState AbsCNop nullIdEnv initUsage
256 initUsage :: CgStksAndHeapUsage
257 initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp))
258 initVirtHp = panic "Uninitialised virtual Hp"
259 initRealHp = panic "Uninitialised real Hp"
262 @envInitForAlternatives@ initialises the environment for a case alternative,
263 assuming that the alternative is entered after an evaluation.
267 zapping any volatile bindings, which aren't valid.
269 zapping the heap usage. It should be restored by a heap check.
271 setting the virtual AND real stack pointer fields to the given virtual stack offsets.
272 this doesn't represent any {\em code}; it is a prediction of where the
273 real stack pointer will be when we come back from the case analysis.
275 BUT LEAVING the rest of the stack-usage info because it is all valid.
276 In particular, we leave the tail stack pointers unchanged, becuase the
277 alternative has to de-allocate the original @case@ expression's stack.
280 @stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water
281 marks found in $e_2$.
284 stateIncUsage :: CgState -> CgState -> CgState
286 stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1)))
287 (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _)))
290 ((vA,fA,rA,hA1 `max` hA2),
291 (vB,fB,rB,hB1 `max` hB2),
292 (vH1 `maxOff` vH2, rH1))
295 %************************************************************************
297 \subsection[CgMonad-basics]{Basic code-generation monad magic}
299 %************************************************************************
302 type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
303 type Code = CgInfoDownwards -> CgState -> CgState
306 {-# INLINE thenFC #-}
307 {-# INLINE returnFC #-}
309 The Abstract~C is not in the environment so as to improve strictness.
312 initC :: CompilationInfo -> Code -> AbstractC
315 = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo)
317 MkCgState abc _ _ -> abc
319 returnFC :: a -> FCode a
321 returnFC val info_down state = (val, state)
326 -> (CgInfoDownwards -> CgState -> a)
327 -> CgInfoDownwards -> CgState -> a
329 -- thenC has both of the following types:
330 -- thenC :: Code -> Code -> Code
331 -- thenC :: Code -> FCode a -> FCode a
333 thenC m k info_down state
334 = k info_down new_state
336 new_state = m info_down state
338 listCs :: [Code] -> Code
340 listCs [] info_down state = state
341 listCs (c:cs) info_down state = stateN
343 state1 = c info_down state
344 stateN = listCs cs info_down state1
346 mapCs :: (a -> Code) -> [a] -> Code
348 mapCs f [] info_down state = state
349 mapCs f (c:cs) info_down state = stateN
351 state1 = (f c) info_down state
352 stateN = mapCs f cs info_down state1
357 -> (a -> CgInfoDownwards -> CgState -> c)
358 -> CgInfoDownwards -> CgState -> c
360 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
361 -- thenFC :: FCode a -> (a -> Code) -> Code
363 thenFC m k info_down state
364 = k m_result info_down new_state
366 (m_result, new_state) = m info_down state
368 listFCs :: [FCode a] -> FCode [a]
370 listFCs [] info_down state = ([], state)
371 listFCs (fc:fcs) info_down state = (thing : things, stateN)
373 (thing, state1) = fc info_down state
374 (things, stateN) = listFCs fcs info_down state1
376 mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
378 mapFCs f [] info_down state = ([], state)
379 mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
381 (thing, state1) = (f fc) info_down state
382 (things, stateN) = mapFCs f fcs info_down state1
385 And the knot-tying combinator:
387 fixC :: (a -> FCode a) -> FCode a
388 fixC fcode info_down state = result
390 result@(v, _) = fcode v info_down state
394 @forkClosureBody@ takes a code, $c$, and compiles it in a completely
395 fresh environment, except that:
396 - compilation info and statics are passed in unchanged.
397 The current environment is passed on completely unaltered, except that
398 abstract C from the fork is incorporated.
400 @forkAbsC@ takes a code and compiles it in the current environment,
401 returning the abstract C thus constructed. The current environment
402 is passed on completely unchanged. It is pretty similar to @getAbsC@,
403 except that the latter does affect the environment. ToDo: combine?
405 @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
406 from the current bindings, but which is otherwise freshly initialised.
407 The Abstract~C returned is attached to the current state, but the
408 bindings and usage information is otherwise unchanged.
411 forkClosureBody :: Code -> Code
414 (MkCgInfoDown cg_info statics _)
415 (MkCgState absC_in binds un_usage)
416 = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
418 fork_state = code body_info_down initialStateC
419 MkCgState absC_fork _ _ = fork_state
420 body_info_down = MkCgInfoDown cg_info statics initEobInfo
422 forkStatics :: FCode a -> FCode a
424 forkStatics fcode (MkCgInfoDown cg_info _ _)
425 (MkCgState absC_in statics un_usage)
426 = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
428 (result, state) = fcode rhs_info_down initialStateC
429 MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
430 -- above or it becomes too strict!
431 rhs_info_down = MkCgInfoDown cg_info statics initEobInfo
433 forkAbsC :: Code -> FCode AbstractC
434 forkAbsC code info_down (MkCgState absC1 bs usage)
437 MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) =
438 code info_down (MkCgState AbsCNop bs usage)
439 ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage
441 new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage)
442 new_state = MkCgState absC1 bs new_usage
445 @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
446 an fcode for the default case $d$, and compiles each in the current
447 environment. The current environment is passed on unmodified, except
449 - the worst stack high-water mark is incorporated
450 - the virtual Hp is moved on to the worst virtual Hp for the branches
452 The "extra branches" arise from handling the default case:
458 Here we in effect expand to
462 C2 c -> let z = C2 c in JUMP(default)
463 C3 d e f -> let z = C2 d e f in JUMP(default)
467 The stuff for C2 and C3 are the extra branches. They are
468 handled differently by forkAlts, because their
469 heap usage is joined onto that for the default case.
472 forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b)
474 forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state
475 = ((extra_branch_results ++ branch_results , deflt_result), out_state)
477 compile fc = fc info_down in_state
479 (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
480 (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes)
482 -- The "in_state" for the default branch is got by worst-casing the
483 -- heap usages etc from the "extra_branches"
484 default_in_state = foldl stateIncUsage in_state extra_branch_out_states
485 (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state
487 out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states)
488 -- NB foldl. in_state is the *left* argument to stateIncUsage
491 @forkEval@ takes two blocks of code.
493 \item The first meddles with the environment to set it up as expected by
494 the alternatives of a @case@ which does an eval (or gc-possible primop).
495 \item The second block is the code for the alternatives.
496 (plus info for semi-tagging purposes)
498 @forkEval@ picks up the virtual stack pointers and stubbed stack slots
499 as set up by the first block, and returns a suitable @EndOfBlockInfo@ for
500 the caller to use, together with whatever value is returned by the second block.
502 It uses @initEnvForAlternatives@ to initialise the environment, and
503 @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap
507 forkEval :: EndOfBlockInfo -- For the body
508 -> Code -- Code to set environment
509 -> FCode Sequel -- Semi-tagging info to store
510 -> FCode EndOfBlockInfo -- The new end of block info
512 forkEval body_eob_info env_code body_code
513 = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) ->
514 returnFC (EndOfBlockInfo vA vB sequel)
516 forkEvalHelp :: EndOfBlockInfo -- For the body
517 -> Code -- Code to set environment
518 -> FCode a -- The code to do after the eval
519 -> FCode (Int, -- SpA
521 a) -- Result of the FCode
523 forkEvalHelp body_eob_info env_code body_code
524 info_down@(MkCgInfoDown cg_info statics _) state
525 = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return)
527 info_down_for_body = MkCgInfoDown cg_info statics body_eob_info
529 (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state
530 -- These vA and fA things are now set up as the body code expects them
532 state_at_end_return :: CgState
534 (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body
536 state_for_body :: CgState
538 state_for_body = MkCgState AbsCNop
539 (nukeVolatileBinds binds)
540 ((vA,stubbed_fA,vA,vA), -- Set real and hwms
541 (vB,fB,vB,vB), -- to virtual ones
542 (initVirtHp, initRealHp))
544 stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ]
545 -- In the branch, all free locations will have been stubbed
548 stateIncUsageEval :: CgState -> CgState -> CgState
549 stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage))
550 (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _))
551 = MkCgState (absC1 `AbsCStmts` absC2)
552 -- The AbsC coming back should consist only of nested declarations,
553 -- notably of the return vector!
555 ((vA,fA,rA,hA1 `max` hA2),
556 (vB,fB,rB,hB1 `max` hB2),
558 -- We don't max the heap high-watermark because stateIncUsageEval is
559 -- used only in forkEval, which in turn is only used for blocks of code
560 -- which do their own heap-check.
563 %************************************************************************
565 \subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@}
567 %************************************************************************
569 @nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the
570 environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far.
573 nopC info_down state = state
575 absC :: AbstractC -> Code
576 absC more_absC info_down state@(MkCgState absC binds usage)
577 = MkCgState (mkAbsCStmts absC more_absC) binds usage
580 These two are just like @absC@, except they examine the compilation
581 info (whether SCC profiling or profiling-ctrs going) and possibly emit
585 costCentresC :: FAST_STRING -> [CAddrMode] -> Code
587 costCentresC macro args _ state@(MkCgState absC binds usage)
588 = if opt_SccProfilingOn
589 then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
592 profCtrC :: FAST_STRING -> [CAddrMode] -> Code
594 profCtrC macro args _ state@(MkCgState absC binds usage)
595 = if not opt_DoTickyProfiling
597 else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
599 {- Try to avoid adding too many special compilation strategies here.
600 It's better to modify the header files as necessary for particular
601 targets, so that we can get away with as few variants of .hc files
602 as possible. 'ForConcurrent' is somewhat special anyway, as it
603 changes entry conventions pretty significantly.
607 @getAbsC@ compiles the code in the current environment, and returns
608 the abstract C thus constructed (leaving the abstract C being carried
609 around in the state untouched). @getAbsC@ does not generate any
610 in-line Abstract~C itself, but the environment it returns is that
611 obtained from the compilation.
614 getAbsC :: Code -> FCode AbstractC
616 getAbsC code info_down (MkCgState absC binds usage)
617 = (absC2, MkCgState absC binds2 usage2)
619 (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage)
623 noBlackHolingFlag, costCentresFlag :: FCode Bool
625 noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
626 costCentresFlag _ state = (opt_SccProfilingOn, state)
631 moduleName :: FCode FAST_STRING
632 moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
638 setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
639 setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state
640 = code (MkCgInfoDown c_info statics eob_info) state
642 getEndOfBlockInfo :: FCode EndOfBlockInfo
643 getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state
647 %************************************************************************
649 \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
651 %************************************************************************
653 There are three basic routines, for adding (@addBindC@), modifying
654 (@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine
655 is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
656 on the end of each function name).
658 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
659 The name should not already be bound. (nice ASSERT, eh?)
661 addBindC :: Id -> CgIdInfo -> Code
662 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
663 = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage
667 addBindsC :: [(Id, CgIdInfo)] -> Code
668 addBindsC new_bindings info_down (MkCgState absC binds usage)
669 = MkCgState absC new_binds usage
671 new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info)
677 modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
678 modifyBindC name mangle_fn info_down (MkCgState absC binds usage)
679 = MkCgState absC (modifyIdEnv mangle_fn binds name) usage
682 Lookup is expected to find a binding for the @Id@.
684 lookupBindC :: Id -> FCode CgIdInfo
685 lookupBindC name info_down@(MkCgInfoDown _ static_binds _)
686 state@(MkCgState absC local_binds usage)
689 val = case (lookupIdEnv local_binds name) of
690 Nothing -> try_static
693 try_static = case (lookupIdEnv static_binds name) of
696 -> pprPanic "lookupBindC:no info!\n"
698 hsep [ptext SLIT("for:"), ppr PprShowAll name],
699 ptext SLIT("(probably: data dependencies broken by an optimisation pass)"),
700 ptext SLIT("static binds for:"),
701 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ],
702 ptext SLIT("local binds for:"),
703 vcat [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ]
707 %************************************************************************
709 \subsection[CgStackery-deadslots]{Finding dead stack slots}
711 %************************************************************************
713 @nukeDeadBindings@ does the following:
715 \item Removes all bindings from the environment other than those
716 for variables in the argument to @nukeDeadBindings@.
717 \item Collects any stack slots so freed, and returns them to the appropriate
719 \item Moves the virtual stack pointers to point to the topmost used
723 Find dead slots on the stacks *and* remove bindings for dead variables
726 You can have multi-word slots on the B stack; if dead, such a slot
727 will be reported as {\em several} offsets (one per word).
729 NOT YET: It returns empty lists if the -fno-stack-stubbing flag is
730 set, so that no stack-stubbing will take place.
732 Probably *naughty* to look inside monad...
735 nukeDeadBindings :: StgLiveVars -- All the *live* variables
740 state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a),
741 (vsp_b, free_b, real_b, hw_b),
743 = MkCgState abs_c (mkIdEnv bs') new_usage
745 new_usage = ((new_vsp_a, new_free_a, real_a, hw_a),
746 (new_vsp_b, new_free_b, real_b, hw_b),
749 (dead_a_slots, dead_b_slots, bs')
750 = dead_slots live_vars
752 [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ]
754 extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed)
755 extra_free_b = sortLt (<) dead_b_slots
757 (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a)
758 (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b)
760 getUnstubbedAStackSlots
761 :: VirtualSpAOffset -- Ignore slots bigger than this
762 -> FCode [VirtualSpAOffset] -- Return the list of slots found
764 getUnstubbedAStackSlots tail_spa
765 info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _))
766 = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state)
769 Several boring auxiliary functions to do the dirty work.
772 dead_slots :: StgLiveVars
773 -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset]
775 -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)])
777 -- dead_slots carries accumulating parameters for
778 -- filtered bindings, dead a and b slots
779 dead_slots live_vars fbs das dbs []
780 = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any
782 dead_slots live_vars fbs das dbs ((v,i):bs)
783 | v `elementOfUniqSet` live_vars
784 = dead_slots live_vars ((v,i):fbs) das dbs bs
785 -- Live, so don't record it in dead slots
786 -- Instead keep it in the filtered bindings
790 MkCgIdInfo _ _ stable_loc _
792 dead_slots live_vars fbs (offsetA : das) dbs bs
795 dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs
797 maybe_Astk_loc = maybeAStkLoc stable_loc
798 is_Astk_loc = maybeToBool maybe_Astk_loc
799 (Just offsetA) = maybe_Astk_loc
801 maybe_Bstk_loc = maybeBStkLoc stable_loc
802 is_Bstk_loc = maybeToBool maybe_Bstk_loc
803 (Just offsetB) = maybe_Bstk_loc
805 _ -> dead_slots live_vars fbs das dbs bs
808 size = (getPrimRepSize . typePrimRep . idType) v
810 -- addFreeSlots expects *both* args to be in increasing order
811 addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
812 addFreeASlots = addFreeSlots fst
814 addFreeBSlots :: [Int] -> [Int] -> [Int]
815 addFreeBSlots = addFreeSlots id
817 addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot]
819 addFreeSlots get_offset cs [] = cs
820 addFreeSlots get_offset [] ns = ns
821 addFreeSlots get_offset (c:cs) (n:ns)
822 = if off_c < off_n then
823 (c : addFreeSlots get_offset cs (n:ns))
824 else if off_c > off_n then
825 (n : addFreeSlots get_offset (c:cs) ns)
827 panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns))
832 trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot])
834 trim get_offset current_sp free_slots
835 = try current_sp (reverse free_slots)
837 try csp [] = (csp, [])
839 = if csp < slot_off then
840 try csp slots -- Free slot off top of stk; ignore
842 else if csp == slot_off then
843 try (csp-1) slots -- Free slot at top of stk; trim
846 (csp, reverse (slot:slots)) -- Otherwise gap; give up
848 slot_off = get_offset slot