2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgStackery.lhs,v 1.12 1999/06/24 13:04:20 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 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 )
29 import Panic ( panic )
30 import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE )
32 import IOExts ( trace )
35 %************************************************************************
37 \subsection[CgStackery-layout]{Laying out a stack frame}
39 %************************************************************************
41 @mkTaggedVirtStkOffsets@ is given a list of arguments. The first
42 argument gets the {\em largest} virtual stack offset (remember,
43 virtual offsets increase towards the top of stack). This function
44 also computes the correct tagging arrangement for standard function
45 entry points. Each non-pointer on the stack is preceded by a tag word
46 indicating the number of non-pointer words above it on the stack.
48 offset --> | | <---- last allocated stack word
52 | | total_nptrs (words)
56 offset + tot_nptrs + 1 --> | tag |
60 mkTaggedVirtStkOffsets
61 :: VirtualSpOffset -- Offset of the last allocated thing
62 -> (a -> PrimRep) -- to be able to grab kinds
63 -> [a] -- things to make offsets for
64 -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
65 [(a, VirtualSpOffset)], -- things with offsets
66 [(VirtualSpOffset,Int)]) -- offsets for tags
68 mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
69 = loop init_Sp_offset [] [] (reverse things)
71 loop offset tags offs [] = (offset,offs,tags)
72 loop offset tags offs (t:things)
73 | isFollowableRep (kind_fun t) =
74 loop (offset+1) tags ((t,offset+1):offs) things
77 size = getPrimRepSize (kind_fun t)
78 tag_slot = offset+size+1
80 loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
81 -- offset of thing is offset+size, because we're growing the stack
82 -- *downwards* as the offsets increase.
85 @mkTaggedStkAmodes@ is a higher-level version of
86 @mkTaggedVirtStkOffsets@. It starts from the tail-call locations. It
87 returns a single list of addressing modes for the stack locations, and
88 therefore is in the monad.
90 It *doesn't* adjust the high water mark.
94 :: VirtualSpOffset -- Tail call positions
95 -> [CAddrMode] -- things to make offsets for
96 -> FCode (VirtualSpOffset, -- OUTPUTS: Topmost allocated word
97 AbstractC, -- Assignments to appropriate stk slots
98 AbstractC) -- Assignments for tagging
100 mkTaggedStkAmodes tail_Sp things
101 = getRealSp `thenFC` \ realSp ->
103 (last_Sp_offset, offsets, tags)
104 = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
107 [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
108 | (thing, offset) <- offsets
112 [ CAssign (CVal (spRel realSp offset) WordRep)
113 (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
114 | (offset,size) <- tags
117 returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
119 mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
121 getRealSp `thenFC` \realSp ->
122 returnFC (mkAbstractCs
123 [ CAssign (CVal (spRel realSp offset) WordRep)
124 (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
125 | (offset,size) <- tags
130 %************************************************************************
132 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
134 %************************************************************************
136 Allocate a virtual offset for something.
139 allocStack :: FCode VirtualSpOffset
140 allocStack = allocPrimStack 1
142 allocPrimStack :: Int -> FCode VirtualSpOffset
143 allocPrimStack size info_down (MkCgState absC binds
144 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
145 = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage))
147 push_virt_sp = virt_sp + size
149 (chosen_slot, new_stk_usage)
150 = case find_block free_stk of
151 Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
152 hw_sp `max` push_virt_sp))
153 -- Adjust high water mark
155 Just slot -> (slot, (virt_sp,
156 delete_block free_stk slot, real_sp, hw_sp))
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 info_down (MkCgState absC binds
184 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
185 = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
187 push_virt_sp = virt_sp + size
188 new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
189 -- Adjust high water mark
192 Pop some words from the current top of stack. This is used for
193 de-allocating the return address in a case alternative.
196 deAllocStackTop :: Int -> FCode VirtualSpOffset
197 deAllocStackTop size info_down (MkCgState absC binds
198 ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
199 = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
201 pop_virt_sp = virt_sp - size
202 new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
206 adjustStackHW :: VirtualSpOffset -> Code
207 adjustStackHW offset info_down (MkCgState absC binds usage)
208 = MkCgState absC binds new_usage
210 ((vSp,fSp,realSp,hwSp), h_usage) = usage
211 new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage)
212 -- No need to fiddle with virtual Sp etc because this call is
213 -- only done just before the end of a block
219 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
220 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
222 state1 = fcode hwSp info_down (MkCgState absC binds usages)
223 (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
227 updateFrameSize | opt_SccProfilingOn = sCC_UF_SIZE
228 | otherwise = uF_SIZE
230 seqFrameSize | opt_SccProfilingOn = sCC_SEQ_FRAME_SIZE
231 | otherwise = sEQ_FRAME_SIZE
234 %************************************************************************
236 \subsection[CgStackery-free]{Free stack slots}
238 %************************************************************************
240 Explicitly free some stack space.
243 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
244 addFreeStackSlots extra_free slot info_down
245 state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
246 = MkCgState abs_c binds new_usage
248 new_usage = ((new_vsp, new_free, real, hw), heap_usage)
249 (new_vsp, new_free) = trim vsp all_free
250 all_free = addFreeSlots free (zip extra_free (repeat slot))
252 freeStackSlots :: [VirtualSpOffset] -> Code
253 freeStackSlots slots = addFreeStackSlots slots Free
255 dataStackSlots :: [VirtualSpOffset] -> Code
256 dataStackSlots slots = addFreeStackSlots slots NonPointer
258 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
259 addFreeSlots cs [] = cs
260 addFreeSlots [] ns = ns
261 addFreeSlots ((c,s):cs) ((n,s'):ns)
263 (c,s) : addFreeSlots cs ((n,s'):ns)
265 (n,s') : addFreeSlots ((c,s):cs) ns
266 else if s /= s' then -- c == n
267 (c,s') : addFreeSlots cs ns
269 panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
270 ++ show (n:map fst ns))
272 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
273 trim current_sp free_slots
274 = try current_sp free_slots
276 try csp [] = (csp,[])
278 try csp (slot@(off,state):slots) =
279 if state == Free && null slots' then
282 else if csp' == off then
289 (csp',slots') = try csp slots