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