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