compiler/codeGen/CgCallConv.hs

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