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