never executed always true always false
    1 module GHC.Cmm.CallConv (
    2   ParamLocation(..),
    3   assignArgumentsPos,
    4   assignStack,
    5   realArgRegsCover,
    6   tupleRegsCover
    7 ) where
    8 
    9 import GHC.Prelude
   10 import Data.List (nub)
   11 
   12 import GHC.Cmm.Expr
   13 import GHC.Runtime.Heap.Layout
   14 import GHC.Cmm (Convention(..))
   15 import GHC.Cmm.Ppr () -- For Outputable instances
   16 
   17 import GHC.Driver.Session
   18 import GHC.Platform
   19 import GHC.Platform.Profile
   20 import GHC.Utils.Outputable
   21 import GHC.Utils.Panic
   22 
   23 -- Calculate the 'GlobalReg' or stack locations for function call
   24 -- parameters as used by the Cmm calling convention.
   25 
   26 data ParamLocation
   27   = RegisterParam GlobalReg
   28   | StackParam ByteOff
   29 
   30 instance Outputable ParamLocation where
   31   ppr (RegisterParam g) = ppr g
   32   ppr (StackParam p)    = ppr p
   33 
   34 -- |
   35 -- Given a list of arguments, and a function that tells their types,
   36 -- return a list showing where each argument is passed
   37 --
   38 assignArgumentsPos :: Profile
   39                    -> ByteOff           -- stack offset to start with
   40                    -> Convention
   41                    -> (a -> CmmType)    -- how to get a type from an arg
   42                    -> [a]               -- args
   43                    -> (
   44                         ByteOff              -- bytes of stack args
   45                       , [(a, ParamLocation)] -- args and locations
   46                       )
   47 
   48 assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
   49     where
   50       platform = profilePlatform profile
   51       regs = case (reps, conv) of
   52                (_,   NativeNodeCall)   -> getRegsWithNode platform
   53                (_,   NativeDirectCall) -> getRegsWithoutNode platform
   54                ([_], NativeReturn)     -> allRegs platform
   55                (_,   NativeReturn)     -> getRegsWithNode platform
   56                -- GC calling convention *must* put values in registers
   57                (_,   GC)               -> allRegs platform
   58                (_,   Slow)             -> nodeOnly
   59       -- The calling conventions first assign arguments to registers,
   60       -- then switch to the stack when we first run out of registers
   61       -- (even if there are still available registers for args of a
   62       -- different type).  When returning an unboxed tuple, we also
   63       -- separate the stack arguments by pointerhood.
   64       (reg_assts, stk_args)  = assign_regs [] reps regs
   65       (stk_off,   stk_assts) = assignStack platform off arg_ty stk_args
   66       assignments = reg_assts ++ stk_assts
   67 
   68       assign_regs assts []     _    = (assts, [])
   69       assign_regs assts (r:rs) regs | isVecType ty   = vec
   70                                     | isFloatType ty = float
   71                                     | otherwise      = int
   72         where vec = case (w, regs) of
   73                       (W128, (vs, fs, ds, ls, s:ss))
   74                           | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
   75                       (W256, (vs, fs, ds, ls, s:ss))
   76                           | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
   77                       (W512, (vs, fs, ds, ls, s:ss))
   78                           | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
   79                       _ -> (assts, (r:rs))
   80               float = case (w, regs) of
   81                         (W32, (vs, fs, ds, ls, s:ss))
   82                             | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
   83                         (W32, (vs, f:fs, ds, ls, ss))
   84                             | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
   85                         (W64, (vs, fs, ds, ls, s:ss))
   86                             | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
   87                         (W64, (vs, fs, d:ds, ls, ss))
   88                             | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
   89                         _ -> (assts, (r:rs))
   90               int = case (w, regs) of
   91                       (W128, _) -> panic "W128 unsupported register type"
   92                       (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)
   93                           -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
   94                       (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)
   95                           -> k (RegisterParam l, (vs, fs, ds, ls, ss))
   96                       _   -> (assts, (r:rs))
   97               k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
   98               ty = arg_ty r
   99               w  = typeWidth ty
  100               !gcp | isGcPtrType ty = VGcPtr
  101                    | otherwise      = VNonGcPtr
  102               passFloatInXmm = passFloatArgsInXmm platform
  103 
  104 passFloatArgsInXmm :: Platform -> Bool
  105 passFloatArgsInXmm platform = case platformArch platform of
  106                               ArchX86_64 -> True
  107                               ArchX86    -> False
  108                               _          -> False
  109 
  110 -- We used to spill vector registers to the stack since the LLVM backend didn't
  111 -- support vector registers in its calling convention. However, this has now
  112 -- been fixed. This function remains only as a convenient way to re-enable
  113 -- spilling when debugging code generation.
  114 passVectorInReg :: Width -> Profile -> Bool
  115 passVectorInReg _ _ = True
  116 
  117 assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
  118             -> (
  119                  ByteOff              -- bytes of stack args
  120                , [(a, ParamLocation)] -- args and locations
  121                )
  122 assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)
  123  where
  124       assign_stk offset assts [] = (offset, assts)
  125       assign_stk offset assts (r:rs)
  126         = assign_stk off' ((r, StackParam off') : assts) rs
  127         where w    = typeWidth (arg_ty r)
  128               off' = offset + size
  129               -- Stack arguments always take a whole number of words, we never
  130               -- pack them unlike constructor fields.
  131               size = roundUpToWords platform (widthInBytes w)
  132 
  133 -----------------------------------------------------------------------------
  134 -- Local information about the registers available
  135 
  136 type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
  137                  , [GlobalReg]   -- floats
  138                  , [GlobalReg]   -- doubles
  139                  , [GlobalReg]   -- longs (int64 and word64)
  140                  , [Int]         -- XMM (floats and doubles)
  141                  )
  142 
  143 -- Vanilla registers can contain pointers, Ints, Chars.
  144 -- Floats and doubles have separate register supplies.
  145 --
  146 -- We take these register supplies from the *real* registers, i.e. those
  147 -- that are guaranteed to map to machine registers.
  148 
  149 getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
  150 getRegsWithoutNode platform =
  151   ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)
  152   , realFloatRegs platform
  153   , realDoubleRegs platform
  154   , realLongRegs platform
  155   , realXmmRegNos platform)
  156 
  157 -- getRegsWithNode uses R1/node even if it isn't a register
  158 getRegsWithNode platform =
  159   ( if null (realVanillaRegs platform)
  160     then [VanillaReg 1]
  161     else realVanillaRegs platform
  162   , realFloatRegs platform
  163   , realDoubleRegs platform
  164   , realLongRegs platform
  165   , realXmmRegNos platform)
  166 
  167 allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
  168 allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
  169 allXmmRegs :: Platform -> [Int]
  170 
  171 allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))
  172 allFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Float_REG   (platformConstants platform))
  173 allDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Double_REG  (platformConstants platform))
  174 allLongRegs    platform = map LongReg    $ regList (pc_MAX_Long_REG    (platformConstants platform))
  175 allXmmRegs     platform =                  regList (pc_MAX_XMM_REG     (platformConstants platform))
  176 
  177 realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
  178 realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
  179 
  180 realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))
  181 realFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Real_Float_REG   (platformConstants platform))
  182 realDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Real_Double_REG  (platformConstants platform))
  183 realLongRegs    platform = map LongReg    $ regList (pc_MAX_Real_Long_REG    (platformConstants platform))
  184 
  185 realXmmRegNos :: Platform -> [Int]
  186 realXmmRegNos platform
  187     | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))
  188     | otherwise              = []
  189 
  190 regList :: Int -> [Int]
  191 regList n = [1 .. n]
  192 
  193 allRegs :: Platform -> AvailRegs
  194 allRegs platform = ( allVanillaRegs platform
  195                    , allFloatRegs   platform
  196                    , allDoubleRegs  platform
  197                    , allLongRegs    platform
  198                    , allXmmRegs     platform
  199                    )
  200 
  201 nodeOnly :: AvailRegs
  202 nodeOnly = ([VanillaReg 1], [], [], [], [])
  203 
  204 -- This returns the set of global registers that *cover* the machine registers
  205 -- used for argument passing. On platforms where registers can overlap---right
  206 -- now just x86-64, where Float and Double registers overlap---passing this set
  207 -- of registers is guaranteed to preserve the contents of all live registers. We
  208 -- only use this functionality in hand-written C-- code in the RTS.
  209 realArgRegsCover :: Platform -> [GlobalReg]
  210 realArgRegsCover platform
  211     | passFloatArgsInXmm platform
  212     = map ($ VGcPtr) (realVanillaRegs platform) ++
  213       realLongRegs platform ++
  214       realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
  215                               -- Moreover, the NCG can't load/store full XMM
  216                               -- registers for now...
  217 
  218     | otherwise
  219     = map ($ VGcPtr) (realVanillaRegs platform) ++
  220       realFloatRegs  platform ++
  221       realDoubleRegs platform ++
  222       realLongRegs   platform
  223       -- we don't save XMM registers if they are not used for parameter passing
  224 
  225 -- Like realArgRegsCover but always includes the node. This covers the real
  226 -- and virtual registers used for unboxed tuples.
  227 --
  228 -- Note: if anything changes in how registers for unboxed tuples overlap,
  229 --       make sure to also update GHC.StgToByteCode.layoutTuple.
  230 
  231 tupleRegsCover :: Platform -> [GlobalReg]
  232 tupleRegsCover platform =
  233   nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)