2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CgStackery]{Stack management functions}
6 Stack-twiddling operations, which are pretty low-down and grimy.
7 (This is the module that knows all about stack layouts, etc.)
10 #include "HsVersions.h"
13 allocAStack, allocBStack, allocAStackTop, allocBStackTop,
15 adjustRealSps, getFinalStackHW,
16 mkVirtStkOffsets, mkStkAmodes
24 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
25 import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
26 import PrimRep ( getPrimRepSize, separateByPtrFollowness,
29 import Util ( mapAccumR, panic )
32 %************************************************************************
34 \subsection[CgStackery-layout]{Laying out a stack frame}
36 %************************************************************************
38 @mkVirtStkOffsets@ is given a list of arguments. The first argument
39 gets the {\em largest} virtual stack offset (remember, virtual offsets
40 increase towards the top of stack).
43 mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing
44 -> VirtualSpBOffset -- ditto
45 -> (a -> PrimRep) -- to be able to grab kinds
46 -> [a] -- things to make offsets for
47 -> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
48 VirtualSpBOffset, -- ditto
49 [(a, VirtualSpAOffset)], -- boxed things with offsets
50 [(a, VirtualSpBOffset)]) -- unboxed things with offsets
52 mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
53 = let (boxeds, unboxeds)
54 = separateByPtrFollowness kind_fun things
55 (last_SpA_offset, boxd_w_offsets)
56 = mapAccumR computeOffset init_SpA_offset boxeds
57 (last_SpB_offset, ubxd_w_offsets)
58 = mapAccumR computeOffset init_SpB_offset unboxeds
60 (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
62 computeOffset offset thing
63 = (offset + (max 1 . getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
64 -- The "max 1" bit is ULTRA important
65 -- Why? mkVirtStkOffsets is the unique function that lays out function
66 -- arguments on the stack. The "max 1" ensures that every argument takes
67 -- at least one stack slot, even if it's of kind VoidKind that actually
68 -- takes no space at all.
69 -- This is important to make sure that argument satisfaction checks work
72 -- where s# is a VoidKind. f's argument satisfaction check will check
73 -- that s# is on the B stack above SuB; but if s# takes zero space, the
74 -- check will be ARGS_B_CHK(0), which always succeeds. As a result, even
75 -- if a,b aren't available either, the PAP update won't trigger and
76 -- we are throughly hosed. (SLPJ 96/05)
79 @mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
80 It starts from the tail-call locations.
81 It returns a single list of addressing modes for the stack locations,
82 and therefore is in the monad.
84 It also adjusts the high water mark if necessary.
87 mkStkAmodes :: VirtualSpAOffset -- Tail call positions
89 -> [CAddrMode] -- things to make offsets for
90 -> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
91 VirtualSpBOffset, -- ditto
92 AbstractC) -- Assignments to appropriate stk slots
94 mkStkAmodes tail_spa tail_spb things
95 info_down (MkCgState absC binds usage)
96 = (result, MkCgState absC binds new_usage)
98 result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
100 (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
101 = mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
104 = [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
105 | (thing, offset) <- ptrs_w_offsets
108 [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
109 | (thing, offset) <- non_ptrs_w_offsets
112 ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
114 new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
115 (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
117 -- No need to fiddle with virtual SpA etc because this call is
118 -- only done just before the end of a block
123 %************************************************************************
125 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
127 %************************************************************************
129 Allocate a virtual offset for something.
131 allocAStack :: FCode VirtualSpAOffset
133 allocAStack info_down (MkCgState absC binds
134 ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
135 = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
137 push_virt_a = virt_a + 1
139 (chosen_slot, new_a_usage)
140 = if null free_a then
141 -- No free slots, so push a new one
142 -- We need to adjust the high-water mark
143 (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
145 -- Free slots available, so use one
146 (free_slot, (virt_a, new_free_a, real_a, hw_a))
148 (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
149 -- Try to find an un-stubbed location;
150 -- if none, return the first in the free list
151 -- We'll only try this if free_a is known to be non-empty
153 -- Free list with the free_slot deleted
154 new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
156 allocBStack :: Int -> FCode VirtualSpBOffset
157 allocBStack size info_down (MkCgState absC binds
158 (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
159 = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
161 push_virt_b = virt_b + size
163 (chosen_slot, new_b_usage)
164 = case find_block free_b of
165 Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
166 hw_b `max` push_virt_b))
167 -- Adjust high water mark
169 Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
171 -- find_block looks for a contiguous chunk of free slots
172 find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
173 find_block [] = Nothing
174 find_block (slot:slots)
175 | take size (slot:slots) == [slot..slot+size-1]
180 delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
181 -- Retain slots which are not in the range
184 -- Allocate a chunk ON TOP OF the stack
185 allocAStackTop :: Int -> FCode VirtualSpAOffset
186 allocAStackTop size info_down (MkCgState absC binds
187 ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
188 = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
190 push_virt_a = virt_a + size
191 chosen_slot = virt_a + 1
192 new_a_usage = (push_virt_a, free_a, real_a, hw_a `max` push_virt_a)
193 -- Adjust high water mark
195 -- Allocate a chunk ON TOP OF the stack
196 allocBStackTop :: Int -> FCode VirtualSpBOffset
197 allocBStackTop size info_down (MkCgState absC binds
198 (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
199 = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
201 push_virt_b = virt_b + size
202 chosen_slot = virt_b+1
203 new_b_usage = (push_virt_b, free_b, real_b, hw_b `max` push_virt_b)
204 -- Adjust high water mark
207 @allocUpdateFrame@ allocates enough space for an update frame
208 on the B stack, records the fact in the end-of-block info (in the ``args''
209 fields), and passes on the old ``args'' fields to the enclosed code.
211 This is all a bit disgusting.
214 allocUpdateFrame :: Int -- Size of frame
215 -> CAddrMode -- Return address which is to be the
217 -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
221 allocUpdateFrame size update_amode code
222 (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
223 (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
226 InRetReg -> code (args_spa, args_spb, vB)
227 (MkCgInfoDown c_info statics new_eob_info)
228 (MkCgState absc binds new_usage)
230 other -> panic "allocUpdateFrame"
234 new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
235 new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
242 getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
243 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
245 state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
246 (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
250 %************************************************************************
252 \subsection[CgStackery-adjust]{Adjusting the stack pointers}
254 %************************************************************************
256 @adjustRealSpX@ generates code to alter the actual stack pointer, and
257 adjusts the environment accordingly. We are careful to push the
258 conditional inside the abstract C code to avoid black holes.
259 ToDo: combine together?
261 These functions {\em do not} deal with high-water-mark adjustment.
262 That's done by functions which allocate stack space.
265 adjustRealSpA :: VirtualSpAOffset -- New offset for Arg stack ptr
267 adjustRealSpA newRealSpA info_down (MkCgState absC binds
268 ((vspA,fA,realSpA,hwspA),
270 = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
272 move_instrA = if (newRealSpA == realSpA) then AbsCNop
275 (CAddr (SpARel realSpA newRealSpA)))
276 new_usage = ((vspA, fA, newRealSpA, hwspA),
279 adjustRealSpB :: VirtualSpBOffset -- New offset for Basic/Control stack ptr
281 adjustRealSpB newRealSpB info_down (MkCgState absC binds
283 (vspB,fB,realSpB,hwspB),
285 = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
287 move_instrB = if (newRealSpB == realSpB) then AbsCNop
288 else (CAssign {-PtrRep-}
290 (CAddr (SpBRel realSpB newRealSpB)))
291 new_usage = (a_usage,
292 (vspB, fB, newRealSpB, hwspB),
295 adjustRealSps :: VirtualSpAOffset -- New offset for Arg stack ptr
296 -> VirtualSpBOffset -- Ditto B stack
298 adjustRealSps newRealSpA newRealSpB
299 = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB