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       -- Disable vectored returns
 271 --      if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
 272 --          VectoredReturn size
 273 --      else
 274             UnvectoredReturn size
 275   -- NB: unvectored returns Include size 0 (no constructors), so that
 276   --     the following perverse code compiles (it crashed GHC in 5.02)
 277   --        data T1
 278   --        data T2 = T2 !T1 Int
 279   --     The only value of type T1 is bottom, which never returns anyway.
 280
 281 dataReturnConvPrim :: CgRep -> CmmReg
 282 dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1)
 283 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
 284 dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
 285 dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
 286 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
 287 dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"
 288
 289
 290 -- getSequelAmode returns an amode which refers to an info table.  The info
 291 -- table will always be of the RET(_VEC)?_(BIG|SMALL) kind.  We're careful
 292 -- not to handle real code pointers, just in case we're compiling for
 293 -- an unregisterised/untailcallish architecture, where info pointers and
 294 -- code pointers aren't the same.
 295 -- DIRE WARNING.
 296 -- The OnStack case of sequelToAmode delivers an Amode which is only
 297 -- valid just before the final control transfer, because it assumes
 298 -- that Sp is pointing to the top word of the return address.  This
 299 -- seems unclean but there you go.
 300
 301 getSequelAmode :: FCode CmmExpr
 302 getSequelAmode
 303   = do  { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
 304         ; case sequel of
 305             OnStack -> do { sp_rel <- getSpRelOffset virt_sp
 306                           ; returnFC (CmmLoad sp_rel wordRep) }
 307
 308             UpdateCode             -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
 309             CaseAlts lbl _ _ True  -> returnFC (CmmLit (CmmLabel mkSeqInfoLabel))
 310             CaseAlts lbl _ _ False -> returnFC (CmmLit (CmmLabel lbl))
 311         }
 312
 313 -------------------------------------------------------------------------
 314 --
 315 --              Build a liveness mask for the current stack
 316 --
 317 -------------------------------------------------------------------------
 318
 319 -- There are four kinds of things on the stack:
 320 --
 321 --      - pointer variables (bound in the environment)
 322 --      - non-pointer variables (boudn in the environment)
 323 --      - free slots (recorded in the stack free list)
 324 --      - non-pointer data slots (recorded in the stack free list)
 325 --
 326 -- We build up a bitmap of non-pointer slots by searching the environment
 327 -- for all the pointer variables, and subtracting these from a bitmap
 328 -- with initially all bits set (up to the size of the stack frame).
 329
 330 buildContLiveness :: Name               -- Basis for label (only)
 331                   -> [VirtualSpOffset]  -- Live stack slots
 332                   -> FCode Liveness
 333 buildContLiveness name live_slots
 334  = do   { stk_usg    <- getStkUsage
 335         ; let   StackUsage { realSp = real_sp,
 336                              frameSp = frame_sp } = stk_usg
 337
 338                 start_sp :: VirtualSpOffset
 339                 start_sp = real_sp - retAddrSizeW
 340                 -- In a continuation, we want a liveness mask that
 341                 -- starts from just after the return address, which is
 342                 -- on the stack at real_sp.
 343
 344                 frame_size :: WordOff
 345                 frame_size = start_sp - frame_sp
 346                 -- real_sp points to the frame-header for the current
 347                 -- stack frame, and the end of this frame is frame_sp.
 348                 -- The size is therefore real_sp - frame_sp - retAddrSizeW
 349                 -- (subtract one for the frame-header = return address).
 350
 351                 rel_slots :: [WordOff]
 352                 rel_slots = sortLe (<=)
 353                     [ start_sp - ofs  -- Get slots relative to top of frame
 354                     | ofs <- live_slots ]
 355
 356                 bitmap = intsToReverseBitmap frame_size rel_slots
 357
 358         ; WARN( not (all (>=0) rel_slots),
 359                 ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
 360           mkLiveness name frame_size bitmap }
 361
 362
 363 -------------------------------------------------------------------------
 364 --
 365 --              Register assignment
 366 --
 367 -------------------------------------------------------------------------
 368
 369 --  How to assign registers for
 370 --
 371 --      1) Calling a fast entry point.
 372 --      2) Returning an unboxed tuple.
 373 --      3) Invoking an out-of-line PrimOp.
 374 --
 375 -- Registers are assigned in order.
 376 --
 377 -- If we run out, we don't attempt to assign any further registers (even
 378 -- though we might have run out of only one kind of register); we just
 379 -- return immediately with the left-overs specified.
 380 --
 381 -- The alternative version @assignAllRegs@ uses the complete set of
 382 -- registers, including those that aren't mapped to real machine
 383 -- registers.  This is used for calling special RTS functions and PrimOps
 384 -- which expect their arguments to always be in the same registers.
 385
 386 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
 387         :: [(CgRep,a)]          -- Arg or result values to assign
 388         -> ([(a, GlobalReg)],   -- Register assignment in same order
 389                                 -- for *initial segment of* input list
 390                                 --   (but reversed; doesn't matter)
 391                                 -- VoidRep args do not appear here
 392             [(CgRep,a)])        -- Leftover arg or result values
 393
 394 assignCallRegs args
 395   = assign_regs args (mkRegTbl [node])
 396         -- The entry convention for a function closure
 397         -- never uses Node for argument passing; instead
 398         -- Node points to the function closure itself
 399
 400 assignPrimOpCallRegs args
 401  = assign_regs args (mkRegTbl_allRegs [])
 402         -- For primops, *all* arguments must be passed in registers
 403
 404 assignReturnRegs args
 405  = assign_regs args (mkRegTbl [])
 406         -- For returning unboxed tuples etc,
 407         -- we use all regs
 408
 409 assign_regs :: [(CgRep,a)]      -- Arg or result values to assign
 410             -> AvailRegs        -- Regs still avail: Vanilla, Float, Double, Longs
 411             -> ([(a, GlobalReg)], [(CgRep, a)])
 412 assign_regs args supply
 413   = go args [] supply
 414   where
 415     go [] acc supply = (acc, [])        -- Return the results reversed (doesn't matter)
 416     go ((VoidArg,_) : args) acc supply  -- Skip void arguments; they aren't passed, and
 417         = go args acc supply            -- there's nothign to bind them to
 418     go ((rep,arg) : args) acc supply
 419         = case assign_reg rep supply of
 420                 Just (reg, supply') -> go args ((arg,reg):acc) supply'
 421                 Nothing             -> (acc, (rep,arg):args)    -- No more regs
 422
 423 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
 424 assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
 425 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
 426 assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
 427 assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 428 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 429     -- PtrArg and NonPtrArg both go in a vanilla register
 430 assign_reg other     not_enough_regs    = Nothing
 431
 432
 433 -------------------------------------------------------------------------
 434 --
 435 --              Register supplies
 436 --
 437 -------------------------------------------------------------------------
 438
 439 -- Vanilla registers can contain pointers, Ints, Chars.
 440 -- Floats and doubles have separate register supplies.
 441 --
 442 -- We take these register supplies from the *real* registers, i.e. those
 443 -- that are guaranteed to map to machine registers.
 444
 445 useVanillaRegs | opt_Unregisterised = 0
 446                | otherwise          = mAX_Real_Vanilla_REG
 447 useFloatRegs   | opt_Unregisterised = 0
 448                | otherwise          = mAX_Real_Float_REG
 449 useDoubleRegs  | opt_Unregisterised = 0
 450                | otherwise          = mAX_Real_Double_REG
 451 useLongRegs    | opt_Unregisterised = 0
 452                | otherwise          = mAX_Real_Long_REG
 453
 454 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 455 vanillaRegNos    = regList useVanillaRegs
 456 floatRegNos      = regList useFloatRegs
 457 doubleRegNos     = regList useDoubleRegs
 458 longRegNos       = regList useLongRegs
 459
 460 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 461 allVanillaRegNos = regList mAX_Vanilla_REG
 462 allFloatRegNos   = regList mAX_Float_REG
 463 allDoubleRegNos  = regList mAX_Double_REG
 464 allLongRegNos    = regList mAX_Long_REG
 465
 466 regList 0 = []
 467 regList n = [1 .. n]
 468
 469 type AvailRegs = ( [Int]   -- available vanilla regs.
 470                  , [Int]   -- floats
 471                  , [Int]   -- doubles
 472                  , [Int]   -- longs (int64 and word64)
 473                  )
 474
 475 mkRegTbl :: [GlobalReg] -> AvailRegs
 476 mkRegTbl regs_in_use
 477   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 478
 479 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
 480 mkRegTbl_allRegs regs_in_use
 481   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 482
 483 mkRegTbl' regs_in_use vanillas floats doubles longs
 484   = (ok_vanilla, ok_float, ok_double, ok_long)
 485   where
 486     ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
 487     ok_float   = mapCatMaybes (select FloatReg)   floats
 488     ok_double  = mapCatMaybes (select DoubleReg)  doubles
 489     ok_long    = mapCatMaybes (select LongReg)    longs
 490                                     -- rep isn't looked at, hence we can use any old rep.
 491
 492     select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
 493         -- one we've unboxed the Int, we make a GlobalReg
 494         -- and see if it is already in use; if not, return its number.
 495
 496     select mk_reg_fun cand
 497       = let
 498             reg = mk_reg_fun cand
 499         in
 500         if reg `not_elem` regs_in_use
 501         then Just cand
 502         else Nothing
 503       where
 504         not_elem = isn'tIn "mkRegTbl"
 505
 506