ghc/compiler/codeGen/CgStackery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgStackery.lhs,v 1.20 2001/10/03 13:57:42 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         allocStack, allocPrimStack, allocStackTop, deAllocStackTop,
  14         adjustStackHW, getFinalStackHW,
  15         mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
  16         freeStackSlots, dataStackSlots, addFreeSlots,
  17         updateFrameSize, seqFrameSize
  18     ) where
  19
  20 #include "HsVersions.h"
  21
  22 import CgMonad
  23 import AbsCSyn
  24
  25 import CgUsages         ( getRealSp )
  26 import AbsCUtils        ( mkAbstractCs, getAmodeRep )
  27 import PrimRep          ( getPrimRepSize, PrimRep(..), isFollowableRep )
  28 import CmdLineOpts      ( opt_SccProfilingOn, opt_GranMacros )
  29 import Panic            ( panic )
  30 import Constants        ( uF_SIZE, pROF_UF_SIZE, gRAN_UF_SIZE,
  31                           sEQ_FRAME_SIZE, pROF_SEQ_FRAME_SIZE,
  32                           gRAN_SEQ_FRAME_SIZE )
  33
  34 import Util             ( sortLt )
  35 import IOExts           ( trace )
  36 \end{code}
  37
  38 %************************************************************************
  39 %*                                                                      *
  40 \subsection[CgStackery-layout]{Laying out a stack frame}
  41 %*                                                                      *
  42 %************************************************************************
  43
  44 @mkTaggedVirtStkOffsets@ is given a list of arguments.  The first
  45 argument gets the {\em largest} virtual stack offset (remember,
  46 virtual offsets increase towards the top of stack).  This function
  47 also computes the correct tagging arrangement for standard function
  48 entry points.  Each non-pointer on the stack is preceded by a tag word
  49 indicating the number of non-pointer words above it on the stack.
  50
  51                 offset --> |       |  <---- last allocated stack word
  52                            ---------  <
  53                            |       |  .
  54                            ---------  .
  55                            |       |  total_nptrs (words)
  56                            ---------  .
  57                            |       |  .
  58                            ---------  <
  59 offset + tot_nptrs + 1 --> |  tag  |
  60                            ---------
  61
  62 \begin{code}
  63 mkTaggedVirtStkOffsets
  64           :: VirtualSpOffset    -- Offset of the last allocated thing
  65           -> (a -> PrimRep)     -- to be able to grab kinds
  66           -> [a]                        -- things to make offsets for
  67           -> (VirtualSpOffset,          -- OUTPUTS: Topmost allocated word
  68               [(a, VirtualSpOffset)],   -- things with offsets
  69               [(VirtualSpOffset,Int)])  -- offsets for tags
  70
  71 mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
  72     = loop init_Sp_offset [] [] (reverse things)
  73   where
  74     loop offset tags offs [] = (offset,offs,tags)
  75     loop offset tags offs (t:things)
  76          | isFollowableRep (kind_fun t) =
  77              loop (offset+1) tags ((t,offset+1):offs) things
  78          | otherwise =
  79              let
  80                  size = getPrimRepSize (kind_fun t)
  81                  tag_slot = offset+size+1
  82              in
  83              loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
  84     -- offset of thing is offset+size, because we're growing the stack
  85     -- *downwards* as the offsets increase.
  86 \end{code}
  87
  88 @mkTaggedStkAmodes@ is a higher-level version of
  89 @mkTaggedVirtStkOffsets@.  It starts from the tail-call locations.  It
  90 returns a single list of addressing modes for the stack locations, and
  91 therefore is in the monad.
  92
  93 It *doesn't* adjust the high water mark.
  94
  95 \begin{code}
  96 mkTaggedStkAmodes
  97         :: VirtualSpOffset          -- Tail call positions
  98         -> [CAddrMode]              -- things to make offsets for
  99         -> FCode (VirtualSpOffset,  -- OUTPUTS: Topmost allocated word
 100                   AbstractC,        -- Assignments to appropriate stk slots
 101                   AbstractC)        -- Assignments for tagging
 102
 103 mkTaggedStkAmodes tail_Sp things
 104   = getRealSp `thenFC` \ realSp ->
 105     let
 106       (last_Sp_offset, offsets, tags)
 107         = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
 108
 109       abs_cs =
 110           [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
 111           | (thing, offset) <- offsets
 112           ]
 113
 114       tag_cs =
 115           [ CAssign (CVal (spRel realSp offset) WordRep)
 116                     (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
 117           | (offset,size) <- tags
 118           ]
 119     in
 120     returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
 121
 122 mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
 123 mkTagAssts tags =
 124    getRealSp `thenFC` \realSp ->
 125    returnFC (mkAbstractCs
 126           [ CAssign (CVal (spRel realSp offset) WordRep)
 127                     (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
 128           | (offset,size) <- tags
 129           ])
 130
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 Allocate a virtual offset for something.
 140
 141 \begin{code}
 142 allocStack :: FCode VirtualSpOffset
 143 allocStack = allocPrimStack 1
 144
 145 allocPrimStack :: Int -> FCode VirtualSpOffset
 146 allocPrimStack size = do
 147         ((virt_sp, free_stk, real_sp, hw_sp),h_usage) <- getUsage
 148         let push_virt_sp = virt_sp + size
 149         let (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
 154                         Just slot -> (slot, (virt_sp,
 155                                                 delete_block free_stk slot, real_sp, hw_sp))
 156         setUsage (new_stk_usage, h_usage)
 157         return chosen_slot
 158
 159         where
 160                 -- find_block looks for a contiguous chunk of free slots
 161                 find_block :: [(VirtualSpOffset,Slot)] -> Maybe VirtualSpOffset
 162                 find_block [] = Nothing
 163                 find_block ((off,free):slots)
 164                         | take size ((off,free):slots) ==
 165                           zip [off..top_slot] (repeat Free) = Just top_slot
 166                         | otherwise                                = find_block slots
 167                                 -- The stack grows downwards, with increasing virtual offsets.
 168                                 -- Therefore, the address of a multi-word object is the *highest*
 169                                 -- virtual offset it occupies (top_slot below).
 170                         where top_slot = off+size-1
 171
 172                 delete_block free_stk slot = [ (s,f) | (s,f) <- free_stk,
 173                                            (s<=slot-size) || (s>slot) ]
 174                               -- Retain slots which are not in the range
 175                               -- slot-size+1..slot
 176 \end{code}
 177
 178 Allocate a chunk ON TOP OF the stack.
 179
 180 ToDo: should really register this memory as NonPointer stuff in the
 181 free list.
 182
 183 \begin{code}
 184 allocStackTop :: Int -> FCode VirtualSpOffset
 185 allocStackTop size = do
 186         ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
 187         let push_virt_sp = virt_sp + size
 188         let new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
 189         setUsage (new_stk_usage, h_usage)
 190         return push_virt_sp
 191 \end{code}
 192
 193 Pop some words from the current top of stack.  This is used for
 194 de-allocating the return address in a case alternative.
 195
 196 \begin{code}
 197 deAllocStackTop :: Int -> FCode VirtualSpOffset
 198 deAllocStackTop size = do
 199         ((virt_sp, free_stk, real_sp, hw_sp), h_usage) <- getUsage
 200         let pop_virt_sp = virt_sp - size
 201         let new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
 202         setUsage (new_stk_usage, h_usage)
 203         return pop_virt_sp
 204 \end{code}
 205
 206 \begin{code}
 207 adjustStackHW :: VirtualSpOffset -> Code
 208 adjustStackHW offset = do
 209         ((vSp,fSp,realSp,hwSp), h_usage) <- getUsage
 210         setUsage ((vSp, fSp, realSp, max offset hwSp), h_usage)
 211 \end{code}
 212
 213 A knot-tying beast.
 214
 215 \begin{code}
 216 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
 217 getFinalStackHW fcode = do
 218         fixC (\hwSp -> do
 219                 fcode hwSp
 220                 ((_,_,_, hwSp),_) <- getUsage
 221                 return hwSp)
 222         return ()
 223 \end{code}
 224
 225 \begin{code}
 226 updateFrameSize | opt_SccProfilingOn = pROF_UF_SIZE
 227                 | opt_GranMacros     = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
 228                 | otherwise          = uF_SIZE
 229
 230 seqFrameSize    | opt_SccProfilingOn  = pROF_SEQ_FRAME_SIZE
 231                 | opt_GranMacros      = gRAN_SEQ_FRAME_SIZE
 232                 | otherwise           = sEQ_FRAME_SIZE
 233 \end{code}
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection[CgStackery-free]{Free stack slots}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 Explicitly free some stack space.
 242
 243 \begin{code}
 244 addFreeStackSlots :: [VirtualSpOffset] -> Slot -> Code
 245 addFreeStackSlots extra_free slot = do
 246         ((vsp, free, real, hw),heap_usage) <- getUsage
 247         let all_free = addFreeSlots free (zip (sortLt (<) extra_free) (repeat slot))
 248         let (new_vsp, new_free) = trim vsp all_free
 249         let new_usage = ((new_vsp, new_free, real, hw), heap_usage)
 250         setUsage new_usage
 251
 252 freeStackSlots :: [VirtualSpOffset] -> Code
 253 freeStackSlots slots = addFreeStackSlots slots Free
 254
 255 dataStackSlots :: [VirtualSpOffset] -> Code
 256 dataStackSlots slots = addFreeStackSlots slots NonPointer
 257
 258 addFreeSlots :: [(Int,Slot)] -> [(Int,Slot)] -> [(Int,Slot)]
 259 addFreeSlots cs [] = cs
 260 addFreeSlots [] ns = ns
 261 addFreeSlots ((c,s):cs) ((n,s'):ns)
 262  = if c < n then
 263         (c,s) : addFreeSlots cs ((n,s'):ns)
 264    else if c > n then
 265         (n,s') : addFreeSlots ((c,s):cs) ns
 266    else if s /= s' then -- c == n
 267         (c,s') : addFreeSlots cs ns
 268    else
 269         panic ("addFreeSlots: equal slots: " ++ show (c:map fst cs)
 270                                              ++ show (n:map fst ns))
 271
 272 trim :: Int{-offset-} -> [(Int,Slot)] -> (Int{-offset-}, [(Int,Slot)])
 273 trim current_sp free_slots
 274   = try current_sp free_slots
 275   where
 276         try csp [] = (csp,[])
 277
 278         try csp (slot@(off,state):slots) =
 279                 if state == Free && null slots' then
 280                     if csp' < off then
 281                         (csp', [])
 282                     else if csp' == off then
 283                         (csp'-1, [])
 284                     else
 285                         (csp',[slot])
 286                 else
 287                     (csp', slot:slots')
 288                 where
 289                     (csp',slots') = try csp slots
 290 \end{code}