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