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