%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
-% $Id: CgRetConv.lhs,v 1.15 1998/12/02 13:17:51 simonm Exp $
+% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
import AbsCSyn -- quite a few things
import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG,
+ mAX_Double_REG, mAX_Long_REG,
mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
- mAX_Real_Double_REG,
- mAX_Long_REG
+ mAX_Real_Double_REG, mAX_Real_Long_REG
)
-import Maybes ( catMaybes )
-import DataCon ( dataConRawArgTys, DataCon )
-import PrimOp ( PrimOp{-instance Outputable-} )
+import CmdLineOpts ( opt_Unregisterised )
+import Maybes ( mapCatMaybes )
import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
-import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
-import Type ( Type, typePrimRep, isUnLiftedType,
- splitAlgTyConApp_maybe )
+import TyCon ( TyCon, tyConFamilySize )
import Util ( isn'tIn )
-
+import FastTypes
import Outputable
\end{code}
ctrlReturnConvAlg tycon
= case (tyConFamilySize tycon) of
- 0 -> panic "ctrlRetConvAlg"
size -> -- we're supposed to know...
if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
VectoredReturn size
else
- UnvectoredReturn size
+ UnvectoredReturn size
+ -- NB: unvectored returns Include size 0 (no constructors), so that
+ -- the following perverse code compiles (it crashed GHC in 5.02)
+ -- data T1
+ -- data T2 = T2 !T1 Int
+ -- The only value of type T1 is bottom, which never returns anyway.
\end{code}
%************************************************************************
\begin{code}
dataReturnConvPrim :: PrimRep -> MagicId
-dataReturnConvPrim IntRep = VanillaReg IntRep ILIT(1)
-dataReturnConvPrim WordRep = VanillaReg WordRep ILIT(1)
-dataReturnConvPrim Int64Rep = LongReg Int64Rep ILIT(1)
-dataReturnConvPrim Word64Rep = LongReg Word64Rep ILIT(1)
-dataReturnConvPrim AddrRep = VanillaReg AddrRep ILIT(1)
-dataReturnConvPrim CharRep = VanillaReg CharRep ILIT(1)
-dataReturnConvPrim FloatRep = FloatReg ILIT(1)
-dataReturnConvPrim DoubleRep = DoubleReg ILIT(1)
+dataReturnConvPrim PtrRep = VanillaReg PtrRep (_ILIT 1)
+dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1)
+dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1)
+dataReturnConvPrim Int32Rep = VanillaReg Int32Rep (_ILIT 1)
+dataReturnConvPrim Word32Rep = VanillaReg Word32Rep (_ILIT 1)
+dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1)
+dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1)
+dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1)
+dataReturnConvPrim CharRep = VanillaReg CharRep (_ILIT 1)
+dataReturnConvPrim Int8Rep = VanillaReg Int8Rep (_ILIT 1)
+dataReturnConvPrim FloatRep = FloatReg (_ILIT 1)
+dataReturnConvPrim DoubleRep = DoubleReg (_ILIT 1)
+dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep (_ILIT 1)
dataReturnConvPrim VoidRep = VoidReg
--- Return a primitive-array pointer in the usual register:
-dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1)
-dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
-
-dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
-dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
-dataReturnConvPrim WeakPtrRep = VanillaReg WeakPtrRep ILIT(1)
-
#ifdef DEBUG
-dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
-dataReturnConvPrim _ = panic "dataReturnConvPrim: other"
+dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep)
#endif
\end{code}
= assign_reg ks (VoidReg:acc) supply
-- one VoidReg is enough for everybody!
-assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs, long_rs)
- = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
+ = assign_reg ks (FloatReg (iUnbox f):acc)
+ (vanilla_rs, float_rs, double_rs, long_rs)
-assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs, long_rs)
- = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
+ = assign_reg ks (DoubleReg (iUnbox d):acc)
+ (vanilla_rs, float_rs, double_rs, long_rs)
-assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(u):long_rs)
- = assign_reg ks (LongReg Word64Rep u:acc) (vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
+ = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
+ (vanilla_rs, float_rs, double_rs, long_rs)
-assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(l):long_rs)
- = assign_reg ks (LongReg Int64Rep l:acc) (vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
+ = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
+ (vanilla_rs, float_rs, double_rs, long_rs)
-assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs, long_rs)
+assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
| not (isFloatingRep k || is64BitRep k)
- = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs, long_rs)
+ = assign_reg ks (VanillaReg k (iUnbox v):acc)
+ (vanilla_rs, float_rs, double_rs, long_rs)
-- The catch-all. It can happen because either
-- (a) we've assigned all the regs so leftover_ks is []
that are guaranteed to map to machine registers.
\begin{code}
-vanillaRegNos, floatRegNos, doubleRegNos :: [Int]
-vanillaRegNos = [1 .. mAX_Real_Vanilla_REG]
-floatRegNos = [1 .. mAX_Real_Float_REG]
-doubleRegNos = [1 .. mAX_Real_Double_REG]
-longRegNos = [1 .. mAX_Long_REG]
+useVanillaRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Vanilla_REG
+useFloatRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Float_REG
+useDoubleRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Double_REG
+useLongRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Long_REG
+
+vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
+vanillaRegNos = regList useVanillaRegs
+floatRegNos = regList useFloatRegs
+doubleRegNos = regList useDoubleRegs
+longRegNos = regList useLongRegs
allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
-allVanillaRegNos = [1 .. mAX_Vanilla_REG]
-allFloatRegNos = [1 .. mAX_Float_REG]
-allDoubleRegNos = [1 .. mAX_Double_REG]
-allLongRegNos = [1 .. mAX_Double_REG]
+allVanillaRegNos = regList mAX_Vanilla_REG
+allFloatRegNos = regList mAX_Float_REG
+allDoubleRegNos = regList mAX_Double_REG
+allLongRegNos = regList mAX_Long_REG
+
+regList 0 = []
+regList n = [1 .. n]
type AvailRegs = ( [Int] -- available vanilla regs.
, [Int] -- floats
mkRegTbl' regs_in_use vanillas floats doubles longs
= (ok_vanilla, ok_float, ok_double, ok_long)
where
- ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas)
- ok_float = catMaybes (map (select FloatReg) floats)
- ok_double = catMaybes (map (select DoubleReg) doubles)
- ok_long = catMaybes (map (select (LongReg Int64Rep)) longs)
+ ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas
+ ok_float = mapCatMaybes (select FloatReg) floats
+ ok_double = mapCatMaybes (select DoubleReg) doubles
+ ok_long = mapCatMaybes (select (LongReg Int64Rep)) longs
-- rep isn't looked at, hence we can use any old rep.
- select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
+ select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
-- one we've unboxed the Int, we make a MagicId
-- and see if it is already in use; if not, return its number.
- select mk_reg_fun cand@IBOX(i)
+ select mk_reg_fun cand
= let
- reg = mk_reg_fun i
+ reg = mk_reg_fun (iUnbox cand)
in
if reg `not_elem` regs_in_use
then Just cand
projects / ghc-hetmet.git / blobdiff