CmmCallConv.hs 9.84 KB
Newer Older
1
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
2

3 4
module CmmCallConv (
  ParamLocation(..),
5
  assignArgumentsPos,
6
  assignStack,
Jan Stolarek's avatar
Jan Stolarek committed
7
  realArgRegsCover
8 9 10 11
) where

#include "HsVersions.h"

12 13
import GhcPrelude

14
import CmmExpr
15
import SMRep
16 17
import Cmm (Convention(..))
import PprCmm ()
18

19
import DynFlags
20
import Platform
21
import Outputable
22

23 24 25
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.

26
data ParamLocation
27
  = RegisterParam GlobalReg
28
  | StackParam ByteOff
29

30
instance Outputable ParamLocation where
31 32 33
  ppr (RegisterParam g) = ppr g
  ppr (StackParam p)    = ppr p

34
-- |
35 36
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
37 38 39 40 41 42 43 44 45 46 47 48 49
--
assignArgumentsPos :: DynFlags
                   -> ByteOff           -- stack offset to start with
                   -> Convention
                   -> (a -> CmmType)    -- how to get a type from an arg
                   -> [a]               -- args
                   -> (
                        ByteOff              -- bytes of stack args
                      , [(a, ParamLocation)] -- args and locations
                      )

assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
    where
50
      regs = case (reps, conv) of
51 52
               (_,   NativeNodeCall)   -> getRegsWithNode dflags
               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
53
               ([_], NativeReturn)     -> allRegs dflags
54
               (_,   NativeReturn)     -> getRegsWithNode dflags
55
               -- GC calling convention *must* put values in registers
56
               (_,   GC)               -> allRegs dflags
57
               (_,   Slow)             -> nodeOnly
58 59
      -- The calling conventions first assign arguments to registers,
      -- then switch to the stack when we first run out of registers
60 61 62 63 64
      -- (even if there are still available registers for args of a
      -- different type).  When returning an unboxed tuple, we also
      -- separate the stack arguments by pointerhood.
      (reg_assts, stk_args)  = assign_regs [] reps regs
      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args
65 66 67
      assignments = reg_assts ++ stk_assts

      assign_regs assts []     _    = (assts, [])
68 69 70
      assign_regs assts (r:rs) regs | isVecType ty   = vec
                                    | isFloatType ty = float
                                    | otherwise      = int
71
        where vec = case (w, regs) of
72 73 74 75 76 77
                      (W128, (vs, fs, ds, ls, s:ss))
                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
                      (W256, (vs, fs, ds, ls, s:ss))
                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
                      (W512, (vs, fs, ds, ls, s:ss))
                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
78
                      _ -> (assts, (r:rs))
79
              float = case (w, regs) of
80 81
                        (W32, (vs, fs, ds, ls, s:ss))
                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
82
                        (W32, (vs, f:fs, ds, ls, ss))
83 84 85
                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
                        (W64, (vs, fs, ds, ls, s:ss))
                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
86
                        (W64, (vs, fs, d:ds, ls, ss))
87
                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
88 89 90 91
                        (W80, _) -> panic "F80 unsupported register type"
                        _ -> (assts, (r:rs))
              int = case (w, regs) of
                      (W128, _) -> panic "W128 unsupported register type"
92 93 94 95
                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))
96 97 98 99 100
                      _   -> (assts, (r:rs))
              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
              ty = arg_ty r
              w  = typeWidth ty
              gcp | isGcPtrType ty = VGcPtr
101
                  | otherwise      = VNonGcPtr
102
              passFloatInXmm = passFloatArgsInXmm dflags
103

104 105 106 107
passFloatArgsInXmm :: DynFlags -> Bool
passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
                              ArchX86_64 -> True
                              _          -> False
108

109 110
-- On X86_64, we always pass 128-bit-wide vectors in registers. On 32-bit X86
-- and for all larger vector sizes on X86_64, LLVM's GHC calling convention
111
-- does not currently pass vectors in registers. The patch to update the GHC
112 113 114 115 116 117 118 119 120 121 122
-- calling convention to support passing SIMD vectors in registers is small and
-- well-contained, so it may make it into LLVM 3.4. The hidden
-- -fllvm-pass-vectors-in-regs flag will generate LLVM code that attempts to
-- pass vectors in registers, but it must only be used with a version of LLVM
-- that has an updated GHC calling convention.
passVectorInReg :: Width -> DynFlags -> Bool
passVectorInReg W128 dflags = case platformArch (targetPlatform dflags) of
                                ArchX86_64 -> True
                                _          -> gopt Opt_LlvmPassVectorsInRegisters dflags
passVectorInReg _    dflags = gopt Opt_LlvmPassVectorsInRegisters dflags

123 124 125 126 127 128 129 130 131 132
assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
            -> (
                 ByteOff              -- bytes of stack args
               , [(a, ParamLocation)] -- args and locations
               )
assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
 where
      assign_stk offset assts [] = (offset, assts)
      assign_stk offset assts (r:rs)
        = assign_stk off' ((r, StackParam off') : assts) rs
133 134
        where w    = typeWidth (arg_ty r)
              off' = offset + size
135 136 137
              -- Stack arguments always take a whole number of words, we never
              -- pack them unlike constructor fields.
              size = roundUpToWords dflags (widthInBytes w)
138 139 140

-----------------------------------------------------------------------------
-- Local information about the registers available
141

142
type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
143 144 145
                 , [GlobalReg]   -- floats
                 , [GlobalReg]   -- doubles
                 , [GlobalReg]   -- longs (int64 and word64)
gmainland's avatar
gmainland committed
146
                 , [Int]         -- XMM (floats and doubles)
dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
147
                 )
148 149 150 151 152 153 154

-- Vanilla registers can contain pointers, Ints, Chars.
-- Floats and doubles have separate register supplies.
--
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.

155
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
156 157 158 159
getRegsWithoutNode dflags =
  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
  , realFloatRegs dflags
  , realDoubleRegs dflags
160
  , realLongRegs dflags
161
  , realXmmRegNos dflags)
162 163

-- getRegsWithNode uses R1/node even if it isn't a register
164 165 166 167 168 169
getRegsWithNode dflags =
  ( if null (realVanillaRegs dflags)
    then [VanillaReg 1]
    else realVanillaRegs dflags
  , realFloatRegs dflags
  , realDoubleRegs dflags
170
  , realLongRegs dflags
171
  , realXmmRegNos dflags)
172 173 174

allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
gmainland's avatar
gmainland committed
175
allXmmRegs :: DynFlags -> [Int]
176 177 178 179 180

allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)
allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)
allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)
gmainland's avatar
gmainland committed
181
allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)
182 183 184

realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
185
realXmmRegNos :: DynFlags -> [Int]
186 187 188 189 190

realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)
realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)
realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)
191 192 193 194

realXmmRegNos dflags
    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)
    | otherwise            = []
195

196 197 198
regList :: Int -> [Int]
regList n = [1 .. n]

199 200 201 202
allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
                  allFloatRegs dflags,
                  allDoubleRegs dflags,
203
                  allLongRegs dflags,
gmainland's avatar
gmainland committed
204
                  allXmmRegs dflags)
Ian Lynagh's avatar
Ian Lynagh committed
205

206 207
nodeOnly :: AvailRegs
nodeOnly = ([VanillaReg 1], [], [], [], [])
208

209 210 211 212 213 214 215
-- This returns the set of global registers that *cover* the machine registers
-- used for argument passing. On platforms where registers can overlap---right
-- now just x86-64, where Float and Double registers overlap---passing this set
-- of registers is guaranteed to preserve the contents of all live registers. We
-- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg]
realArgRegsCover dflags
216 217 218 219 220 221 222 223
    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
                                  realLongRegs dflags ++
                                  map XmmReg (realXmmRegNos dflags)
    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++
                                  realFloatRegs dflags ++
                                  realDoubleRegs dflags ++
                                  realLongRegs dflags ++
                                  map XmmReg (realXmmRegNos dflags)