2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgStackery.lhs,v 1.24 2003/11/17 14:42:47 simonmar 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 allocPrimStack, allocStackTop, deAllocStackTop,
14 adjustStackHW, getFinalStackHW,
15 setStackFrame, getStackFrame,
16 mkVirtStkOffsets, mkStkAmodes,
17 freeStackSlots, dataStackSlots,
19 constructSlowCall, slowArgs,
22 #include "HsVersions.h"
26 import CLabel ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel )
28 import CgUsages ( getRealSp )
29 import AbsCUtils ( mkAbstractCs, getAmodeRep )
31 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
33 import Util ( sortLt )
34 import FastString ( LitString )
37 import TRACE ( trace )
40 %************************************************************************
42 \subsection[CgStackery-layout]{Laying out a stack frame}
44 %************************************************************************
46 'mkVirtStkOffsets' is given a list of arguments. The first argument
47 gets the /largest/ virtual stack offset (remember, virtual offsets
48 increase towards the top of stack).
52 :: VirtualSpOffset -- Offset of the last allocated thing
53 -> (a -> PrimRep) -- to be able to grab kinds
54 -> [a] -- things to make offsets for
55 -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
56 [(a, VirtualSpOffset)]) -- things with offsets
58 mkVirtStkOffsets init_Sp_offset kind_fun things
59 = loop init_Sp_offset [] (reverse things)
61 loop offset offs [] = (offset,offs)
62 loop offset offs (t:things) =
64 size = getPrimRepSize (kind_fun t)
65 thing_slot = offset + size
67 loop thing_slot ((t,thing_slot):offs) things
68 -- offset of thing is offset+size, because we're growing the stack
69 -- *downwards* as the offsets increase.
72 -- | 'mkStkAmodes' is a higher-level version of
73 -- 'mkVirtStkOffsets'. It starts from the tail-call locations.
74 -- It returns a single list of addressing modes for the stack
75 -- locations, and therefore is in the monad. It /doesn't/ adjust the
79 :: VirtualSpOffset -- Tail call positions
80 -> [CAddrMode] -- things to make offsets for
81 -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
82 AbstractC) -- Assignments to appropriate stk slots
84 mkStkAmodes tail_Sp things
85 = getRealSp `thenFC` \ realSp ->
87 (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things
90 [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
91 | (thing, offset) <- offsets
94 returnFC (last_Sp_offset, mkAbstractCs abs_cs)
97 %************************************************************************
99 \subsection{Pushing the arguments for a slow call}
101 %************************************************************************
103 For a slow call, we must take a bunch of arguments and intersperse
104 some stg_ap_<pattern>_ret_info return addresses.
107 constructSlowCall :: [CAddrMode] -> (CAddrMode, [CAddrMode])
108 -- don't forget the zero case
109 constructSlowCall [] = (CLbl stg_ap_0 CodePtrRep , [])
110 constructSlowCall amodes =
111 -- traceSlowCall amodes $
112 (CLbl lbl CodePtrRep, these ++ slowArgs rest)
113 where (tag, these, rest) = matchSlowPattern amodes
114 lbl = mkRtsApplyEntryLabel tag
116 stg_ap_0 = mkRtsApplyEntryLabel SLIT("0")
118 -- | 'slowArgs' takes a list of function arguments and prepares them for
119 -- pushing on the stack for "extra" arguments to a function which requires
120 -- fewer arguments than we currently have.
121 slowArgs :: [CAddrMode] -> [CAddrMode]
123 slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest
124 where (tag, args, rest) = matchSlowPattern amodes
125 lbl = mkRtsApplyInfoLabel tag
127 matchSlowPattern :: [CAddrMode] -> (LitString, [CAddrMode], [CAddrMode])
128 matchSlowPattern amodes = (tag, these, rest)
129 where reps = map getAmodeRep amodes
130 (tag, n) = findMatch (map primRepToArgRep reps)
131 (these, rest) = splitAt n amodes
133 -- These cases were found to cover about 99% of all slow calls:
134 findMatch (RepP: RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppppp"), 7)
135 findMatch (RepP: RepP: RepP: RepP: RepP: RepP: _) = (SLIT("pppppp"), 6)
136 findMatch (RepP: RepP: RepP: RepP: RepP: _) = (SLIT("ppppp"), 5)
137 findMatch (RepP: RepP: RepP: RepP: _) = (SLIT("pppp"), 4)
138 findMatch (RepP: RepP: RepP: _) = (SLIT("ppp"), 3)
139 findMatch (RepP: RepP: RepV: _) = (SLIT("ppv"), 3)
140 findMatch (RepP: RepP: _) = (SLIT("pp"), 2)
141 findMatch (RepP: RepV: _) = (SLIT("pv"), 2)
142 findMatch (RepP: _) = (SLIT("p"), 1)
143 findMatch (RepV: _) = (SLIT("v"), 1)
144 findMatch (RepN: _) = (SLIT("n"), 1)
145 findMatch (RepF: _) = (SLIT("f"), 1)
146 findMatch (RepD: _) = (SLIT("d"), 1)
147 findMatch (RepL: _) = (SLIT("l"), 1)
148 findMatch _ = panic "CgStackery.findMatch"
151 primRepChar p | isFollowableRep p = 'p'
152 primRepChar VoidRep = 'v'
153 primRepChar FloatRep = 'f'
154 primRepChar DoubleRep = 'd'
155 primRepChar p | getPrimRepSize p == 1 = 'n'
156 primRepChar p | is64BitRep p = 'l'
158 traceSlowCall amodes and_then
159 = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then
163 %************************************************************************
165 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
167 %************************************************************************
169 Allocate a virtual offset for something.
172 allocPrimStack :: Int -> FCode VirtualSpOffset
173 allocPrimStack size = do
174 ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage
175 let push_virt_sp = virt_sp + size
176 let (chosen_slot, new_stk_usage) =
177 case find_block free_stk of
178 Nothing -> (push_virt_sp,
179 (push_virt_sp, frame, free_stk, real_sp,
180 hw_sp `max` push_virt_sp))
181 -- Adjust high water mark
184 delete_block free_stk slot,
186 setUsage (new_stk_usage, h_usage)
190 -- find_block looks for a contiguous chunk of free slots
191 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
192 find_block [] = Nothing
193 find_block ((off,free):slots)
194 | take size ((off,free):slots) ==
195 zip [off..top_slot] (repeat Free) = Just top_slot
196 | otherwise = find_block slots
197 -- The stack grows downwards, with increasing virtual offsets.
198 -- Therefore, the address of a multi-word object is the *highest*
199 -- virtual offset it occupies (top_slot below).
200 where top_slot = off+size-1
202 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
203 (s<=slot-size) || (s>slot) ]
204 -- Retain slots which are not in the range
208 Allocate a chunk ON TOP OF the stack.
210 ToDo: should really register this memory as NonPointer stuff in the
214 allocStackTop :: Int -> FCode VirtualSpOffset
215 allocStackTop size = do
216 ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
217 let push_virt_sp = virt_sp + size
218 let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp,
219 hw_sp `max` push_virt_sp)
220 setUsage (new_stk_usage, h_usage)
224 Pop some words from the current top of stack. This is used for
225 de-allocating the return address in a case alternative.
228 deAllocStackTop :: Int -> FCode VirtualSpOffset
229 deAllocStackTop size = do
230 ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
231 let pop_virt_sp = virt_sp - size
232 let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp)
233 setUsage (new_stk_usage, h_usage)
238 adjustStackHW :: VirtualSpOffset -> Code
239 adjustStackHW offset = do
240 ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage
241 setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage)
247 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
248 getFinalStackHW fcode = do
251 ((_,_,_,_, hwSp),_) <- getUsage
257 setStackFrame :: VirtualSpOffset -> Code
258 setStackFrame offset = do
259 ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage
260 setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage)
262 getStackFrame :: FCode VirtualSpOffset
264 ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
269 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
270 | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
271 | otherwise = uF_SIZE
274 %************************************************************************
276 \subsection[CgStackery-free]{Free stack slots}
278 %************************************************************************
280 Explicitly free some stack space.
283 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
284 addFreeStackSlots extra_free slot = do
285 ((vsp, frame,free, real, hw),heap_usage) <- getUsage
286 let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
287 let (new_vsp, new_free) = trim vsp all_free
288 let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage)
291 freeStackSlots :: [VirtualSpOffset] -> Code
292 freeStackSlots slots = addFreeStackSlots slots Free
294 dataStackSlots :: [VirtualSpOffset] -> Code
295 dataStackSlots slots = addFreeStackSlots slots NonPointer
297 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
298 addFreeSlots cs [] = cs
299 addFreeSlots [] ns = ns
300 addFreeSlots ((c,s):cs) ((n,s'):ns)
302 (c,s) : addFreeSlots cs ((n,s'):ns)
304 (n,s') : addFreeSlots ((c,s):cs) ns
305 else if s /= s' then -- c == n
306 (c,s') : addFreeSlots cs ns
308 panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
309 ++ show (n:map fst ns))
311 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
312 trim current_sp free_slots
313 = try current_sp free_slots
315 try csp [] = (csp,[])
317 try csp (slot@(off,state):slots) =
318 if state == Free && null slots' then
321 else if csp' == off then
328 (csp',slots') = try csp slots