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