ghc/compiler/codeGen/CgStackery.lhs

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