2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 % $Id: CgRetConv.lhs,v 1.29 2000/11/14 17:41:04 sewardj Exp $
6 \section[CgRetConv]{Return conventions for the code generator}
8 The datatypes and functions here encapsulate what there is to know
9 about return conventions.
13 CtrlReturnConvention(..),
16 assignRegs, assignAllRegs
19 #include "HsVersions.h"
21 import AbsCSyn -- quite a few things
22 import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
23 mAX_Vanilla_REG, mAX_Float_REG,
24 mAX_Double_REG, mAX_Long_REG,
25 mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
26 mAX_Real_Double_REG, mAX_Real_Long_REG
28 import CmdLineOpts ( opt_Unregisterised )
29 import Maybes ( catMaybes )
30 import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
31 import TyCon ( TyCon, tyConFamilySize )
32 import Util ( isn'tIn )
37 %************************************************************************
39 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
41 %************************************************************************
43 A @CtrlReturnConvention@ says how {\em control} is returned.
45 data CtrlReturnConvention
46 = VectoredReturn Int -- size of the vector table (family size)
47 | UnvectoredReturn Int -- family size
50 %************************************************************************
52 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
54 %************************************************************************
57 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
59 ctrlReturnConvAlg tycon
60 = case (tyConFamilySize tycon) of
61 0 -> pprPanic "ctrlRetConvAlg" (ppr tycon)
62 size -> -- we're supposed to know...
63 if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
69 %************************************************************************
71 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
73 %************************************************************************
76 dataReturnConvPrim :: PrimRep -> MagicId
78 dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1)
79 dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1)
80 dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1)
81 dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1)
82 dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1)
83 dataReturnConvPrim CharRep = VanillaReg CharRep (_ILIT 1)
84 dataReturnConvPrim Int8Rep = VanillaReg Int8Rep (_ILIT 1)
85 dataReturnConvPrim FloatRep = FloatReg (_ILIT 1)
86 dataReturnConvPrim DoubleRep = DoubleReg (_ILIT 1)
87 dataReturnConvPrim VoidRep = VoidReg
89 -- Return a primitive-array pointer in the usual register:
90 dataReturnConvPrim ArrayRep = VanillaReg ArrayRep (_ILIT 1)
91 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep (_ILIT 1)
92 dataReturnConvPrim PrimPtrRep = VanillaReg PrimPtrRep (_ILIT 1)
93 dataReturnConvPrim ThreadIdRep = VanillaReg ThreadIdRep (_ILIT 1)
95 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep (_ILIT 1)
96 dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep (_ILIT 1)
97 dataReturnConvPrim WeakPtrRep = VanillaReg WeakPtrRep (_ILIT 1)
100 dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep)
104 %************************************************************************
106 \subsubsection[CgRetConv-regs]{Register assignment}
108 %************************************************************************
110 How to assign registers for
112 1) Calling a fast entry point.
113 2) Returning an unboxed tuple.
114 3) Invoking an out-of-line PrimOp.
116 Registers are assigned in order.
118 If we run out, we don't attempt to assign any further registers (even
119 though we might have run out of only one kind of register); we just
120 return immediately with the left-overs specified.
122 The alternative version @assignAllRegs@ uses the complete set of
123 registers, including those that aren't mapped to real machine
124 registers. This is used for calling special RTS functions and PrimOps
125 which expect their arguments to always be in the same registers.
128 assignRegs, assignAllRegs
129 :: [MagicId] -- Unavailable registers
130 -> [PrimRep] -- Arg or result kinds to assign
131 -> ([MagicId], -- Register assignment in same order
132 -- for *initial segment of* input list
133 [PrimRep])-- leftover kinds
135 assignRegs regs_in_use kinds
136 = assign_reg kinds [] (mkRegTbl regs_in_use)
138 assignAllRegs regs_in_use kinds
139 = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
142 :: [PrimRep] -- arg kinds being scrutinized
143 -> [MagicId] -- accum. regs assigned so far (reversed)
144 -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
145 -> ([MagicId], [PrimRep])
147 assign_reg (VoidRep:ks) acc supply
148 = assign_reg ks (VoidReg:acc) supply
149 -- one VoidReg is enough for everybody!
151 assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
152 = assign_reg ks (FloatReg (iUnbox f):acc)
153 (vanilla_rs, float_rs, double_rs, long_rs)
155 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
156 = assign_reg ks (DoubleReg (iUnbox d):acc)
157 (vanilla_rs, float_rs, double_rs, long_rs)
159 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
160 = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
161 (vanilla_rs, float_rs, double_rs, long_rs)
163 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
164 = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
165 (vanilla_rs, float_rs, double_rs, long_rs)
167 assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
168 | not (isFloatingRep k || is64BitRep k)
169 = assign_reg ks (VanillaReg k (iUnbox v):acc)
170 (vanilla_rs, float_rs, double_rs, long_rs)
172 -- The catch-all. It can happen because either
173 -- (a) we've assigned all the regs so leftover_ks is []
174 -- (b) we couldn't find a spare register in the appropriate supply
176 -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
177 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
181 Register supplies. Vanilla registers can contain pointers, Ints, Chars.
182 Floats and doubles have separate register supplies.
184 We take these register supplies from the *real* registers, i.e. those
185 that are guaranteed to map to machine registers.
188 useVanillaRegs | opt_Unregisterised = 0
189 | otherwise = mAX_Real_Vanilla_REG
190 useFloatRegs | opt_Unregisterised = 0
191 | otherwise = mAX_Real_Float_REG
192 useDoubleRegs | opt_Unregisterised = 0
193 | otherwise = mAX_Real_Double_REG
194 useLongRegs | opt_Unregisterised = 0
195 | otherwise = mAX_Real_Long_REG
197 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
198 vanillaRegNos = regList useVanillaRegs
199 floatRegNos = regList useFloatRegs
200 doubleRegNos = regList useDoubleRegs
201 longRegNos = regList useLongRegs
203 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
204 allVanillaRegNos = regList mAX_Vanilla_REG
205 allFloatRegNos = regList mAX_Float_REG
206 allDoubleRegNos = regList mAX_Double_REG
207 allLongRegNos = regList mAX_Long_REG
212 type AvailRegs = ( [Int] -- available vanilla regs.
215 , [Int] -- longs (int64 and word64)
218 mkRegTbl :: [MagicId] -> AvailRegs
220 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
222 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
223 mkRegTbl_allRegs regs_in_use
224 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
226 mkRegTbl' regs_in_use vanillas floats doubles longs
227 = (ok_vanilla, ok_float, ok_double, ok_long)
229 ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas)
230 ok_float = catMaybes (map (select FloatReg) floats)
231 ok_double = catMaybes (map (select DoubleReg) doubles)
232 ok_long = catMaybes (map (select (LongReg Int64Rep)) longs)
233 -- rep isn't looked at, hence we can use any old rep.
235 select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
236 -- one we've unboxed the Int, we make a MagicId
237 -- and see if it is already in use; if not, return its number.
239 select mk_reg_fun cand
241 reg = mk_reg_fun (iUnbox cand)
243 if reg `not_elem` regs_in_use
247 not_elem = isn'tIn "mkRegTbl"