profiling fixes
[ghc.git] / compiler / codeGen / CgStackery.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[CgStackery]{Stack management functions}
6
7 Stack-twiddling operations, which are pretty low-down and grimy.
8 (This is the module that knows all about stack layouts, etc.)
9
10 \begin{code}
11 {-# OPTIONS -fno-warn-tabs #-}
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and
14 -- detab the module (please do the detabbing in a separate patch). See
15 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
16 -- for details
17
18 module CgStackery (
19         spRel, getVirtSp, getRealSp, setRealSp,
20         setRealAndVirtualSp, getSpRelOffset,
21
22         allocPrimStack, allocStackTop, deAllocStackTop,
23         adjustStackHW, getFinalStackHW, 
24         setStackFrame, getStackFrame,
25         mkVirtStkOffsets, mkStkAmodes,
26         freeStackSlots, 
27         pushUpdateFrame, pushBHUpdateFrame, emitPushUpdateFrame,
28     ) where
29
30 #include "HsVersions.h"
31
32 import CgMonad
33 import CgUtils
34 import CgProf
35 import ClosureInfo( CgRep(..), cgRepSizeW )
36 import SMRep
37 import OldCmm
38 import OldCmmUtils
39 import CLabel
40 import DynFlags
41 import Util
42 import OrdList
43 import Outputable
44
45 import Control.Monad
46 import Data.List
47 \end{code}
48
49 %************************************************************************
50 %*                                                                      *
51 \subsection[CgUsages-stackery]{Monad things for fiddling with stack usage}
52 %*                                                                      *
53 %************************************************************************
54
55 spRel is a little function that abstracts the stack direction.  Note that most
56 of the code generator is dependent on the stack direction anyway, so
57 changing this on its own spells certain doom.  ToDo: remove?
58
59         THIS IS DIRECTION SENSITIVE!
60
61 Stack grows down, positive virtual offsets correspond to negative
62 additions to the stack pointer.
63
64 \begin{code}
65 spRel :: VirtualSpOffset        -- virtual offset of Sp
66       -> VirtualSpOffset        -- virtual offset of The Thing
67       -> WordOff                -- integer offset
68 spRel sp off = sp - off
69 \end{code}
70
71 @setRealAndVirtualSp@ sets into the environment the offsets of the
72 current position of the real and virtual stack pointers in the current
73 stack frame.  The high-water mark is set too.  It generates no code.
74 It is used to initialise things at the beginning of a closure body.
75
76 \begin{code}
77 setRealAndVirtualSp :: VirtualSpOffset  -- New real Sp
78                      -> Code
79
80 setRealAndVirtualSp new_sp 
81   = do  { stk_usg <- getStkUsage
82         ; setStkUsage (stk_usg {virtSp = new_sp, 
83                                 realSp = new_sp, 
84                                 hwSp   = new_sp}) }
85
86 getVirtSp :: FCode VirtualSpOffset
87 getVirtSp
88   = do  { stk_usg <- getStkUsage
89         ; return (virtSp stk_usg) }
90
91 getRealSp :: FCode VirtualSpOffset
92 getRealSp
93   = do  { stk_usg <- getStkUsage
94         ; return (realSp stk_usg) }
95
96 setRealSp :: VirtualSpOffset -> Code
97 setRealSp new_real_sp
98   = do  { stk_usg <- getStkUsage
99         ; setStkUsage (stk_usg {realSp = new_real_sp}) }
100
101 getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr
102 getSpRelOffset virtual_offset
103   = do dflags <- getDynFlags
104        real_sp <- getRealSp
105        return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset))
106 \end{code}
107
108
109 %************************************************************************
110 %*                                                                      *
111 \subsection[CgStackery-layout]{Laying out a stack frame}
112 %*                                                                      *
113 %************************************************************************
114
115 'mkVirtStkOffsets' is given a list of arguments.  The first argument
116 gets the /largest/ virtual stack offset (remember, virtual offsets
117 increase towards the top of stack).
118
119 \begin{code}
120 mkVirtStkOffsets
121           :: DynFlags
122           -> VirtualSpOffset    -- Offset of the last allocated thing
123           -> [(CgRep,a)]                -- things to make offsets for
124           -> (VirtualSpOffset,          -- OUTPUTS: Topmost allocated word
125               [(a, VirtualSpOffset)])   -- things with offsets (voids filtered out)
126
127 mkVirtStkOffsets dflags init_Sp_offset things
128     = loop init_Sp_offset [] (reverse things)
129   where
130     loop offset offs [] = (offset,offs)
131     loop offset offs ((VoidArg,_):things) = loop offset offs things
132         -- ignore Void arguments
133     loop offset offs ((rep,t):things)
134         = loop thing_slot ((t,thing_slot):offs) things
135         where
136           thing_slot = offset + cgRepSizeW dflags rep
137             -- offset of thing is offset+size, because we're 
138             -- growing the stack *downwards* as the offsets increase.
139
140 -- | 'mkStkAmodes' is a higher-level version of
141 -- 'mkVirtStkOffsets'.  It starts from the tail-call locations.
142 -- It returns a single list of addressing modes for the stack
143 -- locations, and therefore is in the monad.  It /doesn't/ adjust the
144 -- high water mark.
145
146 mkStkAmodes 
147         :: VirtualSpOffset          -- Tail call positions
148         -> [(CgRep,CmmExpr)]        -- things to make offsets for
149         -> FCode (VirtualSpOffset,  -- OUTPUTS: Topmost allocated word
150                   CmmStmts)         -- Assignments to appropriate stk slots
151
152 mkStkAmodes tail_Sp things
153   = do dflags <- getDynFlags
154        rSp <- getRealSp
155        let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things
156            abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode
157                     | (amode, offset) <- offsets
158                     ]
159        returnFC (last_Sp_offset, toOL abs_cs)
160 \end{code}
161
162 %************************************************************************
163 %*                                                                      *
164 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
165 %*                                                                      *
166 %************************************************************************
167
168 Allocate a virtual offset for something.
169
170 \begin{code}
171 allocPrimStack :: CgRep -> FCode VirtualSpOffset
172 allocPrimStack rep = do dflags <- getDynFlags
173                         allocPrimStack' dflags rep
174
175 allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset
176 allocPrimStack' dflags rep
177   = do  { stk_usg <- getStkUsage
178         ; let free_stk = freeStk stk_usg
179         ; case find_block free_stk of
180              Nothing -> do 
181                 { let push_virt_sp = virtSp stk_usg + size
182                 ; setStkUsage (stk_usg { virtSp = push_virt_sp,
183                                          hwSp   = hwSp stk_usg `max` push_virt_sp })
184                                                 -- Adjust high water mark
185                 ; return push_virt_sp }
186              Just slot -> do
187                 { setStkUsage (stk_usg { freeStk = delete_block free_stk slot }) 
188                 ; return slot }
189         }
190   where
191     size :: WordOff
192     size = cgRepSizeW dflags rep
193
194         -- Find_block looks for a contiguous chunk of free slots
195         -- returning the offset of its topmost word
196     find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
197     find_block [] = Nothing
198     find_block (slot:slots)
199         | take size (slot:slots) == [slot..top_slot]
200         = Just top_slot
201         | otherwise
202         = find_block slots
203         where   -- The stack grows downwards, with increasing virtual offsets.
204                 -- Therefore, the address of a multi-word object is the *highest*
205                 -- virtual offset it occupies (top_slot below).
206             top_slot = slot+size-1
207
208     delete_block free_stk slot = [ s | s <- free_stk, 
209                                        (s<=slot-size) || (s>slot) ]
210                       -- Retain slots which are not in the range
211                       -- slot-size+1..slot
212 \end{code}
213
214 Allocate a chunk ON TOP OF the stack.  
215
216 \begin{code}
217 allocStackTop :: WordOff -> FCode ()
218 allocStackTop size
219   = do  { stk_usg <- getStkUsage
220         ; let push_virt_sp = virtSp stk_usg + size
221         ; setStkUsage (stk_usg { virtSp = push_virt_sp,
222                                  hwSp   = hwSp stk_usg `max` push_virt_sp }) }
223 \end{code}
224
225 Pop some words from the current top of stack.  This is used for
226 de-allocating the return address in a case alternative.
227
228 \begin{code}
229 deAllocStackTop :: WordOff -> FCode ()
230 deAllocStackTop size
231   = do  { stk_usg <- getStkUsage
232         ; let pop_virt_sp = virtSp stk_usg - size
233         ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) }
234 \end{code}
235
236 \begin{code}
237 adjustStackHW :: VirtualSpOffset -> Code
238 adjustStackHW offset
239   = do  { stk_usg <- getStkUsage
240         ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) }
241 \end{code}
242
243 A knot-tying beast.
244
245 \begin{code}
246 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
247 getFinalStackHW fcode
248   = do  { fixC_ (\hw_sp -> do
249                 { fcode hw_sp
250                 ; stk_usg <- getStkUsage
251                 ; return (hwSp stk_usg) })
252         ; return () }
253 \end{code}
254
255 \begin{code}
256 setStackFrame :: VirtualSpOffset -> Code
257 setStackFrame offset
258   = do  { stk_usg <- getStkUsage
259         ; setStkUsage (stk_usg { frameSp = offset }) }
260
261 getStackFrame :: FCode VirtualSpOffset
262 getStackFrame
263   = do  { stk_usg <- getStkUsage
264         ; return (frameSp stk_usg) }
265 \end{code}
266
267
268 %********************************************************
269 %*                                                      *
270 %*              Setting up update frames                *
271 %*                                                      *
272 %********************************************************
273
274 @pushUpdateFrame@ $updatee$ pushes a general update frame which
275 points to $updatee$ as the thing to be updated.  It is only used
276 when a thunk has just been entered, so the (real) stack pointers
277 are guaranteed to be nicely aligned with the top of stack.
278 @pushUpdateFrame@ adjusts the virtual and tail stack pointers
279 to reflect the frame pushed.
280
281 \begin{code}
282 pushUpdateFrame :: CmmExpr -> Code -> Code
283 pushUpdateFrame updatee code
284   = pushSpecUpdateFrame mkUpdInfoLabel updatee code
285
286 pushBHUpdateFrame :: CmmExpr -> Code -> Code
287 pushBHUpdateFrame updatee code
288   = pushSpecUpdateFrame mkBHUpdInfoLabel updatee code
289
290 pushSpecUpdateFrame :: CLabel -> CmmExpr -> Code -> Code
291 pushSpecUpdateFrame lbl updatee code
292   = do  {
293       when debugIsOn $ do
294         { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ;
295         ; MASSERT(case sequel of { OnStack -> True; _ -> False}) }
296         ; dflags <- getDynFlags
297         ; allocStackTop (fixedHdrSize dflags + 
298                            sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE dflags)
299         ; vsp <- getVirtSp
300         ; setStackFrame vsp
301         ; frame_addr <- getSpRelOffset vsp
302                 -- The location of the lowest-address
303                 -- word of the update frame itself
304
305                 -- NB. we used to set the Sequel to 'UpdateCode' so
306                 -- that we could jump directly to the update code if
307                 -- we know that the next frame on the stack is an
308                 -- update frame.  However, the RTS can sometimes
309                 -- change an update frame into something else (see
310                 -- e.g. Note [upd-black-hole] in rts/sm/Scav.c), so we
311                 -- no longer make this assumption.
312         ; setEndOfBlockInfo (EndOfBlockInfo vsp OnStack) $
313             do  { emitSpecPushUpdateFrame lbl frame_addr updatee
314                 ; code }
315         }
316
317 emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code
318 emitPushUpdateFrame = emitSpecPushUpdateFrame mkUpdInfoLabel
319
320 emitSpecPushUpdateFrame :: CLabel -> CmmExpr -> CmmExpr -> Code
321 emitSpecPushUpdateFrame lbl frame_addr updatee = do
322         dflags <- getDynFlags
323         stmtsC [  -- Set the info word
324                   CmmStore frame_addr (mkLblExpr lbl)
325                 , -- And the updatee
326                   CmmStore (cmmOffsetB dflags frame_addr (off_updatee dflags)) updatee ]
327         initUpdFrameProf frame_addr
328
329 off_updatee :: DynFlags -> ByteOff
330 off_updatee dflags
331     = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgUpdateFrame_updatee dflags
332 \end{code}
333
334
335 %************************************************************************
336 %*                                                                      *
337 \subsection[CgStackery-free]{Free stack slots}
338 %*                                                                      *
339 %************************************************************************
340
341 Explicitly free some stack space.
342
343 \begin{code}
344 freeStackSlots :: [VirtualSpOffset] -> Code
345 freeStackSlots extra_free
346   = do  { stk_usg <- getStkUsage
347         ; let all_free = addFreeSlots (freeStk stk_usg) (sort extra_free)
348         ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free
349         ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) }
350
351 addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset]
352 -- Merge the two, assuming both are in increasing order
353 addFreeSlots cs [] = cs
354 addFreeSlots [] ns = ns
355 addFreeSlots (c:cs) (n:ns)
356   | c < n     = c : addFreeSlots cs (n:ns)
357   | otherwise = n : addFreeSlots (c:cs) ns
358
359 trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset])
360 -- Try to trim back the virtual stack pointer, where there is a
361 -- continuous bunch of free slots at the end of the free list
362 trim vsp [] = (vsp, [])
363 trim vsp (slot:slots)
364   = case trim vsp slots of
365       (vsp', []) 
366         | vsp' < slot  -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots))
367                           (vsp',   [])
368         | vsp' == slot -> (vsp'-1, [])
369         | otherwise    -> (vsp',   [slot])
370       (vsp', slots')   -> (vsp',   slot:slots')
371 \end{code}