ghc/compiler/codeGen/CgStackery.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[CgStackery]{Stack management functions}
   5
   6 Stack-twiddling operations, which are pretty low-down and grimy.
   7 (This is the module that knows all about stack layouts, etc.)
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module CgStackery (
  13         allocAStack, allocBStack, allocUpdateFrame,
  14         adjustRealSps, getFinalStackHW,
  15         mkVirtStkOffsets, mkStkAmodes,
  16
  17         -- and to make the interface self-sufficient...
  18         AbstractC, CAddrMode, CgState, PrimKind
  19     ) where
  20
  21 import StgSyn
  22 import CgMonad
  23 import AbsCSyn
  24
  25 import CgUsages         ( getSpBRelOffset )
  26 import Maybes           ( Maybe(..) )
  27 import PrimKind         ( getKindSize, retKindSize, separateByPtrFollowness )
  28 import Util
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection[CgStackery-layout]{Laying out a stack frame}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 @mkVirtStkOffsets@ is given a list of arguments.  The first argument
  38 gets the {\em largest} virtual stack offset (remember, virtual offsets
  39 increase towards the top of stack).
  40
  41 \begin{code}
  42 mkVirtStkOffsets :: VirtualSpAOffset    -- Offset of the last allocated thing
  43           -> VirtualSpBOffset           -- ditto
  44           -> (a -> PrimKind)    -- to be able to grab kinds
  45           -> [a]                        -- things to make offsets for
  46           -> (VirtualSpAOffset,         -- OUTPUTS: Topmost allocated word
  47               VirtualSpBOffset,         -- ditto
  48               [(a, VirtualSpAOffset)],  --  boxed things with offsets
  49               [(a, VirtualSpBOffset)])  --  unboxed things with offsets
  50
  51 mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things
  52   = let (boxeds, unboxeds)
  53             = separateByPtrFollowness kind_fun things
  54         (last_SpA_offset, boxd_w_offsets)
  55             = mapAccumR computeOffset init_SpA_offset boxeds
  56         (last_SpB_offset, ubxd_w_offsets)
  57             = mapAccumR computeOffset init_SpB_offset unboxeds
  58     in
  59         (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
  60   where
  61     computeOffset offset thing
  62       = (offset + (getKindSize . kind_fun) thing, (thing, offset+(1::Int)))
  63 \end{code}
  64
  65 @mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
  66 It starts from the tail-call locations.
  67 It returns a single list of addressing modes for the stack locations,
  68 and therefore is in the monad.
  69
  70 It also adjusts the high water mark if necessary.
  71
  72 \begin{code}
  73 mkStkAmodes :: VirtualSpAOffset             -- Tail call positions
  74             -> VirtualSpBOffset
  75             -> [CAddrMode]                  -- things to make offsets for
  76             -> FCode (VirtualSpAOffset,     -- OUTPUTS: Topmost allocated word
  77                       VirtualSpBOffset,     -- ditto
  78                       AbstractC)            -- Assignments to appropriate stk slots
  79
  80 mkStkAmodes tail_spa tail_spb things
  81             info_down (MkCgState absC binds usage)
  82   = (result, MkCgState absC binds new_usage)
  83   where
  84     result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs)
  85
  86     (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets)
  87         = mkVirtStkOffsets tail_spa tail_spb getAmodeKind things
  88
  89     abs_cs
  90         = [ CAssign (CVal (SpARel realSpA offset) PtrKind) thing
  91           | (thing, offset) <- ptrs_w_offsets
  92           ]
  93           ++
  94           [ CAssign (CVal (SpBRel realSpB offset) (getAmodeKind thing)) thing
  95           | (thing, offset) <- non_ptrs_w_offsets
  96           ]
  97
  98     ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage
  99
 100     new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA),
 101                  (vspB,fspB,realSpB,max last_SpB_offset hwSpB),
 102                  h_usage)
 103     -- No need to fiddle with virtual SpA etc because this call is
 104     -- only done just before the end of a block
 105
 106
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 Allocate a virtual offset for something.
 116 \begin{code}
 117 allocAStack :: FCode VirtualSpAOffset
 118
 119 allocAStack info_down (MkCgState absC binds
 120                     ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
 121   = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
 122   where
 123     push_virt_a = virt_a + 1
 124
 125     (chosen_slot, new_a_usage)
 126         = if null free_a then
 127                 -- No free slots, so push a new one
 128                 -- We need to adjust the high-water mark
 129                 (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a))
 130           else
 131                 -- Free slots available, so use one
 132                 (free_slot, (virt_a, new_free_a, real_a, hw_a))
 133
 134     (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a)
 135                     -- Try to find an un-stubbed location;
 136                     -- if none, return the first in the free list
 137                     -- We'll only try this if free_a is known to be non-empty
 138
 139     -- Free list with the free_slot deleted
 140     new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ]
 141
 142 allocBStack :: Int -> FCode VirtualSpBOffset
 143 allocBStack size info_down (MkCgState absC binds
 144                                  (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
 145   = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
 146   where
 147     push_virt_b = virt_b + size
 148
 149     (chosen_slot, new_b_usage)
 150         = case find_block free_b of
 151                 Nothing -> (virt_b+1, (push_virt_b, free_b, real_b,
 152                                        hw_b `max` push_virt_b))
 153                                        -- Adjust high water mark
 154
 155                 Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b))
 156
 157     -- find_block looks for a contiguous chunk of free slots
 158     find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
 159     find_block [] = Nothing
 160     find_block (slot:slots)
 161       | take size (slot:slots) == take size (repeat slot)
 162       = Just slot
 163       | otherwise
 164       = find_block slots
 165
 166     delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
 167                               -- Retain slots which are not in the range
 168                               -- slot..slot+size-1
 169 \end{code}
 170
 171 @allocUpdateFrame@ allocates enough space for an update frame
 172 on the B stack, records the fact in the end-of-block info (in the ``args''
 173 fields), and passes on the old ``args'' fields to the enclosed code.
 174
 175 This is all a bit disgusting.
 176
 177 \begin{code}
 178 allocUpdateFrame :: Int                 -- Size of frame
 179                  -> CAddrMode           -- Return address which is to be the
 180                                         -- top word of frame
 181                  -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code)
 182                                                 -- Scope of update
 183                  -> Code
 184
 185 allocUpdateFrame size update_amode code
 186         (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel))
 187         (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage))
 188   = case sequel of
 189
 190         InRetReg -> code (args_spa, args_spb, vB)
 191                          (MkCgInfoDown c_info statics new_eob_info)
 192                          (MkCgState absc binds new_usage)
 193
 194         other    -> panic "allocUpdateFrame"
 195
 196   where
 197     new_vB = vB + size
 198     new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode)
 199     new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage)
 200 \end{code}
 201
 202
 203 A knot-tying beast.
 204
 205 \begin{code}
 206 getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code
 207 getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
 208   where
 209     state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages)
 210     (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection[CgStackery-adjust]{Adjusting the stack pointers}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 @adjustRealSpX@ generates code to alter the actual stack pointer, and
 221 adjusts the environment accordingly.  We are careful to push the
 222 conditional inside the abstract C code to avoid black holes.
 223 ToDo: combine together?
 224
 225 These functions {\em do not} deal with high-water-mark adjustment.
 226 That's done by functions which allocate stack space.
 227
 228 \begin{code}
 229 adjustRealSpA :: VirtualSpAOffset       -- New offset for Arg stack ptr
 230               -> Code
 231 adjustRealSpA newRealSpA info_down (MkCgState absC binds
 232                                         ((vspA,fA,realSpA,hwspA),
 233                                         b_usage, h_usage))
 234   = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage
 235     where
 236     move_instrA = if (newRealSpA == realSpA) then AbsCNop
 237                  else (CAssign
 238                             (CReg SpA)
 239                             (CAddr (SpARel realSpA newRealSpA)))
 240     new_usage = ((vspA, fA, newRealSpA, hwspA),
 241                  b_usage, h_usage)
 242
 243 adjustRealSpB :: VirtualSpBOffset       -- New offset for Basic/Control stack ptr
 244               -> Code
 245 adjustRealSpB newRealSpB info_down (MkCgState absC binds
 246                                         (a_usage,
 247                                         (vspB,fB,realSpB,hwspB),
 248                                         h_usage))
 249   = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage
 250     where
 251     move_instrB = if (newRealSpB == realSpB) then AbsCNop
 252                  else (CAssign {-PtrKind-}
 253                             (CReg SpB)
 254                             (CAddr (SpBRel realSpB newRealSpB)))
 255     new_usage = (a_usage,
 256                  (vspB, fB, newRealSpB, hwspB),
 257                  h_usage)
 258
 259 adjustRealSps :: VirtualSpAOffset       -- New offset for Arg stack ptr
 260               -> VirtualSpBOffset       -- Ditto B stack
 261               -> Code
 262 adjustRealSps newRealSpA newRealSpB
 263   = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB
 264 \end{code}