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