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