compiler/codeGen/CgCallConv.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2004-2006
   4 --
   5 -- CgCallConv
   6 --
   7 -- The datatypes and functions here encapsulate the
   8 -- calling and return conventions used by the code generator.
   9 --
  10 -----------------------------------------------------------------------------
  11
  12
  13 module CgCallConv (
  14         -- Argument descriptors
  15         mkArgDescr, argDescrType,
  16
  17         -- Liveness
  18         isBigLiveness, buildContLiveness, mkRegLiveness,
  19         smallLiveness, mkLivenessCLit,
  20
  21         -- Register assignment
  22         assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
  23
  24         -- Calls
  25         constructSlowCall, slowArgs, slowCallPattern,
  26
  27         -- Returns
  28         dataReturnConvPrim,
  29         getSequelAmode
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import CgUtils
  35 import CgMonad
  36 import SMRep
  37
  38 import MachOp
  39 import Cmm
  40 import CLabel
  41
  42 import Constants
  43 import ClosureInfo
  44 import CgStackery
  45 import CmmUtils
  46 import Maybes
  47 import Id
  48 import Name
  49 import Bitmap
  50 import Util
  51 import StaticFlags
  52 import FastString
  53 import Outputable
  54
  55 import Data.Bits
  56
  57 -------------------------------------------------------------------------
  58 --
  59 --      Making argument descriptors
  60 --
  61 --  An argument descriptor describes the layout of args on the stack,
  62 --  both for    * GC (stack-layout) purposes, and
  63 --              * saving/restoring registers when a heap-check fails
  64 --
  65 -- Void arguments aren't important, therefore (contrast constructSlowCall)
  66 --
  67 -------------------------------------------------------------------------
  68
  69 -- bring in ARG_P, ARG_N, etc.
  70 #include "../includes/StgFun.h"
  71
  72 -------------------------
  73 argDescrType :: ArgDescr -> Int
  74 -- The "argument type" RTS field type
  75 argDescrType (ArgSpec n) = n
  76 argDescrType (ArgGen liveness)
  77   | isBigLiveness liveness = ARG_GEN_BIG
  78   | otherwise              = ARG_GEN
  79
  80
  81 mkArgDescr :: Name -> [Id] -> FCode ArgDescr
  82 mkArgDescr nm args
  83   = case stdPattern arg_reps of
  84         Just spec_id -> return (ArgSpec spec_id)
  85         Nothing      -> do { liveness <- mkLiveness nm size bitmap
  86                            ; return (ArgGen liveness) }
  87   where
  88     arg_reps = filter nonVoidArg (map idCgRep args)
  89         -- Getting rid of voids eases matching of standard patterns
  90
  91     bitmap   = mkBitmap arg_bits
  92     arg_bits = argBits arg_reps
  93     size     = length arg_bits
  94
  95 argBits :: [CgRep] -> [Bool]    -- True for non-ptr, False for ptr
  96 argBits []              = []
  97 argBits (PtrArg : args) = False : argBits args
  98 argBits (arg    : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
  99
 100 stdPattern :: [CgRep] -> Maybe Int
 101 stdPattern []          = Just ARG_NONE  -- just void args, probably
 102
 103 stdPattern [PtrArg]    = Just ARG_P
 104 stdPattern [FloatArg]  = Just ARG_F
 105 stdPattern [DoubleArg] = Just ARG_D
 106 stdPattern [LongArg]   = Just ARG_L
 107 stdPattern [NonPtrArg] = Just ARG_N
 108
 109 stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN
 110 stdPattern [NonPtrArg,PtrArg]    = Just ARG_NP
 111 stdPattern [PtrArg,NonPtrArg]    = Just ARG_PN
 112 stdPattern [PtrArg,PtrArg]       = Just ARG_PP
 113
 114 stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN
 115 stdPattern [NonPtrArg,NonPtrArg,PtrArg]    = Just ARG_NNP
 116 stdPattern [NonPtrArg,PtrArg,NonPtrArg]    = Just ARG_NPN
 117 stdPattern [NonPtrArg,PtrArg,PtrArg]       = Just ARG_NPP
 118 stdPattern [PtrArg,NonPtrArg,NonPtrArg]    = Just ARG_PNN
 119 stdPattern [PtrArg,NonPtrArg,PtrArg]       = Just ARG_PNP
 120 stdPattern [PtrArg,PtrArg,NonPtrArg]       = Just ARG_PPN
 121 stdPattern [PtrArg,PtrArg,PtrArg]          = Just ARG_PPP
 122
 123 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg]               = Just ARG_PPPP
 124 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg]        = Just ARG_PPPPP
 125 stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP
 126 stdPattern other = Nothing
 127
 128
 129 -------------------------------------------------------------------------
 130 --
 131 --      Liveness info
 132 --
 133 -------------------------------------------------------------------------
 134
 135 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
 136 mkLiveness name size bits
 137   | size > mAX_SMALL_BITMAP_SIZE                -- Bitmap does not fit in one word
 138   = do  { let lbl = mkBitmapLabel name
 139         ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
 140                              : map mkWordCLit bits)
 141         ; return (BigLiveness lbl) }
 142
 143   | otherwise           -- Bitmap fits in one word
 144   = let
 145         small_bits = case bits of
 146                         []  -> 0
 147                         [b] -> fromIntegral b
 148                         _   -> panic "livenessToAddrMode"
 149     in
 150     return (smallLiveness size small_bits)
 151
 152 smallLiveness :: Int -> StgWord -> Liveness
 153 smallLiveness size small_bits = SmallLiveness bits
 154   where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
 155
 156 -------------------
 157 isBigLiveness :: Liveness -> Bool
 158 isBigLiveness (BigLiveness _)   = True
 159 isBigLiveness (SmallLiveness _) = False
 160
 161 -------------------
 162 mkLivenessCLit :: Liveness -> CmmLit
 163 mkLivenessCLit (BigLiveness lbl)    = CmmLabel lbl
 164 mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
 165
 166
 167 -------------------------------------------------------------------------
 168 --
 169 --              Bitmap describing register liveness
 170 --              across GC when doing a "generic" heap check
 171 --              (a RET_DYN stack frame).
 172 --
 173 -- NB. Must agree with these macros (currently in StgMacros.h):
 174 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
 175 -------------------------------------------------------------------------
 176
 177 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
 178 mkRegLiveness regs ptrs nptrs
 179   = (fromIntegral nptrs `shiftL` 16) .|.
 180     (fromIntegral ptrs  `shiftL` 24) .|.
 181     all_non_ptrs `xor` reg_bits regs
 182   where
 183     all_non_ptrs = 0xff
 184
 185     reg_bits [] = 0
 186     reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
 187         = (1 `shiftL` (i - 1)) .|. reg_bits regs
 188     reg_bits (_ : regs)
 189         = reg_bits regs
 190
 191 -------------------------------------------------------------------------
 192 --
 193 --              Pushing the arguments for a slow call
 194 --
 195 -------------------------------------------------------------------------
 196
 197 -- For a slow call, we must take a bunch of arguments and intersperse
 198 -- some stg_ap_<pattern>_ret_info return addresses.
 199 constructSlowCall
 200         :: [(CgRep,CmmExpr)]
 201         -> (CLabel,             -- RTS entry point for call
 202            [(CgRep,CmmExpr)],   -- args to pass to the entry point
 203            [(CgRep,CmmExpr)])   -- stuff to save on the stack
 204
 205    -- don't forget the zero case
 206 constructSlowCall []
 207   = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
 208
 209 constructSlowCall amodes
 210   = (stg_ap_pat, these, rest)
 211   where
 212     stg_ap_pat = mkRtsApFastLabel arg_pat
 213     (arg_pat, these, rest) = matchSlowPattern amodes
 214
 215 -- | 'slowArgs' takes a list of function arguments and prepares them for
 216 -- pushing on the stack for "extra" arguments to a function which requires
 217 -- fewer arguments than we currently have.
 218 slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
 219 slowArgs [] = []
 220 slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
 221   where (arg_pat, args, rest) = matchSlowPattern amodes
 222         stg_ap_pat = mkRtsRetInfoLabel arg_pat
 223
 224 matchSlowPattern :: [(CgRep,CmmExpr)]
 225                  -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
 226 matchSlowPattern amodes = (arg_pat, these, rest)
 227   where (arg_pat, n)  = slowCallPattern (map fst amodes)
 228         (these, rest) = splitAt n amodes
 229
 230 -- These cases were found to cover about 99% of all slow calls:
 231 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
 232 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _)     = (SLIT("stg_ap_ppppp"), 5)
 233 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _)     = (SLIT("stg_ap_pppp"), 4)
 234 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _)    = (SLIT("stg_ap_pppv"), 4)
 235 slowCallPattern (PtrArg: PtrArg: PtrArg: _)             = (SLIT("stg_ap_ppp"), 3)
 236 slowCallPattern (PtrArg: PtrArg: VoidArg: _)            = (SLIT("stg_ap_ppv"), 3)
 237 slowCallPattern (PtrArg: PtrArg: _)                     = (SLIT("stg_ap_pp"), 2)
 238 slowCallPattern (PtrArg: VoidArg: _)                    = (SLIT("stg_ap_pv"), 2)
 239 slowCallPattern (PtrArg: _)                             = (SLIT("stg_ap_p"), 1)
 240 slowCallPattern (VoidArg: _)                            = (SLIT("stg_ap_v"), 1)
 241 slowCallPattern (NonPtrArg: _)                          = (SLIT("stg_ap_n"), 1)
 242 slowCallPattern (FloatArg: _)                           = (SLIT("stg_ap_f"), 1)
 243 slowCallPattern (DoubleArg: _)                          = (SLIT("stg_ap_d"), 1)
 244 slowCallPattern (LongArg: _)                            = (SLIT("stg_ap_l"), 1)
 245 slowCallPattern _  = panic "CgStackery.slowCallPattern"
 246
 247 -------------------------------------------------------------------------
 248 --
 249 --              Return conventions
 250 --
 251 -------------------------------------------------------------------------
 252
 253 dataReturnConvPrim :: CgRep -> CmmReg
 254 dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1)
 255 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
 256 dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
 257 dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
 258 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
 259 dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"
 260
 261
 262 -- getSequelAmode returns an amode which refers to an info table.  The info
 263 -- table will always be of the RET_(BIG|SMALL) kind.  We're careful
 264 -- not to handle real code pointers, just in case we're compiling for
 265 -- an unregisterised/untailcallish architecture, where info pointers and
 266 -- code pointers aren't the same.
 267 -- DIRE WARNING.
 268 -- The OnStack case of sequelToAmode delivers an Amode which is only
 269 -- valid just before the final control transfer, because it assumes
 270 -- that Sp is pointing to the top word of the return address.  This
 271 -- seems unclean but there you go.
 272
 273 getSequelAmode :: FCode CmmExpr
 274 getSequelAmode
 275   = do  { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
 276         ; case sequel of
 277             OnStack -> do { sp_rel <- getSpRelOffset virt_sp
 278                           ; returnFC (CmmLoad sp_rel wordRep) }
 279
 280             UpdateCode        -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
 281             CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
 282         }
 283
 284 -------------------------------------------------------------------------
 285 --
 286 --              Build a liveness mask for the current stack
 287 --
 288 -------------------------------------------------------------------------
 289
 290 -- There are four kinds of things on the stack:
 291 --
 292 --      - pointer variables (bound in the environment)
 293 --      - non-pointer variables (boudn in the environment)
 294 --      - free slots (recorded in the stack free list)
 295 --      - non-pointer data slots (recorded in the stack free list)
 296 --
 297 -- We build up a bitmap of non-pointer slots by searching the environment
 298 -- for all the pointer variables, and subtracting these from a bitmap
 299 -- with initially all bits set (up to the size of the stack frame).
 300
 301 buildContLiveness :: Name               -- Basis for label (only)
 302                   -> [VirtualSpOffset]  -- Live stack slots
 303                   -> FCode Liveness
 304 buildContLiveness name live_slots
 305  = do   { stk_usg    <- getStkUsage
 306         ; let   StackUsage { realSp = real_sp,
 307                              frameSp = frame_sp } = stk_usg
 308
 309                 start_sp :: VirtualSpOffset
 310                 start_sp = real_sp - retAddrSizeW
 311                 -- In a continuation, we want a liveness mask that
 312                 -- starts from just after the return address, which is
 313                 -- on the stack at real_sp.
 314
 315                 frame_size :: WordOff
 316                 frame_size = start_sp - frame_sp
 317                 -- real_sp points to the frame-header for the current
 318                 -- stack frame, and the end of this frame is frame_sp.
 319                 -- The size is therefore real_sp - frame_sp - retAddrSizeW
 320                 -- (subtract one for the frame-header = return address).
 321
 322                 rel_slots :: [WordOff]
 323                 rel_slots = sortLe (<=)
 324                     [ start_sp - ofs  -- Get slots relative to top of frame
 325                     | ofs <- live_slots ]
 326
 327                 bitmap = intsToReverseBitmap frame_size rel_slots
 328
 329         ; WARN( not (all (>=0) rel_slots),
 330                 ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
 331           mkLiveness name frame_size bitmap }
 332
 333
 334 -------------------------------------------------------------------------
 335 --
 336 --              Register assignment
 337 --
 338 -------------------------------------------------------------------------
 339
 340 --  How to assign registers for
 341 --
 342 --      1) Calling a fast entry point.
 343 --      2) Returning an unboxed tuple.
 344 --      3) Invoking an out-of-line PrimOp.
 345 --
 346 -- Registers are assigned in order.
 347 --
 348 -- If we run out, we don't attempt to assign any further registers (even
 349 -- though we might have run out of only one kind of register); we just
 350 -- return immediately with the left-overs specified.
 351 --
 352 -- The alternative version @assignAllRegs@ uses the complete set of
 353 -- registers, including those that aren't mapped to real machine
 354 -- registers.  This is used for calling special RTS functions and PrimOps
 355 -- which expect their arguments to always be in the same registers.
 356
 357 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
 358         :: [(CgRep,a)]          -- Arg or result values to assign
 359         -> ([(a, GlobalReg)],   -- Register assignment in same order
 360                                 -- for *initial segment of* input list
 361                                 --   (but reversed; doesn't matter)
 362                                 -- VoidRep args do not appear here
 363             [(CgRep,a)])        -- Leftover arg or result values
 364
 365 assignCallRegs args
 366   = assign_regs args (mkRegTbl [node])
 367         -- The entry convention for a function closure
 368         -- never uses Node for argument passing; instead
 369         -- Node points to the function closure itself
 370
 371 assignPrimOpCallRegs args
 372  = assign_regs args (mkRegTbl_allRegs [])
 373         -- For primops, *all* arguments must be passed in registers
 374
 375 assignReturnRegs args
 376  = assign_regs args (mkRegTbl [])
 377         -- For returning unboxed tuples etc,
 378         -- we use all regs
 379
 380 assign_regs :: [(CgRep,a)]      -- Arg or result values to assign
 381             -> AvailRegs        -- Regs still avail: Vanilla, Float, Double, Longs
 382             -> ([(a, GlobalReg)], [(CgRep, a)])
 383 assign_regs args supply
 384   = go args [] supply
 385   where
 386     go [] acc supply = (acc, [])        -- Return the results reversed (doesn't matter)
 387     go ((VoidArg,_) : args) acc supply  -- Skip void arguments; they aren't passed, and
 388         = go args acc supply            -- there's nothign to bind them to
 389     go ((rep,arg) : args) acc supply
 390         = case assign_reg rep supply of
 391                 Just (reg, supply') -> go args ((arg,reg):acc) supply'
 392                 Nothing             -> (acc, (rep,arg):args)    -- No more regs
 393
 394 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
 395 assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
 396 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
 397 assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
 398 assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 399 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 400     -- PtrArg and NonPtrArg both go in a vanilla register
 401 assign_reg other     not_enough_regs    = Nothing
 402
 403
 404 -------------------------------------------------------------------------
 405 --
 406 --              Register supplies
 407 --
 408 -------------------------------------------------------------------------
 409
 410 -- Vanilla registers can contain pointers, Ints, Chars.
 411 -- Floats and doubles have separate register supplies.
 412 --
 413 -- We take these register supplies from the *real* registers, i.e. those
 414 -- that are guaranteed to map to machine registers.
 415
 416 useVanillaRegs | opt_Unregisterised = 0
 417                | otherwise          = mAX_Real_Vanilla_REG
 418 useFloatRegs   | opt_Unregisterised = 0
 419                | otherwise          = mAX_Real_Float_REG
 420 useDoubleRegs  | opt_Unregisterised = 0
 421                | otherwise          = mAX_Real_Double_REG
 422 useLongRegs    | opt_Unregisterised = 0
 423                | otherwise          = mAX_Real_Long_REG
 424
 425 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 426 vanillaRegNos    = regList useVanillaRegs
 427 floatRegNos      = regList useFloatRegs
 428 doubleRegNos     = regList useDoubleRegs
 429 longRegNos       = regList useLongRegs
 430
 431 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 432 allVanillaRegNos = regList mAX_Vanilla_REG
 433 allFloatRegNos   = regList mAX_Float_REG
 434 allDoubleRegNos  = regList mAX_Double_REG
 435 allLongRegNos    = regList mAX_Long_REG
 436
 437 regList 0 = []
 438 regList n = [1 .. n]
 439
 440 type AvailRegs = ( [Int]   -- available vanilla regs.
 441                  , [Int]   -- floats
 442                  , [Int]   -- doubles
 443                  , [Int]   -- longs (int64 and word64)
 444                  )
 445
 446 mkRegTbl :: [GlobalReg] -> AvailRegs
 447 mkRegTbl regs_in_use
 448   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 449
 450 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
 451 mkRegTbl_allRegs regs_in_use
 452   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 453
 454 mkRegTbl' regs_in_use vanillas floats doubles longs
 455   = (ok_vanilla, ok_float, ok_double, ok_long)
 456   where
 457     ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
 458     ok_float   = mapCatMaybes (select FloatReg)   floats
 459     ok_double  = mapCatMaybes (select DoubleReg)  doubles
 460     ok_long    = mapCatMaybes (select LongReg)    longs
 461                                     -- rep isn't looked at, hence we can use any old rep.
 462
 463     select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
 464         -- one we've unboxed the Int, we make a GlobalReg
 465         -- and see if it is already in use; if not, return its number.
 466
 467     select mk_reg_fun cand
 468       = let
 469             reg = mk_reg_fun cand
 470         in
 471         if reg `not_elem` regs_in_use
 472         then Just cand
 473         else Nothing
 474       where
 475         not_elem = isn'tIn "mkRegTbl"
 476
 477