2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 % $Id: CgRetConv.lhs,v 1.19 1999/05/13 17:30:58 simonm 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
26 import CmdLineOpts ( opt_UseVanillaRegs, opt_UseFloatRegs,
27 opt_UseDoubleRegs, opt_UseLongRegs
29 import Maybes ( catMaybes )
30 import DataCon ( dataConRawArgTys, DataCon )
31 import PrimOp ( PrimOp{-instance Outputable-} )
32 import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
33 import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
34 import Type ( Type, typePrimRep, isUnLiftedType,
35 splitAlgTyConApp_maybe )
36 import Util ( isn'tIn )
41 %************************************************************************
43 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
45 %************************************************************************
47 A @CtrlReturnConvention@ says how {\em control} is returned.
49 data CtrlReturnConvention
50 = VectoredReturn Int -- size of the vector table (family size)
51 | UnvectoredReturn Int -- family size
54 %************************************************************************
56 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
58 %************************************************************************
61 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
63 ctrlReturnConvAlg tycon
64 = case (tyConFamilySize tycon) of
65 0 -> panic "ctrlRetConvAlg"
66 size -> -- we're supposed to know...
67 if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
73 %************************************************************************
75 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
77 %************************************************************************
80 dataReturnConvPrim :: PrimRep -> MagicId
82 dataReturnConvPrim IntRep = VanillaReg IntRep ILIT(1)
83 dataReturnConvPrim WordRep = VanillaReg WordRep ILIT(1)
84 dataReturnConvPrim Int64Rep = LongReg Int64Rep ILIT(1)
85 dataReturnConvPrim Word64Rep = LongReg Word64Rep ILIT(1)
86 dataReturnConvPrim AddrRep = VanillaReg AddrRep ILIT(1)
87 dataReturnConvPrim CharRep = VanillaReg CharRep ILIT(1)
88 dataReturnConvPrim FloatRep = FloatReg ILIT(1)
89 dataReturnConvPrim DoubleRep = DoubleReg ILIT(1)
90 dataReturnConvPrim VoidRep = VoidReg
92 -- Return a primitive-array pointer in the usual register:
93 dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1)
94 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
96 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
97 dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
98 dataReturnConvPrim WeakPtrRep = VanillaReg WeakPtrRep ILIT(1)
101 dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
102 dataReturnConvPrim _ = panic "dataReturnConvPrim: other"
106 %************************************************************************
108 \subsubsection[CgRetConv-regs]{Register assignment}
110 %************************************************************************
112 How to assign registers for
114 1) Calling a fast entry point.
115 2) Returning an unboxed tuple.
116 3) Invoking an out-of-line PrimOp.
118 Registers are assigned in order.
120 If we run out, we don't attempt to assign any further registers (even
121 though we might have run out of only one kind of register); we just
122 return immediately with the left-overs specified.
124 The alternative version @assignAllRegs@ uses the complete set of
125 registers, including those that aren't mapped to real machine
126 registers. This is used for calling special RTS functions and PrimOps
127 which expect their arguments to always be in the same registers.
130 assignRegs, assignAllRegs
131 :: [MagicId] -- Unavailable registers
132 -> [PrimRep] -- Arg or result kinds to assign
133 -> ([MagicId], -- Register assignment in same order
134 -- for *initial segment of* input list
135 [PrimRep])-- leftover kinds
137 assignRegs regs_in_use kinds
138 = assign_reg kinds [] (mkRegTbl regs_in_use)
140 assignAllRegs regs_in_use kinds
141 = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
144 :: [PrimRep] -- arg kinds being scrutinized
145 -> [MagicId] -- accum. regs assigned so far (reversed)
146 -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
147 -> ([MagicId], [PrimRep])
149 assign_reg (VoidRep:ks) acc supply
150 = assign_reg ks (VoidReg:acc) supply
151 -- one VoidReg is enough for everybody!
153 assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs, long_rs)
154 = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs, long_rs)
156 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs, long_rs)
157 = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs, long_rs)
159 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(u):long_rs)
160 = assign_reg ks (LongReg Word64Rep u:acc) (vanilla_rs, float_rs, double_rs, long_rs)
162 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(l):long_rs)
163 = assign_reg ks (LongReg Int64Rep l:acc) (vanilla_rs, float_rs, double_rs, long_rs)
165 assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs, long_rs)
166 | not (isFloatingRep k || is64BitRep k)
167 = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs, long_rs)
169 -- The catch-all. It can happen because either
170 -- (a) we've assigned all the regs so leftover_ks is []
171 -- (b) we couldn't find a spare register in the appropriate supply
173 -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
174 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
178 Register supplies. Vanilla registers can contain pointers, Ints, Chars.
179 Floats and doubles have separate register supplies.
181 We take these register supplies from the *real* registers, i.e. those
182 that are guaranteed to map to machine registers.
185 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
186 vanillaRegNos = regList opt_UseVanillaRegs
187 floatRegNos = regList opt_UseFloatRegs
188 doubleRegNos = regList opt_UseDoubleRegs
189 longRegNos = regList opt_UseLongRegs
191 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
192 allVanillaRegNos = regList mAX_Vanilla_REG
193 allFloatRegNos = regList mAX_Float_REG
194 allDoubleRegNos = regList mAX_Double_REG
195 allLongRegNos = regList mAX_Long_REG
200 type AvailRegs = ( [Int] -- available vanilla regs.
203 , [Int] -- longs (int64 and word64)
206 mkRegTbl :: [MagicId] -> AvailRegs
208 = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
210 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
211 mkRegTbl_allRegs regs_in_use
212 = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
214 mkRegTbl' regs_in_use vanillas floats doubles longs
215 = (ok_vanilla, ok_float, ok_double, ok_long)
217 ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas)
218 ok_float = catMaybes (map (select FloatReg) floats)
219 ok_double = catMaybes (map (select DoubleReg) doubles)
220 ok_long = catMaybes (map (select (LongReg Int64Rep)) longs)
221 -- rep isn't looked at, hence we can use any old rep.
223 select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
224 -- one we've unboxed the Int, we make a MagicId
225 -- and see if it is already in use; if not, return its number.
227 select mk_reg_fun cand@IBOX(i)
231 if reg `not_elem` regs_in_use
235 not_elem = isn'tIn "mkRegTbl"