ghc/compiler/codeGen/CgStackery.lhs

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