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)