2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgStackery.lhs,v 1.23 2002/12/11 15:36:27 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 allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
14 adjustStackHW, getFinalStackHW,
15 setStackFrame, getStackFrame,
16 mkVirtStkOffsets, mkStkAmodes,
17 freeStackSlots, dataStackSlots, addFreeSlots,
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 allocStack :: FCode VirtualSpOffset
173 allocStack = allocPrimStack 1
175 allocPrimStack :: Int -> FCode VirtualSpOffset
176 allocPrimStack size = do
177 ((virt_sp, frame, free_stk, real_sp, hw_sp),h_usage) <- getUsage
178 let push_virt_sp = virt_sp + size
179 let (chosen_slot, new_stk_usage) =
180 case find_block free_stk of
181 Nothing -> (push_virt_sp,
182 (push_virt_sp, frame, free_stk, real_sp,
183 hw_sp `max` push_virt_sp))
184 -- Adjust high water mark
187 delete_block free_stk slot,
189 setUsage (new_stk_usage, h_usage)
193 -- find_block looks for a contiguous chunk of free slots
194 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
195 find_block [] = Nothing
196 find_block ((off,free):slots)
197 | take size ((off,free):slots) ==
198 zip [off..top_slot] (repeat Free) = Just top_slot
199 | otherwise = find_block slots
200 -- The stack grows downwards, with increasing virtual offsets.
201 -- Therefore, the address of a multi-word object is the *highest*
202 -- virtual offset it occupies (top_slot below).
203 where top_slot = off+size-1
205 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
206 (s<=slot-size) || (s>slot) ]
207 -- Retain slots which are not in the range
211 Allocate a chunk ON TOP OF the stack.
213 ToDo: should really register this memory as NonPointer stuff in the
217 allocStackTop :: Int -> FCode VirtualSpOffset
218 allocStackTop size = do
219 ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
220 let push_virt_sp = virt_sp + size
221 let new_stk_usage = (push_virt_sp, frame, free_stk, real_sp,
222 hw_sp `max` push_virt_sp)
223 setUsage (new_stk_usage, h_usage)
227 Pop some words from the current top of stack. This is used for
228 de-allocating the return address in a case alternative.
231 deAllocStackTop :: Int -> FCode VirtualSpOffset
232 deAllocStackTop size = do
233 ((virt_sp, frame, free_stk, real_sp, hw_sp), h_usage) <- getUsage
234 let pop_virt_sp = virt_sp - size
235 let new_stk_usage = (pop_virt_sp, frame, free_stk, real_sp, hw_sp)
236 setUsage (new_stk_usage, h_usage)
241 adjustStackHW :: VirtualSpOffset -> Code
242 adjustStackHW offset = do
243 ((vSp,fTop,fSp,realSp,hwSp), h_usage) <- getUsage
244 setUsage ((vSp, fTop, fSp, realSp, max offset hwSp), h_usage)
250 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
251 getFinalStackHW fcode = do
254 ((_,_,_,_, hwSp),_) <- getUsage
260 setStackFrame :: VirtualSpOffset -> Code
261 setStackFrame offset = do
262 ((vSp,_,fSp,realSp,hwSp), h_usage) <- getUsage
263 setUsage ((vSp, offset, fSp, realSp, hwSp), h_usage)
265 getStackFrame :: FCode VirtualSpOffset
267 ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
272 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
273 | opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
274 | otherwise = uF_SIZE
277 %************************************************************************
279 \subsection[CgStackery-free]{Free stack slots}
281 %************************************************************************
283 Explicitly free some stack space.
286 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
287 addFreeStackSlots extra_free slot = do
288 ((vsp, frame,free, real, hw),heap_usage) <- getUsage
289 let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
290 let (new_vsp, new_free) = trim vsp all_free
291 let new_usage = ((new_vsp, frame, new_free, real, hw), heap_usage)
294 freeStackSlots :: [VirtualSpOffset] -> Code
295 freeStackSlots slots = addFreeStackSlots slots Free
297 dataStackSlots :: [VirtualSpOffset] -> Code
298 dataStackSlots slots = addFreeStackSlots slots NonPointer
300 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
301 addFreeSlots cs [] = cs
302 addFreeSlots [] ns = ns
303 addFreeSlots ((c,s):cs) ((n,s'):ns)
305 (c,s) : addFreeSlots cs ((n,s'):ns)
307 (n,s') : addFreeSlots ((c,s):cs) ns
308 else if s /= s' then -- c == n
309 (c,s') : addFreeSlots cs ns
311 panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
312 ++ show (n:map fst ns))
314 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
315 trim current_sp free_slots
316 = try current_sp free_slots
318 try csp [] = (csp,[])
320 try csp (slot@(off,state):slots) =
321 if state == Free && null slots' then
324 else if csp' == off then
331 (csp',slots') = try csp slots