ghc/compiler/codeGen/CgStackery.lhs

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