2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgStackery.lhs,v 1.14 2000/01/14 11:45:21 hwloidl Exp $
6 \section[CgStackery]{Stack management functions}
8 Stack-twiddling operations, which are pretty low-down and grimy.
9 (This is the module that knows all about stack layouts, etc.)
13 allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
14 adjustStackHW, getFinalStackHW,
15 mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
16 freeStackSlots, dataStackSlots, addFreeSlots,
17 updateFrameSize, seqFrameSize
20 #include "HsVersions.h"
25 import CgUsages ( getRealSp )
26 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
27 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
28 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
29 import Panic ( panic )
30 import Constants ( uF_SIZE, sCC_UF_SIZE, gRAN_UF_SIZE,
31 sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE, gRAN_SEQ_FRAME_SIZE )
33 import IOExts ( trace )
36 %************************************************************************
38 \subsection[CgStackery-layout]{Laying out a stack frame}
40 %************************************************************************
42 @mkTaggedVirtStkOffsets@ is given a list of arguments. The first
43 argument gets the {\em largest} virtual stack offset (remember,
44 virtual offsets increase towards the top of stack). This function
45 also computes the correct tagging arrangement for standard function
46 entry points. Each non-pointer on the stack is preceded by a tag word
47 indicating the number of non-pointer words above it on the stack.
49 offset --> | | <---- last allocated stack word
53 | | total_nptrs (words)
57 offset + tot_nptrs + 1 --> | tag |
61 mkTaggedVirtStkOffsets
62 :: VirtualSpOffset -- Offset of the last allocated thing
63 -> (a -> PrimRep) -- to be able to grab kinds
64 -> [a] -- things to make offsets for
65 -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
66 [(a, VirtualSpOffset)], -- things with offsets
67 [(VirtualSpOffset,Int)]) -- offsets for tags
69 mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
70 = loop init_Sp_offset [] [] (reverse things)
72 loop offset tags offs [] = (offset,offs,tags)
73 loop offset tags offs (t:things)
74 | isFollowableRep (kind_fun t) =
75 loop (offset+1) tags ((t,offset+1):offs) things
78 size = getPrimRepSize (kind_fun t)
79 tag_slot = offset+size+1
81 loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
82 -- offset of thing is offset+size, because we're growing the stack
83 -- *downwards* as the offsets increase.
86 @mkTaggedStkAmodes@ is a higher-level version of
87 @mkTaggedVirtStkOffsets@. It starts from the tail-call locations. It
88 returns a single list of addressing modes for the stack locations, and
89 therefore is in the monad.
91 It *doesn't* adjust the high water mark.
95 :: VirtualSpOffset -- Tail call positions
96 -> [CAddrMode] -- things to make offsets for
97 -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
98 AbstractC, -- Assignments to appropriate stk slots
99 AbstractC) -- Assignments for tagging
101 mkTaggedStkAmodes tail_Sp things
102 = getRealSp `thenFC` \ realSp ->
104 (last_Sp_offset, offsets, tags)
105 = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
108 [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
109 | (thing, offset) <- offsets
113 [ CAssign (CVal (spRel realSp offset) WordRep)
114 (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
115 | (offset,size) <- tags
118 returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
120 mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
122 getRealSp `thenFC` \realSp ->
123 returnFC (mkAbstractCs
124 [ CAssign (CVal (spRel realSp offset) WordRep)
125 (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
126 | (offset,size) <- tags
131 %************************************************************************
133 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
135 %************************************************************************
137 Allocate a virtual offset for something.
140 allocStack :: FCode VirtualSpOffset
141 allocStack = allocPrimStack 1
143 allocPrimStack :: Int -> FCode VirtualSpOffset
144 allocPrimStack size info_down (MkCgState absC binds
145 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
146 = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage))
148 push_virt_sp = virt_sp + size
150 (chosen_slot, new_stk_usage)
151 = case find_block free_stk of
152 Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
153 hw_sp `max` push_virt_sp))
154 -- Adjust high water mark
156 Just slot -> (slot, (virt_sp,
157 delete_block free_stk slot, real_sp, hw_sp))
159 -- find_block looks for a contiguous chunk of free slots
160 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
161 find_block [] = Nothing
162 find_block ((off,free):slots)
163 | take size ((off,free):slots) ==
164 zip [off..top_slot] (repeat Free) = Just top_slot
165 | otherwise = find_block slots
166 -- The stack grows downwards, with increasing virtual offsets.
167 -- Therefore, the address of a multi-word object is the *highest*
168 -- virtual offset it occupies (top_slot below).
169 where top_slot = off+size-1
171 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
172 (s<=slot-size) || (s>slot) ]
173 -- Retain slots which are not in the range
177 Allocate a chunk ON TOP OF the stack.
179 ToDo: should really register this memory as NonPointer stuff in the
183 allocStackTop :: Int -> FCode VirtualSpOffset
184 allocStackTop size info_down (MkCgState absC binds
185 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
186 = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
188 push_virt_sp = virt_sp + size
189 new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
190 -- Adjust high water mark
193 Pop some words from the current top of stack. This is used for
194 de-allocating the return address in a case alternative.
197 deAllocStackTop :: Int -> FCode VirtualSpOffset
198 deAllocStackTop size info_down (MkCgState absC binds
199 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
200 = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
202 pop_virt_sp = virt_sp - size
203 new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
207 adjustStackHW :: VirtualSpOffset -> Code
208 adjustStackHW offset info_down (MkCgState absC binds usage)
209 = MkCgState absC binds new_usage
211 ((vSp,fSp,realSp,hwSp), h_usage) = usage
212 new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage)
213 -- No need to fiddle with virtual Sp etc because this call is
214 -- only done just before the end of a block
220 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
221 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
223 state1 = fcode hwSp info_down (MkCgState absC binds usages)
224 (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
228 updateFrameSize | opt_SccProfilingOn = sCC_UF_SIZE
229 | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
230 | otherwise = uF_SIZE
232 seqFrameSize | opt_SccProfilingOn = sCC_SEQ_FRAME_SIZE
233 | opt_GranMacros = gRAN_SEQ_FRAME_SIZE
234 | otherwise = sEQ_FRAME_SIZE
237 %************************************************************************
239 \subsection[CgStackery-free]{Free stack slots}
241 %************************************************************************
243 Explicitly free some stack space.
246 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
247 addFreeStackSlots extra_free slot info_down
248 state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
249 = MkCgState abs_c binds new_usage
251 new_usage = ((new_vsp, new_free, real, hw), heap_usage)
252 (new_vsp, new_free) = trim vsp all_free
253 all_free = addFreeSlots free (zip extra_free (repeat slot))
255 freeStackSlots :: [VirtualSpOffset] -> Code
256 freeStackSlots slots = addFreeStackSlots slots Free
258 dataStackSlots :: [VirtualSpOffset] -> Code
259 dataStackSlots slots = addFreeStackSlots slots NonPointer
261 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
262 addFreeSlots cs [] = cs
263 addFreeSlots [] ns = ns
264 addFreeSlots ((c,s):cs) ((n,s'):ns)
266 (c,s) : addFreeSlots cs ((n,s'):ns)
268 (n,s') : addFreeSlots ((c,s):cs) ns
269 else if s /= s' then -- c == n
270 (c,s') : addFreeSlots cs ns
272 panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
273 ++ show (n:map fst ns))
275 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
276 trim current_sp free_slots
277 = try current_sp free_slots
279 try csp [] = (csp,[])
281 try csp (slot@(off,state):slots) =
282 if state == Free && null slots' then
285 else if csp' == off then
292 (csp',slots') = try csp slots