ghc/compiler/codeGen/CgStackery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgStackery.lhs,v 1.24 2003/11/17 14:42:47 simonmar Exp $
   5 %
   6 \section[CgStackery]{Stack management functions}
   7
   8 Stack-twiddling operations, which are pretty low-down and grimy.
   9 (This is the module that knows all about stack layouts, etc.)
  10
  11 \begin{code}
  12 module CgStackery (
  13         allocPrimStack, allocStackTop, deAllocStackTop,
  14         adjustStackHW, getFinalStackHW,
  15         setStackFrame, getStackFrame,
  16         mkVirtStkOffsets, mkStkAmodes,
  17         freeStackSlots, dataStackSlots,
  18         updateFrameSize,
  19         constructSlowCall, slowArgs,
  20     ) where
  21
  22 #include "HsVersions.h"
  23
  24 import CgMonad
  25 import AbsCSyn
  26 import CLabel           ( mkRtsApplyInfoLabel, mkRtsApplyEntryLabel )
  27
  28 import CgUsages         ( getRealSp )
  29 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  30 import PrimRep
  31 import CmdLineOpts      ( opt_SccProfilingOn, opt_GranMacros )
  32 import Constants
  33 import Util             ( sortLt )
  34 import FastString       ( LitString )
  35 import Panic
  36
  37 import TRACE            ( trace )
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection[CgStackery-layout]{Laying out a stack frame}
  43 %*                                                                      *
  44 %************************************************************************
  45
  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).
  49
  50 \begin{code}
  51 mkVirtStkOffsets
  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
  57
  58 mkVirtStkOffsets init_Sp_offset kind_fun things
  59     = loop init_Sp_offset [] (reverse things)
  60   where
  61     loop offset offs [] = (offset,offs)
  62     loop offset offs (t:things) =
  63              let
  64                  size = getPrimRepSize (kind_fun t)
  65                  thing_slot = offset + size
  66              in
  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.
  70
  71
  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
  76 -- high water mark.
  77
  78 mkStkAmodes
  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
  83
  84 mkStkAmodes tail_Sp things
  85   = getRealSp `thenFC` \ realSp ->
  86     let
  87       (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp getAmodeRep things
  88
  89       abs_cs =
  90           [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
  91           | (thing, offset) <- offsets
  92           ]
  93     in
  94     returnFC (last_Sp_offset, mkAbstractCs abs_cs)
  95 \end{code}
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{Pushing the arguments for a slow call}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 For a slow call, we must take a bunch of arguments and intersperse
 104 some stg_ap_<pattern>_ret_info return addresses.
 105
 106 \begin{code}
 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
 115
 116 stg_ap_0 = mkRtsApplyEntryLabel SLIT("0")
 117
 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]
 122 slowArgs [] = []
 123 slowArgs amodes = CLbl lbl RetRep : args ++ slowArgs rest
 124   where (tag, args, rest) = matchSlowPattern amodes
 125         lbl = mkRtsApplyInfoLabel tag
 126
 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
 132
 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"
 149
 150 #ifdef DEBUG
 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'
 157
 158 traceSlowCall amodes and_then
 159  = trace ("call: " ++ map primRepChar (map getAmodeRep amodes)) and_then
 160 #endif
 161 \end{code}
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 Allocate a virtual offset for something.
 170
 171 \begin{code}
 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
 182                    Just slot -> (slot,
 183                                   (virt_sp, frame,
 184                                    delete_block free_stk slot,
 185                                    real_sp, hw_sp))
 186         setUsage (new_stk_usage, h_usage)
 187         return chosen_slot
 188
 189         where
 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
 201
 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
 205                               -- slot-size+1..slot
 206 \end{code}
 207
 208 Allocate a chunk ON TOP OF the stack.
 209
 210 ToDo: should really register this memory as NonPointer stuff in the
 211 free list.
 212
 213 \begin{code}
 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)
 221         return push_virt_sp
 222 \end{code}
 223
 224 Pop some words from the current top of stack.  This is used for
 225 de-allocating the return address in a case alternative.
 226
 227 \begin{code}
 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)
 234         return pop_virt_sp
 235 \end{code}
 236
 237 \begin{code}
 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)
 242 \end{code}
 243
 244 A knot-tying beast.
 245
 246 \begin{code}
 247 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
 248 getFinalStackHW fcode = do
 249         fixC (\hwSp -> do
 250                 fcode hwSp
 251                 ((_,_,_,_, hwSp),_) <- getUsage
 252                 return hwSp)
 253         return ()
 254 \end{code}
 255
 256 \begin{code}
 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)
 261
 262 getStackFrame :: FCode VirtualSpOffset
 263 getStackFrame = do
 264         ((vSp,frame,fSp,realSp,hwSp), h_usage) <- getUsage
 265         return frame
 266 \end{code}
 267
 268 \begin{code}
 269 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
 270                 | opt_GranMacros     = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
 271                 | otherwise          = uF_SIZE
 272 \end{code}
 273
 274 %************************************************************************
 275 %*                                                                      *
 276 \subsection[CgStackery-free]{Free stack slots}
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 Explicitly free some stack space.
 281
 282 \begin{code}
 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)
 289         setUsage new_usage
 290
 291 freeStackSlots :: [VirtualSpOffset] -> Code
 292 freeStackSlots slots = addFreeStackSlots slots Free
 293
 294 dataStackSlots :: [VirtualSpOffset] -> Code
 295 dataStackSlots slots = addFreeStackSlots slots NonPointer
 296
 297 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
 298 addFreeSlots cs [] = cs
 299 addFreeSlots [] ns = ns
 300 addFreeSlots ((c,s):cs) ((n,s'):ns)
 301  = if c < n then
 302         (c,s) : addFreeSlots cs ((n,s'):ns)
 303    else if c > n then
 304         (n,s') : addFreeSlots ((c,s):cs) ns
 305    else if s /= s' then -- c == n
 306         (c,s') : addFreeSlots cs ns
 307    else
 308         panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
 309                                              ++ show (n:map fst ns))
 310
 311 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
 312 trim current_sp free_slots
 313   = try current_sp free_slots
 314   where
 315         try csp [] = (csp,[])
 316
 317         try csp (slot@(off,state):slots) =
 318                 if state == Free && null slots' then
 319                     if csp' < off then
 320                         (csp', [])
 321                     else if csp' == off then
 322                         (csp'-1, [])
 323                     else
 324                         (csp',[slot])
 325                 else
 326                     (csp', slot:slots')
 327                 where
 328                     (csp',slots') = try csp slots
 329 \end{code}