7 #include "HsVersions.h"
11 import Cmm (Convention(..))
15 import qualified Data.List as L
16 import StaticFlags (opt_Unregisterised)
19 -- Calculate the 'GlobalReg' or stack locations for function call
20 -- parameters as used by the Cmm calling convention.
23 = RegisterParam GlobalReg
26 instance (Outputable a) => Outputable (ParamLocation a) where
27 ppr (RegisterParam g) = ppr g
28 ppr (StackParam p) = ppr p
30 type ArgumentFormat a b = [(a, ParamLocation b)]
32 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
33 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
34 -- Also, I want byte offsets, not word offsets.
35 assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
36 ArgumentFormat a ByteOff
37 -- Given a list of arguments, and a function that tells their types,
38 -- return a list showing where each argument is passed
39 assignArgumentsPos conv arg_ty reps = assignments
40 where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
41 regs = case (reps, conv) of
42 (_, NativeNodeCall) -> getRegsWithNode
43 (_, NativeDirectCall) -> getRegsWithoutNode
44 ([_], NativeReturn) -> allRegs
45 (_, NativeReturn) -> getRegsWithNode
46 -- GC calling convention *must* put values in registers
48 (_, PrimOpCall) -> allRegs
49 ([_], PrimOpReturn) -> allRegs
50 (_, PrimOpReturn) -> getRegsWithNode
52 _ -> pprPanic "Unknown calling convention" (ppr conv)
53 -- The calling conventions first assign arguments to registers,
54 -- then switch to the stack when we first run out of registers
55 -- (even if there are still available registers for args of a different type).
56 -- When returning an unboxed tuple, we also separate the stack
57 -- arguments by pointerhood.
58 (reg_assts, stk_args) = assign_regs [] reps regs
59 stk_args' = case conv of NativeReturn -> part
61 GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
63 where part = uncurry (++)
64 (L.partition (not . isGcPtrType . arg_ty) stk_args)
65 stk_assts = assign_stk 0 [] (reverse stk_args')
66 assignments = reg_assts ++ stk_assts
68 assign_regs assts [] _ = (assts, [])
69 assign_regs assts (r:rs) regs = if isFloatType ty then float else int
70 where float = case (w, regs) of
71 (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
72 (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
73 (W80, _) -> panic "F80 unsupported register type"
75 int = case (w, regs) of
76 (W128, _) -> panic "W128 unsupported register type"
77 (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
78 -> k (RegisterParam (v gcp), (vs, fs, ds, ls))
79 (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
80 -> k (RegisterParam l, (vs, fs, ds, ls))
82 k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
85 gcp | isGcPtrType ty = VGcPtr
86 | otherwise = VNonGcPtr
88 assign_stk _ assts [] = assts
89 assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
90 where w = typeWidth (arg_ty r)
91 size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
94 -----------------------------------------------------------------------------
95 -- Local information about the registers available
97 type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
98 , [GlobalReg] -- floats
99 , [GlobalReg] -- doubles
100 , [GlobalReg] -- longs (int64 and word64)
103 -- Vanilla registers can contain pointers, Ints, Chars.
104 -- Floats and doubles have separate register supplies.
106 -- We take these register supplies from the *real* registers, i.e. those
107 -- that are guaranteed to map to machine registers.
109 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
110 vanillaRegNos | opt_Unregisterised = []
111 | otherwise = regList mAX_Real_Vanilla_REG
112 floatRegNos | opt_Unregisterised = []
113 | otherwise = regList mAX_Real_Float_REG
114 doubleRegNos | opt_Unregisterised = []
115 | otherwise = regList mAX_Real_Double_REG
116 longRegNos | opt_Unregisterised = []
117 | otherwise = regList mAX_Real_Long_REG
120 getRegsWithoutNode, getRegsWithNode :: AvailRegs
122 (filter (\r -> r VGcPtr /= node) intRegs,
123 map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
124 where intRegs = map VanillaReg vanillaRegNos
126 (intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
127 where intRegs = map VanillaReg vanillaRegNos
129 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
130 allVanillaRegNos = regList mAX_Vanilla_REG
131 allFloatRegNos = regList mAX_Float_REG
132 allDoubleRegNos = regList mAX_Double_REG
133 allLongRegNos = regList mAX_Long_REG
135 regList :: Int -> [Int]
139 allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos,
140 map DoubleReg allDoubleRegNos, map LongReg allLongRegNos)
143 noRegs = ([], [], [], [])