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         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 -> Int
  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 Int
 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 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
 137 mkLiveness name size bits
 138   | size > mAX_SMALL_BITMAP_SIZE                -- Bitmap does not fit in one word
 139   = do  { let lbl = mkBitmapLabel (getUnique name)
 140         ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
 141                              : map mkWordCLit bits)
 142         ; return (BigLiveness lbl) }
 143
 144   | otherwise           -- Bitmap fits in one word
 145   = let
 146         small_bits = case bits of
 147                         []  -> 0
 148                         [b] -> fromIntegral b
 149                         _   -> panic "livenessToAddrMode"
 150     in
 151     return (smallLiveness size small_bits)
 152
 153 smallLiveness :: Int -> StgWord -> Liveness
 154 smallLiveness size small_bits = SmallLiveness bits
 155   where bits = fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
 156
 157 -------------------
 158 isBigLiveness :: Liveness -> Bool
 159 isBigLiveness (BigLiveness _)   = True
 160 isBigLiveness (SmallLiveness _) = False
 161
 162 -------------------
 163 mkLivenessCLit :: Liveness -> CmmLit
 164 mkLivenessCLit (BigLiveness lbl)    = CmmLabel lbl
 165 mkLivenessCLit (SmallLiveness bits) = mkWordCLit bits
 166
 167
 168 -------------------------------------------------------------------------
 169 --
 170 --              Bitmap describing register liveness
 171 --              across GC when doing a "generic" heap check
 172 --              (a RET_DYN stack frame).
 173 --
 174 -- NB. Must agree with these macros (currently in StgMacros.h):
 175 -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
 176 -------------------------------------------------------------------------
 177
 178 mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
 179 mkRegLiveness regs ptrs nptrs
 180   = (fromIntegral nptrs `shiftL` 16) .|.
 181     (fromIntegral ptrs  `shiftL` 24) .|.
 182     all_non_ptrs `xor` reg_bits regs
 183   where
 184     all_non_ptrs = 0xff
 185
 186     reg_bits [] = 0
 187     reg_bits ((id, VanillaReg i) : regs) | isFollowableArg (idCgRep id)
 188         = (1 `shiftL` (i - 1)) .|. reg_bits regs
 189     reg_bits (_ : regs)
 190         = reg_bits regs
 191
 192 -------------------------------------------------------------------------
 193 --
 194 --              Pushing the arguments for a slow call
 195 --
 196 -------------------------------------------------------------------------
 197
 198 -- For a slow call, we must take a bunch of arguments and intersperse
 199 -- some stg_ap_<pattern>_ret_info return addresses.
 200 constructSlowCall
 201         :: [(CgRep,CmmExpr)]
 202         -> (CLabel,             -- RTS entry point for call
 203            [(CgRep,CmmExpr)],   -- args to pass to the entry point
 204            [(CgRep,CmmExpr)])   -- stuff to save on the stack
 205
 206    -- don't forget the zero case
 207 constructSlowCall []
 208   = (mkRtsApFastLabel SLIT("stg_ap_0"), [], [])
 209
 210 constructSlowCall amodes
 211   = (stg_ap_pat, these, rest)
 212   where
 213     stg_ap_pat = mkRtsApFastLabel arg_pat
 214     (arg_pat, these, rest) = matchSlowPattern amodes
 215
 216 -- | 'slowArgs' takes a list of function arguments and prepares them for
 217 -- pushing on the stack for "extra" arguments to a function which requires
 218 -- fewer arguments than we currently have.
 219 slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
 220 slowArgs [] = []
 221 slowArgs amodes = (NonPtrArg, mkLblExpr stg_ap_pat) : args ++ slowArgs rest
 222   where (arg_pat, args, rest) = matchSlowPattern amodes
 223         stg_ap_pat = mkRtsRetInfoLabel arg_pat
 224
 225 matchSlowPattern :: [(CgRep,CmmExpr)]
 226                  -> (LitString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
 227 matchSlowPattern amodes = (arg_pat, these, rest)
 228   where (arg_pat, n)  = slowCallPattern (map fst amodes)
 229         (these, rest) = splitAt n amodes
 230
 231 -- These cases were found to cover about 99% of all slow calls:
 232 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (SLIT("stg_ap_pppppp"), 6)
 233 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _)     = (SLIT("stg_ap_ppppp"), 5)
 234 slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _)     = (SLIT("stg_ap_pppp"), 4)
 235 slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _)    = (SLIT("stg_ap_pppv"), 4)
 236 slowCallPattern (PtrArg: PtrArg: PtrArg: _)             = (SLIT("stg_ap_ppp"), 3)
 237 slowCallPattern (PtrArg: PtrArg: VoidArg: _)            = (SLIT("stg_ap_ppv"), 3)
 238 slowCallPattern (PtrArg: PtrArg: _)                     = (SLIT("stg_ap_pp"), 2)
 239 slowCallPattern (PtrArg: VoidArg: _)                    = (SLIT("stg_ap_pv"), 2)
 240 slowCallPattern (PtrArg: _)                             = (SLIT("stg_ap_p"), 1)
 241 slowCallPattern (VoidArg: _)                            = (SLIT("stg_ap_v"), 1)
 242 slowCallPattern (NonPtrArg: _)                          = (SLIT("stg_ap_n"), 1)
 243 slowCallPattern (FloatArg: _)                           = (SLIT("stg_ap_f"), 1)
 244 slowCallPattern (DoubleArg: _)                          = (SLIT("stg_ap_d"), 1)
 245 slowCallPattern (LongArg: _)                            = (SLIT("stg_ap_l"), 1)
 246 slowCallPattern _  = panic "CgStackery.slowCallPattern"
 247
 248 -------------------------------------------------------------------------
 249 --
 250 --              Return conventions
 251 --
 252 -------------------------------------------------------------------------
 253
 254 dataReturnConvPrim :: CgRep -> CmmReg
 255 dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1)
 256 dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1)
 257 dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
 258 dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
 259 dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
 260 dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"
 261
 262
 263 -- getSequelAmode returns an amode which refers to an info table.  The info
 264 -- table will always be of the RET_(BIG|SMALL) kind.  We're careful
 265 -- not to handle real code pointers, just in case we're compiling for
 266 -- an unregisterised/untailcallish architecture, where info pointers and
 267 -- code pointers aren't the same.
 268 -- DIRE WARNING.
 269 -- The OnStack case of sequelToAmode delivers an Amode which is only
 270 -- valid just before the final control transfer, because it assumes
 271 -- that Sp is pointing to the top word of the return address.  This
 272 -- seems unclean but there you go.
 273
 274 getSequelAmode :: FCode CmmExpr
 275 getSequelAmode
 276   = do  { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
 277         ; case sequel of
 278             OnStack -> do { sp_rel <- getSpRelOffset virt_sp
 279                           ; returnFC (CmmLoad sp_rel wordRep) }
 280
 281             UpdateCode        -> returnFC (CmmLit (CmmLabel mkUpdInfoLabel))
 282             CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
 283         }
 284
 285 -------------------------------------------------------------------------
 286 --
 287 --              Build a liveness mask for the current stack
 288 --
 289 -------------------------------------------------------------------------
 290
 291 -- There are four kinds of things on the stack:
 292 --
 293 --      - pointer variables (bound in the environment)
 294 --      - non-pointer variables (bound in the environment)
 295 --      - free slots (recorded in the stack free list)
 296 --      - non-pointer data slots (recorded in the stack free list)
 297 --
 298 -- We build up a bitmap of non-pointer slots by searching the environment
 299 -- for all the pointer variables, and subtracting these from a bitmap
 300 -- with initially all bits set (up to the size of the stack frame).
 301
 302 buildContLiveness :: Name               -- Basis for label (only)
 303                   -> [VirtualSpOffset]  -- Live stack slots
 304                   -> FCode Liveness
 305 buildContLiveness name live_slots
 306  = do   { stk_usg    <- getStkUsage
 307         ; let   StackUsage { realSp = real_sp,
 308                              frameSp = frame_sp } = stk_usg
 309
 310                 start_sp :: VirtualSpOffset
 311                 start_sp = real_sp - retAddrSizeW
 312                 -- In a continuation, we want a liveness mask that
 313                 -- starts from just after the return address, which is
 314                 -- on the stack at real_sp.
 315
 316                 frame_size :: WordOff
 317                 frame_size = start_sp - frame_sp
 318                 -- real_sp points to the frame-header for the current
 319                 -- stack frame, and the end of this frame is frame_sp.
 320                 -- The size is therefore real_sp - frame_sp - retAddrSizeW
 321                 -- (subtract one for the frame-header = return address).
 322
 323                 rel_slots :: [WordOff]
 324                 rel_slots = sortLe (<=)
 325                     [ start_sp - ofs  -- Get slots relative to top of frame
 326                     | ofs <- live_slots ]
 327
 328                 bitmap = intsToReverseBitmap frame_size rel_slots
 329
 330         ; WARN( not (all (>=0) rel_slots),
 331                 ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
 332           mkLiveness name frame_size bitmap }
 333
 334
 335 -------------------------------------------------------------------------
 336 --
 337 --              Register assignment
 338 --
 339 -------------------------------------------------------------------------
 340
 341 --  How to assign registers for
 342 --
 343 --      1) Calling a fast entry point.
 344 --      2) Returning an unboxed tuple.
 345 --      3) Invoking an out-of-line PrimOp.
 346 --
 347 -- Registers are assigned in order.
 348 --
 349 -- If we run out, we don't attempt to assign any further registers (even
 350 -- though we might have run out of only one kind of register); we just
 351 -- return immediately with the left-overs specified.
 352 --
 353 -- The alternative version @assignAllRegs@ uses the complete set of
 354 -- registers, including those that aren't mapped to real machine
 355 -- registers.  This is used for calling special RTS functions and PrimOps
 356 -- which expect their arguments to always be in the same registers.
 357
 358 assignCallRegs, assignPrimOpCallRegs, assignReturnRegs
 359         :: [(CgRep,a)]          -- Arg or result values to assign
 360         -> ([(a, GlobalReg)],   -- Register assignment in same order
 361                                 -- for *initial segment of* input list
 362                                 --   (but reversed; doesn't matter)
 363                                 -- VoidRep args do not appear here
 364             [(CgRep,a)])        -- Leftover arg or result values
 365
 366 assignCallRegs args
 367   = assign_regs args (mkRegTbl [node])
 368         -- The entry convention for a function closure
 369         -- never uses Node for argument passing; instead
 370         -- Node points to the function closure itself
 371
 372 assignPrimOpCallRegs args
 373  = assign_regs args (mkRegTbl_allRegs [])
 374         -- For primops, *all* arguments must be passed in registers
 375
 376 assignReturnRegs args
 377  = assign_regs args (mkRegTbl [])
 378         -- For returning unboxed tuples etc,
 379         -- we use all regs
 380
 381 assign_regs :: [(CgRep,a)]      -- Arg or result values to assign
 382             -> AvailRegs        -- Regs still avail: Vanilla, Float, Double, Longs
 383             -> ([(a, GlobalReg)], [(CgRep, a)])
 384 assign_regs args supply
 385   = go args [] supply
 386   where
 387     go [] acc supply = (acc, [])        -- Return the results reversed (doesn't matter)
 388     go ((VoidArg,_) : args) acc supply  -- Skip void arguments; they aren't passed, and
 389         = go args acc supply            -- there's nothign to bind them to
 390     go ((rep,arg) : args) acc supply
 391         = case assign_reg rep supply of
 392                 Just (reg, supply') -> go args ((arg,reg):acc) supply'
 393                 Nothing             -> (acc, (rep,arg):args)    -- No more regs
 394
 395 assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
 396 assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
 397 assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
 398 assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
 399 assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 400 assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v, (vs, fs, ds, ls))
 401     -- PtrArg and NonPtrArg both go in a vanilla register
 402 assign_reg other     not_enough_regs    = Nothing
 403
 404
 405 -------------------------------------------------------------------------
 406 --
 407 --              Register supplies
 408 --
 409 -------------------------------------------------------------------------
 410
 411 -- Vanilla registers can contain pointers, Ints, Chars.
 412 -- Floats and doubles have separate register supplies.
 413 --
 414 -- We take these register supplies from the *real* registers, i.e. those
 415 -- that are guaranteed to map to machine registers.
 416
 417 useVanillaRegs | opt_Unregisterised = 0
 418                | otherwise          = mAX_Real_Vanilla_REG
 419 useFloatRegs   | opt_Unregisterised = 0
 420                | otherwise          = mAX_Real_Float_REG
 421 useDoubleRegs  | opt_Unregisterised = 0
 422                | otherwise          = mAX_Real_Double_REG
 423 useLongRegs    | opt_Unregisterised = 0
 424                | otherwise          = mAX_Real_Long_REG
 425
 426 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 427 vanillaRegNos    = regList useVanillaRegs
 428 floatRegNos      = regList useFloatRegs
 429 doubleRegNos     = regList useDoubleRegs
 430 longRegNos       = regList useLongRegs
 431
 432 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 433 allVanillaRegNos = regList mAX_Vanilla_REG
 434 allFloatRegNos   = regList mAX_Float_REG
 435 allDoubleRegNos  = regList mAX_Double_REG
 436 allLongRegNos    = regList mAX_Long_REG
 437
 438 regList 0 = []
 439 regList n = [1 .. n]
 440
 441 type AvailRegs = ( [Int]   -- available vanilla regs.
 442                  , [Int]   -- floats
 443                  , [Int]   -- doubles
 444                  , [Int]   -- longs (int64 and word64)
 445                  )
 446
 447 mkRegTbl :: [GlobalReg] -> AvailRegs
 448 mkRegTbl regs_in_use
 449   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 450
 451 mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs
 452 mkRegTbl_allRegs regs_in_use
 453   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 454
 455 mkRegTbl' regs_in_use vanillas floats doubles longs
 456   = (ok_vanilla, ok_float, ok_double, ok_long)
 457   where
 458     ok_vanilla = mapCatMaybes (select VanillaReg) vanillas
 459     ok_float   = mapCatMaybes (select FloatReg)   floats
 460     ok_double  = mapCatMaybes (select DoubleReg)  doubles
 461     ok_long    = mapCatMaybes (select LongReg)    longs
 462                                     -- rep isn't looked at, hence we can use any old rep.
 463
 464     select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
 465         -- one we've unboxed the Int, we make a GlobalReg
 466         -- and see if it is already in use; if not, return its number.
 467
 468     select mk_reg_fun cand
 469       = let
 470             reg = mk_reg_fun cand
 471         in
 472         if reg `not_elem` regs_in_use
 473         then Just cand
 474         else Nothing
 475       where
 476         not_elem = isn'tIn "mkRegTbl"
 477
 478