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
|
module CmmCallConv (
ParamLocation(..),
ArgumentFormat,
assignArguments,
assignArgumentsPos,
argumentsSize,
) where
#include "HsVersions.h"
import CmmExpr
import SMRep
import Cmm (Convention(..))
import PprCmm ()
import Constants
import qualified Data.List as L
import StaticFlags (opt_Unregisterised)
import Outputable
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
data ParamLocation a
= RegisterParam GlobalReg
| StackParam a
instance (Outputable a) => Outputable (ParamLocation a) where
ppr (RegisterParam g) = ppr g
ppr (StackParam p) = ppr p
type ArgumentFormat a b = [(a, ParamLocation b)]
-- Stack parameters are returned as word offsets.
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
assignArguments _ _ = panic "assignArguments only used in dead codegen" -- assignments
-- | JD: For the new stack story, I want arguments passed on the stack to manifest as
-- positive offsets in a CallArea, not negative offsets from the stack pointer.
-- Also, I want byte offsets, not word offsets.
assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
ArgumentFormat a ByteOff
assignArgumentsPos conv arg_ty reps = assignments
where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode
-- GC calling convention *must* put values in registers
(_, GC) -> allRegs
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
(_, Slow) -> noRegs
_ -> pprPanic "Unknown calling convention" (ppr conv)
-- 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_args' = case conv of NativeReturn -> part
PrimOpReturn -> part
GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
_ -> stk_args
where part = uncurry (++)
(L.partition (not . isGcPtrType . arg_ty) stk_args)
stk_assts = assign_stk 0 [] (reverse 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, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
(W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
(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)) | widthInBits w <= widthInBits wordWidth
-> k (RegisterParam (v gcp), (vs, fs, ds, ls))
(_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
-> k (RegisterParam l, (vs, fs, ds, ls))
_ -> (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
assign_stk _ assts [] = 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
argumentsSize :: (a -> CmmType) -> [a] -> WordOff
argumentsSize f reps = maximum (0 : map arg_top args)
where
args = assignArguments f reps
arg_top (_, StackParam offset) = -offset
arg_top (_, RegisterParam _) = 0
-----------------------------------------------------------------------------
-- Local information about the registers available
type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
, [GlobalReg] -- floats
, [GlobalReg] -- doubles
, [GlobalReg] -- longs (int64 and word64)
)
-- 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.
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Vanilla_REG
floatRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Float_REG
doubleRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Double_REG
longRegNos | opt_Unregisterised = []
| otherwise = regList mAX_Real_Long_REG
--
getRegsWithoutNode, getRegsWithNode :: AvailRegs
getRegsWithoutNode =
(filter (\r -> r VGcPtr /= node) intRegs,
map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
getRegsWithNode =
(intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
where intRegs = map VanillaReg vanillaRegNos
allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
allFloatRegNos = regList mAX_Float_REG
allDoubleRegNos = regList mAX_Double_REG
allLongRegNos = regList mAX_Long_REG
regList :: Int -> [Int]
regList n = [1 .. n]
allRegs :: AvailRegs
allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos,
map DoubleReg allDoubleRegNos, map LongReg allLongRegNos)
noRegs :: AvailRegs
noRegs = ([], [], [], [])
|
