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.)
11 allocAStack, allocBStack, allocAStackTop, allocBStackTop,
13 adjustRealSps, getFinalStackHW,
14 mkVirtStkOffsets, mkStkAmodes
17 #include "HsVersions.h"
22 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
23 import HeapOffs ( VirtualSpAOffset, VirtualSpBOffset )
24 import PrimRep ( getPrimRepSize, separateByPtrFollowness,
27 import Util ( mapAccumR, panic )
30 %************************************************************************
32 \subsection[CgStackery-layout]{Laying out a stack frame}
34 %************************************************************************
36 @mkVirtStkOffsets@ is given a list of arguments. The first argument
37 gets the {\em largest} virtual stack offset (remember, virtual offsets
38 increase towards the top of stack).
41 mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing
42 -> VirtualSpBOffset -- ditto
43 -> (a -> PrimRep) -- to be able to grab kinds
44 -> [a] -- things to make offsets for
45 -> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
46 VirtualSpBOffset, -- ditto
47 [(a, VirtualSpAOffset)], -- boxed things with offsets
48 [(a, VirtualSpBOffset)]) -- unboxed things with offsets
50 mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
51 = let (boxeds, unboxeds)
52 = separateByPtrFollowness kind_fun things
53 (last_SpA_offset, boxd_w_offsets)
54 = mapAccumR computeOffset init_SpA_offset boxeds
55 (last_SpB_offset, ubxd_w_offsets)
56 = mapAccumR computeOffset init_SpB_offset unboxeds
58 (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
60 computeOffset offset thing
61 = (offset + (max 1 . getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
62 -- The "max 1" bit is ULTRA important
63 -- Why? mkVirtStkOffsets is the unique function that lays out function
64 -- arguments on the stack. The "max 1" ensures that every argument takes
65 -- at least one stack slot, even if it's of kind VoidKind that actually
66 -- takes no space at all.
67 -- This is important to make sure that argument satisfaction checks work
70 -- where s# is a VoidKind. f's argument satisfaction check will check
71 -- that s# is on the B stack above SuB; but if s# takes zero space, the
72 -- check will be ARGS_B_CHK(0), which always succeeds. As a result, even
73 -- if a,b aren't available either, the PAP update won't trigger and
74 -- we are throughly hosed. (SLPJ 96/05)
77 @mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
78 It starts from the tail-call locations.
79 It returns a single list of addressing modes for the stack locations,
80 and therefore is in the monad.
82 It also adjusts the high water mark if necessary.
85 mkStkAmodes :: VirtualSpAOffset -- Tail call positions
87 -> [CAddrMode] -- things to make offsets for
88 -> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word
89 VirtualSpBOffset, -- ditto
90 AbstractC) -- Assignments to appropriate stk slots
92 mkStkAmodes tail_spa tail_spb things
93 info_down (MkCgState absC binds usage)
94 = (result, MkCgState absC binds new_usage)
96 result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
98 (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
99 = mkVirtStkOffsets tail_spa tail_spb getAmodeRep things
102 = [ CAssign (CVal (SpARel realSpA offset) PtrRep) thing
103 | (thing, offset) <- ptrs_w_offsets
106 [ CAssign (CVal (SpBRel realSpB offset) (getAmodeRep thing)) thing
107 | (thing, offset) <- non_ptrs_w_offsets
110 ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
112 new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
113 (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
115 -- No need to fiddle with virtual SpA etc because this call is
116 -- only done just before the end of a block
121 %************************************************************************
123 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
125 %************************************************************************
127 Allocate a virtual offset for something.
129 allocAStack :: FCode VirtualSpAOffset
131 allocAStack info_down (MkCgState absC binds
132 ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
133 = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
135 push_virt_a = virt_a + 1
137 (chosen_slot, new_a_usage)
138 = if null free_a then
139 -- No free slots, so push a new one
140 -- We need to adjust the high-water mark
141 (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
143 -- Free slots available, so use one
144 (free_slot, (virt_a, new_free_a, real_a, hw_a))
146 (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
147 -- Try to find an un-stubbed location;
148 -- if none, return the first in the free list
149 -- We'll only try this if free_a is known to be non-empty
151 -- Free list with the free_slot deleted
152 new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
154 allocBStack :: Int -> FCode VirtualSpBOffset
155 allocBStack size info_down (MkCgState absC binds
156 (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
157 = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
159 push_virt_b = virt_b + size
161 (chosen_slot, new_b_usage)
162 = case find_block free_b of
163 Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
164 hw_b `max` push_virt_b))
165 -- Adjust high water mark
167 Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
169 -- find_block looks for a contiguous chunk of free slots
170 find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
171 find_block [] = Nothing
172 find_block (slot:slots)
173 | take size (slot:slots) == [slot..slot+size-1]
178 delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
179 -- Retain slots which are not in the range
182 -- Allocate a chunk ON TOP OF the stack
183 allocAStackTop :: Int -> FCode VirtualSpAOffset
184 allocAStackTop size info_down (MkCgState absC binds
185 ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
186 = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
188 push_virt_a = virt_a + size
189 chosen_slot = virt_a + 1
190 new_a_usage = (push_virt_a, free_a, real_a, hw_a `max` push_virt_a)
191 -- Adjust high water mark
193 -- Allocate a chunk ON TOP OF the stack
194 allocBStackTop :: Int -> FCode VirtualSpBOffset
195 allocBStackTop size info_down (MkCgState absC binds
196 (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
197 = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
199 push_virt_b = virt_b + size
200 chosen_slot = virt_b+1
201 new_b_usage = (push_virt_b, free_b, real_b, hw_b `max` push_virt_b)
202 -- Adjust high water mark
205 @allocUpdateFrame@ allocates enough space for an update frame
206 on the B stack, records the fact in the end-of-block info (in the ``args''
207 fields), and passes on the old ``args'' fields to the enclosed code.
209 This is all a bit disgusting.
212 allocUpdateFrame :: Int -- Size of frame
213 -> CAddrMode -- Return address which is to be the
215 -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
219 allocUpdateFrame size update_amode code
220 (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
221 (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
224 InRetReg -> code (args_spa, args_spb, vB)
225 (MkCgInfoDown c_info statics new_eob_info)
226 (MkCgState absc binds new_usage)
228 other -> panic "allocUpdateFrame"
232 new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
233 new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
240 getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
241 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
243 state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
244 (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
248 %************************************************************************
250 \subsection[CgStackery-adjust]{Adjusting the stack pointers}
252 %************************************************************************
254 @adjustRealSpX@ generates code to alter the actual stack pointer, and
255 adjusts the environment accordingly. We are careful to push the
256 conditional inside the abstract C code to avoid black holes.
257 ToDo: combine together?
259 These functions {\em do not} deal with high-water-mark adjustment.
260 That's done by functions which allocate stack space.
263 adjustRealSpA :: VirtualSpAOffset -- New offset for Arg stack ptr
265 adjustRealSpA newRealSpA info_down (MkCgState absC binds
266 ((vspA,fA,realSpA,hwspA),
268 = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
270 move_instrA = if (newRealSpA == realSpA) then AbsCNop
273 (CAddr (SpARel realSpA newRealSpA)))
274 new_usage = ((vspA, fA, newRealSpA, hwspA),
277 adjustRealSpB :: VirtualSpBOffset -- New offset for Basic/Control stack ptr
279 adjustRealSpB newRealSpB info_down (MkCgState absC binds
281 (vspB,fB,realSpB,hwspB),
283 = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
285 move_instrB = if (newRealSpB == realSpB) then AbsCNop
286 else (CAssign {-PtrRep-}
288 (CAddr (SpBRel realSpB newRealSpB)))
289 new_usage = (a_usage,
290 (vspB, fB, newRealSpB, hwspB),
293 adjustRealSps :: VirtualSpAOffset -- New offset for Arg stack ptr
294 -> VirtualSpBOffset -- Ditto B stack
296 adjustRealSps newRealSpA newRealSpB
297 = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB