2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgStackery.lhs,v 1.22 2002/09/13 15:02:29 simonpj 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, getAmodeRep )
27 import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
28 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
29 import Panic ( panic )
31 import Util ( sortLt )
33 import TRACE ( 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 = do
145 ((virt_sp, free_stk, real_sp, hw_sp),h_usage) <- getUsage
146 let push_virt_sp = virt_sp + size
147 let (chosen_slot, new_stk_usage) =
148 case find_block free_stk of
149 Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
150 hw_sp `max` push_virt_sp))
151 -- Adjust high water mark
152 Just slot -> (slot, (virt_sp,
153 delete_block free_stk slot, real_sp, hw_sp))
154 setUsage (new_stk_usage, h_usage)
158 -- find_block looks for a contiguous chunk of free slots
159 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
160 find_block [] = Nothing
161 find_block ((off,free):slots)
162 | take size ((off,free):slots) ==
163 zip [off..top_slot] (repeat Free) = Just top_slot
164 | otherwise = find_block slots
165 -- The stack grows downwards, with increasing virtual offsets.
166 -- Therefore, the address of a multi-word object is the *highest*
167 -- virtual offset it occupies (top_slot below).
168 where top_slot = off+size-1
170 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
171 (s<=slot-size) || (s>slot) ]
172 -- Retain slots which are not in the range
176 Allocate a chunk ON TOP OF the stack.
178 ToDo: should really register this memory as NonPointer stuff in the
182 allocStackTop :: Int -> FCode VirtualSpOffset
183 allocStackTop size = do
184 ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
185 let push_virt_sp = virt_sp + size
186 let new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
187 setUsage (new_stk_usage, h_usage)
191 Pop some words from the current top of stack. This is used for
192 de-allocating the return address in a case alternative.
195 deAllocStackTop :: Int -> FCode VirtualSpOffset
196 deAllocStackTop size = do
197 ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
198 let pop_virt_sp = virt_sp - size
199 let new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
200 setUsage (new_stk_usage, h_usage)
205 adjustStackHW :: VirtualSpOffset -> Code
206 adjustStackHW offset = do
207 ((vSp,fSp,realSp,hwSp), h_usage) <- getUsage
208 setUsage ((vSp, fSp, realSp, max offset hwSp), h_usage)
214 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
215 getFinalStackHW fcode = do
218 ((_,_,_, hwSp),_) <- getUsage
224 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
225 | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
226 | otherwise = uF_SIZE
228 seqFrameSize | opt_SccProfilingOn = pROF_SEQ_FRAME_SIZE
229 | opt_GranMacros = gRAN_SEQ_FRAME_SIZE
230 | otherwise = sEQ_FRAME_SIZE
233 %************************************************************************
235 \subsection[CgStackery-free]{Free stack slots}
237 %************************************************************************
239 Explicitly free some stack space.
242 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
243 addFreeStackSlots extra_free slot = do
244 ((vsp, free, real, hw),heap_usage) <- getUsage
245 let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
246 let (new_vsp, new_free) = trim vsp all_free
247 let new_usage = ((new_vsp, new_free, real, hw), heap_usage)
250 freeStackSlots :: [VirtualSpOffset] -> Code
251 freeStackSlots slots = addFreeStackSlots slots Free
253 dataStackSlots :: [VirtualSpOffset] -> Code
254 dataStackSlots slots = addFreeStackSlots slots NonPointer
256 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
257 addFreeSlots cs [] = cs
258 addFreeSlots [] ns = ns
259 addFreeSlots ((c,s):cs) ((n,s'):ns)
261 (c,s) : addFreeSlots cs ((n,s'):ns)
263 (n,s') : addFreeSlots ((c,s):cs) ns
264 else if s /= s' then -- c == n
265 (c,s') : addFreeSlots cs ns
267 panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
268 ++ show (n:map fst ns))
270 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
271 trim current_sp free_slots
272 = try current_sp free_slots
274 try csp [] = (csp,[])
276 try csp (slot@(off,state):slots) =
277 if state == Free && null slots' then
280 else if csp' == off then
287 (csp',slots') = try csp slots