1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module CmmCallConv (
ParamLocation(..),
assignArgumentsPos,
assignStack,
globalArgRegs, realArgRegsCover
) where
#include "HsVersions.h"
import CmmExpr
import SMRep
import Cmm (Convention(..))
import PprCmm ()
import DynFlags
import Outputable
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
data ParamLocation
= RegisterParam GlobalReg
| StackParam ByteOff
instance Outputable ParamLocation where
ppr (RegisterParam g) = ppr g
ppr (StackParam p) = ppr p
-- |
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
--
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
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags
([_], NativeReturn) -> allRegs dflags
(_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers
(_, GC) -> allRegs dflags
(_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
-- (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
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
assign_regs assts (r:rs) regs = if isFloatType ty then float else int
where float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
(W32, (vs, f:fs, ds, ls, ss))
| not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss))
(W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
(W64, (vs, fs, d:ds, ls, ss))
| not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss))
(W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
(_, (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))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
ty = arg_ty r
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
hasSseRegs = mAX_Real_SSE_REG dflags /= 0
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
where w = typeWidth (arg_ty r)
size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size
off' = offset + size
word_size = wORD_SIZE dflags
-----------------------------------------------------------------------------
-- Local information about the registers available
type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
, [GlobalReg] -- floats
, [GlobalReg] -- doubles
, [GlobalReg] -- longs (int64 and word64)
, [Int] -- SSE (floats and doubles)
)
-- 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.
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
getRegsWithoutNode dflags =
( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags
, sseRegNos dflags)
-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode dflags =
( if null (realVanillaRegs dflags)
then [VanillaReg 1]
else realVanillaRegs dflags
, realFloatRegs dflags
, realDoubleRegs dflags
, realLongRegs dflags
, sseRegNos dflags)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
allSseRegs :: DynFlags -> [Int]
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)
allSseRegs dflags = regList (mAX_SSE_REG dflags)
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
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)
sseRegNos :: DynFlags -> [Int]
sseRegNos dflags =regList (mAX_SSE_REG dflags)
regList :: Int -> [Int]
regList n = [1 .. n]
allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
allFloatRegs dflags,
allDoubleRegs dflags,
allLongRegs dflags,
allSseRegs dflags)
noRegs :: AvailRegs
noRegs = ([], [], [], [], [])
globalArgRegs :: DynFlags -> [GlobalReg]
globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
allFloatRegs dflags ++
allDoubleRegs dflags ++
allLongRegs dflags
-- 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
| hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++
realDoubleRegs dflags ++
realLongRegs dflags
| otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags
where
hasSseRegs = mAX_Real_SSE_REG dflags /= 0
|