%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1998
+%
+% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
about return conventions.
\begin{code}
-#include "HsVersions.h"
-
module CgRetConv (
- CtrlReturnConvention(..), DataReturnConvention(..),
-
+ CtrlReturnConvention(..),
ctrlReturnConvAlg,
- dataReturnConvAlg,
-
dataReturnConvPrim,
-
- assignPrimOpResultRegs,
- makePrimOpArgsRobust,
- assignRegs
-
- -- and to make the interface self-sufficient...
+ assignRegs, assignAllRegs
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- paranoia checking
+#include "HsVersions.h"
import AbsCSyn -- quite a few things
-import AbsCUtils ( mkAbstractCs, getAmodeRep,
- amodeCanSurviveGC
- )
-import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
mAX_Vanilla_REG, mAX_Float_REG,
- mAX_Double_REG
- )
-import CmdLineOpts ( opt_ReturnInRegsThreshold )
-import Id ( isDataCon, dataConSig,
- DataCon(..), GenId{-instance Eq-}
- )
-import Maybes ( catMaybes )
-import PprStyle ( PprStyle(..) )
-import PprType ( TyCon{-instance Outputable-} )
-import PrimOp ( primOpCanTriggerGC,
- getPrimOpResultInfo, PrimOpResultInfo(..),
- PrimOp{-instance Outputable-}
- )
-import PrimRep ( isFloatingRep, PrimRep(..) )
-import TyCon ( tyConDataCons, tyConFamilySize )
-import Type ( typePrimRep )
-import Util ( zipWithEqual, mapAccumL, isn'tIn,
- pprError, pprTrace, panic, assertPanic
+ mAX_Double_REG, mAX_Long_REG,
+ mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
+ mAX_Real_Double_REG, mAX_Real_Long_REG
)
+import CmdLineOpts ( opt_Unregisterised )
+import Maybes ( mapCatMaybes )
+import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
+import TyCon ( TyCon, tyConFamilySize )
+import Util ( isn'tIn )
+import FastTypes
+import Outputable
\end{code}
%************************************************************************
| UnvectoredReturn Int -- family size
\end{code}
-A @DataReturnConvention@ says how the data for a particular
-data-constructor is returned.
-\begin{code}
-data DataReturnConvention
- = ReturnInHeap
- | ReturnInRegs [MagicId]
-\end{code}
-The register assignment given by a @ReturnInRegs@ obeys three rules:
-\begin{itemize}
-\item R1 is dead.
-\item R2 points to the info table for the phantom constructor
-\item The list of @MagicId@ is in the same order as the arguments
- to the constructor.
-\end{itemize}
-
-
%************************************************************************
%* *
\subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
ctrlReturnConvAlg tycon
= case (tyConFamilySize tycon) of
- 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $
- UnvectoredReturn 0 -- e.g., w/ "data Bin"
-
size -> -- we're supposed to know...
if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
VectoredReturn size
else
- UnvectoredReturn size
-\end{code}
-
-@dataReturnConvAlg@ determines the return conventions from the
-(possibly specialised) data constructor.
-
-(See also @getDataConReturnConv@ (in @Id@).) We grab the types
-of the data constructor's arguments. We feed them and a list of
-available registers into @assign_reg@, which sequentially assigns
-registers of the appropriate types to the arguments, based on the
-types. If @assign_reg@ runs out of a particular kind of register,
-then it gives up, returning @ReturnInHeap@.
-
-\begin{code}
-dataReturnConvAlg :: DataCon -> DataReturnConvention
-
-dataReturnConvAlg data_con
- = ASSERT(isDataCon data_con)
- case leftover_kinds of
- [] -> ReturnInRegs reg_assignment
- other -> ReturnInHeap -- Didn't fit in registers
- where
- (_, _, arg_tys, _) = dataConSig data_con
-
- (reg_assignment, leftover_kinds)
- = assignRegs [node, infoptr] -- taken...
- (map typePrimRep arg_tys)
+ 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}
%************************************************************************
%* *
%************************************************************************
-WARNING! If you add a return convention which can return a pointer,
-make sure you alter CgCase (cgPrimDefault) to generate the right sort
-of heap check!
\begin{code}
dataReturnConvPrim :: PrimRep -> MagicId
-dataReturnConvPrim IntRep = VanillaReg IntRep ILIT(1)
-dataReturnConvPrim WordRep = VanillaReg WordRep 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)
-
#ifdef DEBUG
-dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
-dataReturnConvPrim _ = panic "dataReturnConvPrim: other"
+dataReturnConvPrim rep = pprPanic "dataReturnConvPrim:" (ppr rep)
#endif
\end{code}
-%********************************************************
-%* *
-\subsection[primop-stuff]{Argument and return conventions for Prim Ops}
-%* *
-%********************************************************
-
-\begin{code}
-assignPrimOpResultRegs
- :: PrimOp -- The constructors in canonical order
- -> [MagicId] -- The return regs all concatenated to together,
- -- (*including* one for the tag if necy)
-
-assignPrimOpResultRegs op
- = case (getPrimOpResultInfo op) of
-
- ReturnsPrim kind -> [dataReturnConvPrim kind]
-
- ReturnsAlg tycon
- -> let
- cons = tyConDataCons tycon
- result_regs = concat (map get_return_regs cons)
- in
- -- As R1 is dead, it can hold the tag if necessary
- case cons of
- [_] -> result_regs
- other -> (VanillaReg IntRep ILIT(1)) : result_regs
- where
- get_return_regs con
- = case (dataReturnConvAlg con) of
- ReturnInRegs regs -> regs
- ReturnInHeap -> panic "getPrimOpAlgResultRegs"
-\end{code}
-
-@assignPrimOpArgsRobust@ is used only for primitive ops which may
-trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust)
-arguments in registers. This function assigns them and tells us which
-of those registers are now live (because we've shoved a followable
-argument into it).
-
-Bug: it is assumed that robust amodes cannot contain pointers. This
-seems reasonable but isn't true. For example, \tr{Array#}'s
-\tr{ForeignObj#}'s are pointers. (This is only known to bite on
-\tr{_ccall_GC_} with a ForeignObj argument.)
-
-See after for some ADR comments...
-
-\begin{code}
-makePrimOpArgsRobust
- :: PrimOp
- -> [CAddrMode] -- Arguments
- -> ([CAddrMode], -- Arg registers
- Int, -- Liveness mask
- AbstractC) -- Simultaneous assignments to assign args to regs
-
-makePrimOpArgsRobust op arg_amodes
- = ASSERT (primOpCanTriggerGC op)
- let
- non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
- arg_kinds = map getAmodeRep non_robust_amodes
-
- (arg_regs, extra_args)
- = assignRegs [{-nothing live-}] arg_kinds
-
- -- Check that all the args fit before returning arg_regs
- final_arg_regs = case extra_args of
- [] -> arg_regs
- other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op)
-
- arg_assts
- = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes)
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
-
- safe_arg regs arg
- | amodeCanSurviveGC arg = (regs, arg)
- | otherwise = (tail regs, CReg (head regs))
- safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
-
- liveness_mask = mkLiveRegsMask final_arg_regs
- in
- (safe_amodes, liveness_mask, arg_assts)
-\end{code}
-
%************************************************************************
%* *
\subsubsection[CgRetConv-regs]{Register assignment}
%* *
%************************************************************************
-How to assign registers.
+How to assign registers for
+
+ 1) Calling a fast entry point.
+ 2) Returning an unboxed tuple.
+ 3) Invoking an out-of-line PrimOp.
+
Registers are assigned in order.
-If we run out, we don't attempt to assign
-any further registers (even though we might have run out of only one kind of
-register); we just return immediately with the left-overs specified.
+If we run out, we don't attempt to assign any further registers (even
+though we might have run out of only one kind of register); we just
+return immediately with the left-overs specified.
+
+The alternative version @assignAllRegs@ uses the complete set of
+registers, including those that aren't mapped to real machine
+registers. This is used for calling special RTS functions and PrimOps
+which expect their arguments to always be in the same registers.
\begin{code}
-assignRegs :: [MagicId] -- Unavailable registers
- -> [PrimRep] -- Arg or result kinds to assign
- -> ([MagicId], -- Register assignment in same order
+assignRegs, assignAllRegs
+ :: [MagicId] -- Unavailable registers
+ -> [PrimRep] -- Arg or result kinds to assign
+ -> ([MagicId], -- Register assignment in same order
-- for *initial segment of* input list
- [PrimRep])-- leftover kinds
+ [PrimRep])-- leftover kinds
assignRegs regs_in_use kinds
= assign_reg kinds [] (mkRegTbl regs_in_use)
- where
- assign_reg :: [PrimRep] -- arg kinds being scrutinized
- -> [MagicId] -- accum. regs assigned so far (reversed)
- -> ([Int], [Int], [Int])
- -- regs still avail: Vanilla, Float, Double
- -> ([MagicId], [PrimRep])
+assignAllRegs regs_in_use kinds
+ = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
- assign_reg (VoidRep:ks) acc supply
- = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
+assign_reg
+ :: [PrimRep] -- arg kinds being scrutinized
+ -> [MagicId] -- accum. regs assigned so far (reversed)
+ -> AvailRegs -- regs still avail: Vanilla, Float, Double, longs
+ -> ([MagicId], [PrimRep])
- assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
- = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
+assign_reg (VoidRep:ks) acc supply
+ = assign_reg ks (VoidReg:acc) supply
+ -- one VoidReg is enough for everybody!
- assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
- = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_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 (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
- | not (isFloatingRep k)
- = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_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)
- -- The catch-all. It can happen because either
- -- (a) we've assigned all the regs so leftover_ks is []
- -- (b) we couldn't find a spare register in the appropriate supply
- -- or, I suppose,
- -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
- assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-\end{code}
+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)
-Register supplies. Vanilla registers can contain pointers, Ints, Chars.
+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 (v:vanilla_rs, float_rs, double_rs, long_rs)
+ | not (isFloatingRep k || is64BitRep k)
+ = 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 []
+-- (b) we couldn't find a spare register in the appropriate supply
+-- or, I suppose,
+-- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
+assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-\begin{code}
-vanillaRegNos :: [Int]
-vanillaRegNos = [1 .. mAX_Vanilla_REG]
\end{code}
+Register supplies. Vanilla registers can contain pointers, Ints, Chars.
Floats and doubles have separate register supplies.
+We take these register supplies from the *real* registers, i.e. those
+that are guaranteed to map to machine registers.
+
\begin{code}
-floatRegNos, doubleRegNos :: [Int]
-floatRegNos = [1 .. mAX_Float_REG]
-doubleRegNos = [1 .. mAX_Double_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 = 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
+ , [Int] -- doubles
+ , [Int] -- longs (int64 and word64)
+ )
+
+mkRegTbl :: [MagicId] -> AvailRegs
+mkRegTbl regs_in_use
+ = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
-mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
+mkRegTbl_allRegs :: [MagicId] -> AvailRegs
+mkRegTbl_allRegs regs_in_use
+ = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
-mkRegTbl regs_in_use
- = (ok_vanilla, ok_float, ok_double)
+mkRegTbl' regs_in_use vanillas floats doubles longs
+ = (ok_vanilla, ok_float, ok_double, ok_long)
where
- ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
- ok_float = catMaybes (map (select FloatReg) floatRegNos)
- ok_double = catMaybes (map (select DoubleReg) doubleRegNos)
-
- taker :: [Int] -> [Int]
- taker rs
- = case (opt_ReturnInRegsThreshold) of
- Nothing -> rs -- no flag set; use all of them
- Just n -> take n rs
+ 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