ghc/compiler/codeGen/CgStackery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgStackery.lhs,v 1.9 1998/12/02 13:17:51 simonm 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         allocUpdateFrame,
  15         adjustRealSp, adjustStackHW, getFinalStackHW,
  16         mkTaggedVirtStkOffsets, mkTaggedStkAmodes, mkTagAssts,
  17         freeStackSlots, addFreeSlots
  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 Util             ( panic )
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection[CgStackery-layout]{Laying out a stack frame}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 @mkTaggedVirtStkOffsets@ is given a list of arguments.  The first
  38 argument gets the {\em largest} virtual stack offset (remember,
  39 virtual offsets increase towards the top of stack).  This function
  40 also computes the correct tagging arrangement for standard function
  41 entry points.  Each non-pointer on the stack is preceded by a tag word
  42 indicating the number of non-pointer words above it on the stack.
  43
  44                 offset --> |       |  <---- last allocated stack word
  45                            ---------  <
  46                            |       |  .
  47                            ---------  .
  48                            |       |  total_nptrs (words)
  49                            ---------  .
  50                            |       |  .
  51                            ---------  <
  52 offset + tot_nptrs + 1 --> |  tag  |
  53                            ---------
  54
  55 \begin{code}
  56 mkTaggedVirtStkOffsets
  57           :: VirtualSpOffset    -- Offset of the last allocated thing
  58           -> (a -> PrimRep)     -- to be able to grab kinds
  59           -> [a]                        -- things to make offsets for
  60           -> (VirtualSpOffset,          -- OUTPUTS: Topmost allocated word
  61               [(a, VirtualSpOffset)],   -- things with offsets
  62               [(VirtualSpOffset,Int)])  -- offsets for tags
  63
  64 mkTaggedVirtStkOffsets init_Sp_offset kind_fun things
  65     = loop init_Sp_offset [] [] (reverse things)
  66   where
  67     loop offset tags offs [] = (offset,offs,tags)
  68     loop offset tags offs (t:things)
  69          | isFollowableRep (kind_fun t) =
  70              loop (offset+1) tags ((t,offset+1):offs) things
  71          | otherwise =
  72              let
  73                  size = getPrimRepSize (kind_fun t)
  74                  tag_slot = offset+size+1
  75              in
  76              loop tag_slot ((tag_slot,size):tags) ((t,offset+size):offs) things
  77     -- offset of thing is offset+size, because we're growing the stack
  78     -- *downwards* as the offsets increase.
  79 \end{code}
  80
  81 @mkTaggedStkAmodes@ is a higher-level version of
  82 @mkTaggedVirtStkOffsets@.  It starts from the tail-call locations.  It
  83 returns a single list of addressing modes for the stack locations, and
  84 therefore is in the monad.
  85
  86 It *doesn't* adjust the high water mark.
  87
  88 \begin{code}
  89 mkTaggedStkAmodes
  90         :: VirtualSpOffset          -- Tail call positions
  91         -> [CAddrMode]              -- things to make offsets for
  92         -> FCode (VirtualSpOffset,  -- OUTPUTS: Topmost allocated word
  93                   AbstractC,        -- Assignments to appropriate stk slots
  94                   AbstractC)        -- Assignments for tagging
  95
  96 mkTaggedStkAmodes tail_Sp things
  97   = getRealSp `thenFC` \ realSp ->
  98     let
  99       (last_Sp_offset, offsets, tags)
 100         = mkTaggedVirtStkOffsets tail_Sp getAmodeRep things
 101
 102       abs_cs =
 103           [ CAssign (CVal (spRel realSp offset) (getAmodeRep thing)) thing
 104           | (thing, offset) <- offsets
 105           ]
 106
 107       tag_cs =
 108           [ CAssign (CVal (spRel realSp offset) WordRep)
 109                     (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
 110           | (offset,size) <- tags
 111           ]
 112     in
 113     returnFC (last_Sp_offset, mkAbstractCs abs_cs, mkAbstractCs tag_cs)
 114
 115 mkTagAssts :: [(VirtualSpOffset,Int)] -> FCode AbstractC
 116 mkTagAssts tags =
 117    getRealSp `thenFC` \realSp ->
 118    returnFC (mkAbstractCs
 119           [ CAssign (CVal (spRel realSp offset) WordRep)
 120                     (CMacroExpr WordRep ARG_TAG [mkIntCLit size])
 121           | (offset,size) <- tags
 122           ])
 123
 124 \end{code}
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 Allocate a virtual offset for something.
 133
 134 \begin{code}
 135 allocStack :: FCode VirtualSpOffset
 136 allocStack = allocPrimStack 1
 137
 138 allocPrimStack :: Int -> FCode VirtualSpOffset
 139 allocPrimStack size info_down (MkCgState absC binds
 140                                  ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
 141   = (chosen_slot, MkCgState absC binds (new_stk_usage, h_usage))
 142   where
 143     push_virt_sp = virt_sp + size
 144
 145     (chosen_slot, new_stk_usage)
 146         = case find_block free_stk of
 147                 Nothing -> (push_virt_sp, (push_virt_sp, free_stk, real_sp,
 148                                        hw_sp `max` push_virt_sp))
 149                                        -- Adjust high water mark
 150
 151                 Just slot -> (slot, (virt_sp,
 152                                     delete_block free_stk slot, real_sp, hw_sp))
 153
 154     -- find_block looks for a contiguous chunk of free slots
 155     find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
 156     find_block [] = Nothing
 157     find_block (slot:slots)
 158       | take size (slot:slots) == [slot..top_slot] = Just top_slot
 159       | otherwise                                  = find_block slots
 160         -- The stack grows downwards, with increasing virtual offsets.
 161         -- Therefore, the address of a multi-word object is the *highest*
 162         -- virtual offset it occupies (top_slot below).
 163       where top_slot = slot+size-1
 164
 165     delete_block free_stk slot = [s | s <- free_stk, (s<=slot-size) || (s>slot)]
 166                               -- Retain slots which are not in the range
 167                               -- slot-size+1..slot
 168
 169 -- Allocate a chunk ON TOP OF the stack
 170 allocStackTop :: Int -> FCode VirtualSpOffset
 171 allocStackTop size info_down (MkCgState absC binds
 172                              ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
 173   = (push_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
 174   where
 175     push_virt_sp = virt_sp + size
 176     new_stk_usage = (push_virt_sp, free_stk, real_sp, hw_sp `max` push_virt_sp)
 177                                                 -- Adjust high water mark
 178 \end{code}
 179
 180 Pop some words from the current top of stack.  This is used for
 181 de-allocating the return address in a case alternative.
 182
 183 \begin{code}
 184 deAllocStackTop :: Int -> FCode VirtualSpOffset
 185 deAllocStackTop size info_down (MkCgState absC binds
 186                              ((virt_sp, free_stk, real_sp, hw_sp), h_usage))
 187   = (pop_virt_sp, MkCgState absC binds (new_stk_usage, h_usage))
 188   where
 189     pop_virt_sp = virt_sp - size
 190     new_stk_usage = (pop_virt_sp, free_stk, real_sp, hw_sp)
 191 \end{code}
 192
 193 @allocUpdateFrame@ allocates enough space for an update frame on the
 194 stack, records the fact in the end-of-block info (in the ``args''
 195 fields), and passes on the old ``args'' fields to the enclosed code.
 196
 197 This is all a bit disgusting.
 198
 199 \begin{code}
 200 allocUpdateFrame :: Int                 -- Size of frame
 201                  -> Code                -- Scope of update
 202                  -> Code
 203
 204 allocUpdateFrame size code
 205         (MkCgInfoDown c_info statics srt (EndOfBlockInfo args_Sp sequel))
 206         (MkCgState absc binds ((vSp,rr,qq,hwSp),h_usage))
 207   = case sequel of
 208
 209         OnStack _ -> code (MkCgInfoDown c_info statics srt new_eob_info)
 210                           (MkCgState absc binds new_usage)
 211
 212         other     -> panic "allocUpdateFrame"
 213
 214   where
 215     new_vSp = vSp + size
 216     new_eob_info = EndOfBlockInfo new_vSp UpdateCode
 217     new_usage = ((new_vSp,rr,qq,hwSp `max` new_vSp), h_usage)
 218 \end{code}
 219
 220 \begin{code}
 221 adjustStackHW :: VirtualSpOffset -> Code
 222 adjustStackHW offset info_down (MkCgState absC binds usage)
 223   = MkCgState absC binds new_usage
 224   where
 225     ((vSp,fSp,realSp,hwSp), h_usage) = usage
 226     new_usage = ((vSp, fSp, realSp, max offset hwSp), h_usage)
 227     -- No need to fiddle with virtual Sp etc because this call is
 228     -- only done just before the end of a block
 229 \end{code}
 230
 231 A knot-tying beast.
 232
 233 \begin{code}
 234 getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
 235 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
 236   where
 237     state1 = fcode hwSp info_down (MkCgState absC binds usages)
 238     (MkCgState _ _ ((_,_,_, hwSp), _)) = state1
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsection[CgStackery-adjust]{Adjusting the stack pointers}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 @adjustRealSpX@ generates code to alter the actual stack pointer, and
 249 adjusts the environment accordingly.  We are careful to push the
 250 conditional inside the abstract C code to avoid black holes.
 251 ToDo: combine together?
 252
 253 These functions {\em do not} deal with high-water-mark adjustment.
 254 That's done by functions which allocate stack space.
 255
 256 \begin{code}
 257 adjustRealSp :: VirtualSpOffset         -- New offset for Arg stack ptr
 258               -> Code
 259 adjustRealSp newRealSp info_down (MkCgState absC binds
 260                                         ((vSp,fSp,realSp,hwSp), h_usage))
 261   = MkCgState (mkAbsCStmts absC move_instr) binds new_usage
 262     where
 263     move_instr = if (newRealSp == realSp) then AbsCNop
 264                  else (CAssign
 265                             (CReg Sp)
 266                             (CAddr (spRel realSp newRealSp)))
 267     new_usage = ((vSp, fSp, newRealSp, hwSp), h_usage)
 268 \end{code}
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection[CgStackery-free]{Free stack slots}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 Explicitly free some stack space.
 277
 278 \begin{code}
 279 freeStackSlots :: [VirtualSpOffset] -> Code
 280 freeStackSlots extra_free info_down
 281         state@(MkCgState abs_c binds ((vsp, free, real, hw), heap_usage))
 282   = MkCgState abs_c binds new_usage
 283   where
 284     new_usage = ((new_vsp, new_free, real, hw), heap_usage)
 285     (new_vsp, new_free) = trim vsp (addFreeSlots free extra_free)
 286
 287 addFreeSlots :: [Int] -> [Int] -> [Int]
 288 addFreeSlots cs [] = cs
 289 addFreeSlots [] ns = ns
 290 addFreeSlots (c:cs) (n:ns)
 291  = if c < n then
 292         c : addFreeSlots cs (n:ns)
 293    else if c > n then
 294         n : addFreeSlots (c:cs) ns
 295    else
 296         panic ("addFreeSlots: equal slots: " ++ show (c:cs) ++ show (n:ns))
 297
 298 trim :: Int{-offset-} -> [Int] -> (Int{-offset-}, [Int])
 299 trim current_sp free_slots
 300   = try current_sp (reverse free_slots)
 301   where
 302     try csp [] = (csp, [])
 303     try csp (slot:slots)
 304       = if csp < slot then
 305             try csp slots               -- Free slot off top of stk; ignore
 306
 307         else if csp == slot then
 308             try (csp-1) slots           -- Free slot at top of stk; trim
 309
 310         else
 311             (csp, reverse (slot:slots)) -- Otherwise gap; give up
 312 \end{code}