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