235fe7f911f6db6619aeae666c246beaccf6073d
[ghc.git] / compiler / cmm / CmmCallConv.hs
1 {-# OPTIONS -fno-warn-tabs #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and
4 -- detab the module (please do the detabbing in a separate patch). See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
6 -- for details
7
8 module CmmCallConv (
9 ParamLocation(..),
10 assignArgumentsPos,
11 globalArgRegs
12 ) where
13
14 #include "HsVersions.h"
15
16 import CmmExpr
17 import SMRep
18 import Cmm (Convention(..))
19 import PprCmm ()
20
21 import qualified Data.List as L
22 import DynFlags
23 import Outputable
24
25 -- Calculate the 'GlobalReg' or stack locations for function call
26 -- parameters as used by the Cmm calling convention.
27
28 data ParamLocation
29 = RegisterParam GlobalReg
30 | StackParam ByteOff
31
32 instance Outputable ParamLocation where
33 ppr (RegisterParam g) = ppr g
34 ppr (StackParam p) = ppr p
35
36 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
37 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
38 -- Also, I want byte offsets, not word offsets.
39 assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
40 [(a, ParamLocation)]
41 -- Given a list of arguments, and a function that tells their types,
42 -- return a list showing where each argument is passed
43 assignArgumentsPos dflags conv arg_ty reps = assignments
44 where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
45 regs = case (reps, conv) of
46 (_, NativeNodeCall) -> getRegsWithNode dflags
47 (_, NativeDirectCall) -> getRegsWithoutNode dflags
48 ([_], NativeReturn) -> allRegs dflags
49 (_, NativeReturn) -> getRegsWithNode dflags
50 -- GC calling convention *must* put values in registers
51 (_, GC) -> allRegs dflags
52 (_, PrimOpCall) -> allRegs dflags
53 ([_], PrimOpReturn) -> allRegs dflags
54 (_, PrimOpReturn) -> getRegsWithNode dflags
55 (_, Slow) -> noRegs
56 -- The calling conventions first assign arguments to registers,
57 -- then switch to the stack when we first run out of registers
58 -- (even if there are still available registers for args of a different type).
59 -- When returning an unboxed tuple, we also separate the stack
60 -- arguments by pointerhood.
61 (reg_assts, stk_args) = assign_regs [] reps regs
62 stk_args' = case conv of NativeReturn -> part
63 PrimOpReturn -> part
64 GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
65 _ -> stk_args
66 where part = uncurry (++)
67 (L.partition (not . isGcPtrType . arg_ty) stk_args)
68 stk_assts = assign_stk 0 [] (reverse stk_args')
69 assignments = reg_assts ++ stk_assts
70
71 assign_regs assts [] _ = (assts, [])
72 assign_regs assts (r:rs) regs = if isFloatType ty then float else int
73 where float = case (w, regs) of
74 (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
75 (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
76 (W80, _) -> panic "F80 unsupported register type"
77 _ -> (assts, (r:rs))
78 int = case (w, regs) of
79 (W128, _) -> panic "W128 unsupported register type"
80 (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags)
81 -> k (RegisterParam (v gcp), (vs, fs, ds, ls))
82 (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags)
83 -> k (RegisterParam l, (vs, fs, ds, ls))
84 _ -> (assts, (r:rs))
85 k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
86 ty = arg_ty r
87 w = typeWidth ty
88 gcp | isGcPtrType ty = VGcPtr
89 | otherwise = VNonGcPtr
90
91 assign_stk _ assts [] = assts
92 assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
93 where w = typeWidth (arg_ty r)
94 size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags
95 off' = offset + size
96
97 -----------------------------------------------------------------------------
98 -- Local information about the registers available
99
100 type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
101 , [GlobalReg] -- floats
102 , [GlobalReg] -- doubles
103 , [GlobalReg] -- longs (int64 and word64)
104 )
105
106 -- Vanilla registers can contain pointers, Ints, Chars.
107 -- Floats and doubles have separate register supplies.
108 --
109 -- We take these register supplies from the *real* registers, i.e. those
110 -- that are guaranteed to map to machine registers.
111
112 getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
113 getRegsWithoutNode dflags =
114 ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
115 , realFloatRegs dflags
116 , realDoubleRegs dflags
117 , realLongRegs dflags)
118
119 -- getRegsWithNode uses R1/node even if it isn't a register
120 getRegsWithNode dflags =
121 ( if null (realVanillaRegs dflags)
122 then [VanillaReg 1]
123 else realVanillaRegs dflags
124 , realFloatRegs dflags
125 , realDoubleRegs dflags
126 , realLongRegs dflags)
127
128 allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
129 allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
130
131 allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
132 allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
133 allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
134 allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
135
136 realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
137 realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
138
139 realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
140 realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
141 realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
142 realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
143
144 regList :: Int -> [Int]
145 regList n = [1 .. n]
146
147 allRegs :: DynFlags -> AvailRegs
148 allRegs dflags = (allVanillaRegs dflags,
149 allFloatRegs dflags,
150 allDoubleRegs dflags,
151 allLongRegs dflags)
152
153 noRegs :: AvailRegs
154 noRegs = ([], [], [], [])
155
156 globalArgRegs :: DynFlags -> [GlobalReg]
157 globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
158 allFloatRegs dflags ++
159 allDoubleRegs dflags ++
160 allLongRegs dflags