2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 % $Id: CgRetConv.lhs,v 1.32 2002/08/02 13:08:34 simonmar 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 size -> -- we're supposed to know...
62 if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
66 -- NB: unvectored returns Include size 0 (no constructors), so that
67 -- the following perverse code compiles (it crashed GHC in 5.02)
69 -- data T2 = T2 !T1 Int
70 -- The only value of type T1 is bottom, which never returns anyway.
73 %************************************************************************
75 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
77 %************************************************************************
80 dataReturnConvPrim :: PrimRep -> MagicId
82 dataReturnConvPrim PtrRep = VanillaReg PtrRep (_ILIT 1)
83 dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1)
84 dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1)
85 dataReturnConvPrim Int32Rep = VanillaReg Int32Rep (_ILIT 1)
86 dataReturnConvPrim Word32Rep = VanillaReg Word32Rep (_ILIT 1)
87 dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1)
88 dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1)
89 dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1)
90 dataReturnConvPrim CharRep = VanillaReg CharRep (_ILIT 1)
91 dataReturnConvPrim Int8Rep = VanillaReg Int8Rep (_ILIT 1)
92 dataReturnConvPrim FloatRep = FloatReg (_ILIT 1)
93 dataReturnConvPrim DoubleRep = DoubleReg (_ILIT 1)
94 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep (_ILIT 1)
95 dataReturnConvPrim VoidRep = VoidReg
98 dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep)
102 %************************************************************************
104 \subsubsection[CgRetConv-regs]{Register assignment}
106 %************************************************************************
108 How to assign registers for
110 1) Calling a fast entry point.
111 2) Returning an unboxed tuple.
112 3) Invoking an out-of-line PrimOp.
114 Registers are assigned in order.
116 If we run out, we don't attempt to assign any further registers (even
117 though we might have run out of only one kind of register); we just
118 return immediately with the left-overs specified.
120 The alternative version @assignAllRegs@ uses the complete set of
121 registers, including those that aren't mapped to real machine
122 registers. This is used for calling special RTS functions and PrimOps
123 which expect their arguments to always be in the same registers.
126 assignRegs, assignAllRegs
127 :: [MagicId] -- Unavailable registers
128 -> [PrimRep] -- Arg or result kinds to assign
129 -> ([MagicId], -- Register assignment in same order
130 -- for *initial segment of* input list
131 [PrimRep])-- leftover kinds
133 assignRegs regs_in_use kinds
134 = assign_reg kinds [] (mkRegTbl regs_in_use)
136 assignAllRegs regs_in_use kinds
137 = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
140 :: [PrimRep] -- arg kinds being scrutinized
141 -> [MagicId] -- accum. regs assigned so far (reversed)
142 -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
143 -> ([MagicId], [PrimRep])
145 assign_reg (VoidRep:ks) acc supply
146 = assign_reg ks (VoidReg:acc) supply
147 -- one VoidReg is enough for everybody!
149 assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
150 = assign_reg ks (FloatReg (iUnbox f):acc)
151 (vanilla_rs, float_rs, double_rs, long_rs)
153 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
154 = assign_reg ks (DoubleReg (iUnbox d):acc)
155 (vanilla_rs, float_rs, double_rs, long_rs)
157 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
158 = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
159 (vanilla_rs, float_rs, double_rs, long_rs)
161 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
162 = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
163 (vanilla_rs, float_rs, double_rs, long_rs)
165 assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
166 | not (isFloatingRep k || is64BitRep k)
167 = assign_reg ks (VanillaReg k (iUnbox v):acc)
168 (vanilla_rs, float_rs, double_rs, long_rs)
170 -- The catch-all. It can happen because either
171 -- (a) we've assigned all the regs so leftover_ks is []
172 -- (b) we couldn't find a spare register in the appropriate supply
174 -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
175 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
179 Register supplies. Vanilla registers can contain pointers, Ints, Chars.
180 Floats and doubles have separate register supplies.
182 We take these register supplies from the *real* registers, i.e. those
183 that are guaranteed to map to machine registers.
186 useVanillaRegs | opt_Unregisterised = 0
187 | otherwise = mAX_Real_Vanilla_REG
188 useFloatRegs | opt_Unregisterised = 0
189 | otherwise = mAX_Real_Float_REG
190 useDoubleRegs | opt_Unregisterised = 0
191 | otherwise = mAX_Real_Double_REG
192 useLongRegs | opt_Unregisterised = 0
193 | otherwise = mAX_Real_Long_REG
195 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
196 vanillaRegNos = regList useVanillaRegs
197 floatRegNos = regList useFloatRegs
198 doubleRegNos = regList useDoubleRegs
199 longRegNos = regList useLongRegs
201 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
202 allVanillaRegNos = regList mAX_Vanilla_REG
203 allFloatRegNos = regList mAX_Float_REG
204 allDoubleRegNos = regList mAX_Double_REG
205 allLongRegNos = regList mAX_Long_REG
210 type AvailRegs = ( [Int] -- available vanilla regs.
213 , [Int] -- longs (int64 and word64)
216 mkRegTbl :: [MagicId] -> AvailRegs
218 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
220 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
221 mkRegTbl_allRegs regs_in_use
222 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
224 mkRegTbl' regs_in_use vanillas floats doubles longs
225 = (ok_vanilla, ok_float, ok_double, ok_long)
227 ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas)
228 ok_float = catMaybes (map (select FloatReg) floats)
229 ok_double = catMaybes (map (select DoubleReg) doubles)
230 ok_long = catMaybes (map (select (LongReg Int64Rep)) longs)
231 -- rep isn't looked at, hence we can use any old rep.
233 select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
234 -- one we've unboxed the Int, we make a MagicId
235 -- and see if it is already in use; if not, return its number.
237 select mk_reg_fun cand
239 reg = mk_reg_fun (iUnbox cand)
241 if reg `not_elem` regs_in_use
245 not_elem = isn'tIn "mkRegTbl"