X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgRetConv.lhs;h=c06d2db8be271bf4139108ddbac859f0cc108528;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=5881fb1f1ece4927f38b546c946d7695dc9cd44a;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 5881fb1..c06d2db 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,5 +1,7 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1995 +% (c) The GRASP Project, Glasgow University, 1992-1998 +% +% $Id: CgRetConv.lhs,v 1.15 1998/12/02 13:17:51 simonm Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -7,46 +9,33 @@ The datatypes and functions here encapsulate what there is to know about return conventions. \begin{code} -#include "HsVersions.h" - module CgRetConv ( - CtrlReturnConvention(..), DataReturnConvention(..), - + CtrlReturnConvention(..), ctrlReturnConvAlg, - dataReturnConvAlg, - - mkLiveRegsBitMask, noLiveRegsMask, - dataReturnConvPrim, - - assignPrimOpResultRegs, - makePrimOpArgsRobust, - assignRegs - - -- and to make the interface self-sufficient... + assignRegs, assignAllRegs ) where -import AbsCSyn +#include "HsVersions.h" -import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC, - getPrimOpResultInfo, integerDataCon - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import AbsCSyn -- quite a few things +import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, + mAX_Vanilla_REG, mAX_Float_REG, + mAX_Double_REG, + mAX_Real_Vanilla_REG, mAX_Real_Float_REG, + mAX_Real_Double_REG, + mAX_Long_REG ) -import Type ( getTyConFamilySize, primRepFromType, getTyConDataCons, - TyVarTemplate, TyCon, Class, - TauType(..), ThetaType(..), Type - ) -import CgCompInfo -- various things -import CgMonad ( IntSwitchChecker(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( Id, getDataConSig, fIRST_TAG, isDataCon, - DataCon(..), ConTag(..) - ) -import Maybes ( catMaybes, Maybe(..) ) -import PrimRep -import Util -import Pretty +import Maybes ( catMaybes ) +import DataCon ( dataConRawArgTys, DataCon ) +import PrimOp ( PrimOp{-instance Outputable-} ) +import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) +import TyCon ( TyCon, tyConDataCons, tyConFamilySize ) +import Type ( Type, typePrimRep, isUnLiftedType, + splitAlgTyConApp_maybe ) +import Util ( isn'tIn ) + +import Outputable \end{code} %************************************************************************ @@ -62,22 +51,6 @@ data CtrlReturnConvention | 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} @@ -88,104 +61,28 @@ The register assignment given by a @ReturnInRegs@ obeys three rules: ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention ctrlReturnConvAlg tycon - = case (getTyConFamilySize tycon) of - Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon) - UnvectoredReturn 0 -- e.g., w/ "data Bin" - - Just size -> -- we're supposed to know... + = 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 \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 :: IntSwitchChecker -> DataCon -> DataReturnConvention - -dataReturnConvAlg isw_chkr data_con - = ASSERT(isDataCon data_con) - case leftover_kinds of - [] -> ReturnInRegs reg_assignment - other -> ReturnInHeap -- Didn't fit in registers - where - (_, _, arg_tys, _) = getDataConSig data_con - - (reg_assignment, leftover_kinds) - = assignRegs isw_chkr_to_use - [node, infoptr] -- taken... - (map primRepFromType arg_tys) - - isw_chkr_to_use = isw_chkr - - is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11) -\end{code} - -\begin{code} -noLiveRegsMask :: Int -- Mask indicating nothing live -noLiveRegsMask = 0 - -mkLiveRegsBitMask - :: [MagicId] -- Candidate live regs; depends what they have in them - -> Int - -mkLiveRegsBitMask regs - = foldl do_reg noLiveRegsMask regs - where - do_reg acc (VanillaReg kind reg_no) - | isFollowableRep kind - = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1))) - - do_reg acc anything_else = acc - - reg_tbl -- ToDo: mk Array! - = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, - lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8] - -{- --- Completely opaque code. ADR --- What's wrong with: (untested) - -mkLiveRegsBitMask regs - = foldl (+) noLiveRegsMask (map liveness_bit regs) - where - liveness_bit (VanillaReg kind reg_no) - | isFollowableRep kind - = reg_tbl !! (reg_no - 1) - - liveness_bit anything_else - = noLiveRegsBitMask - - reg_tbl - = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4, - lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8] --} -\end{code} - - %************************************************************************ %* * \subsection[CgRetConv-prim]{Return conventions for primitive datatypes} %* * %************************************************************************ -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 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) @@ -197,7 +94,8 @@ dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1) dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1) dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1) -dataReturnConvPrim MallocPtrRep = VanillaReg MallocPtrRep ILIT(1) +dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1) +dataReturnConvPrim WeakPtrRep = VanillaReg WeakPtrRep ILIT(1) #ifdef DEBUG dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep" @@ -205,175 +103,119 @@ dataReturnConvPrim _ = panic "dataReturnConvPrim: other" #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 = getTyConDataCons 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 fake_isw_chkr con) of - ReturnInRegs regs -> regs - ReturnInHeap -> panic "getPrimOpAlgResultRegs" - - fake_isw_chkr :: IntSwitchChecker - fake_isw_chkr x = Nothing -\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{MallocPtr#}'s are pointers. (This is only known to bite on -\tr{_ccall_GC_} with a MallocPtr 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 fake_isw_chkr [{-nothing live-}] arg_kinds - - -- Check that all the args fit before returning arg_regs - final_arg_regs = case extra_args of - [] -> arg_regs - other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op)) - - arg_assts - = mkAbstractCs (zipWithEqual 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 = mkLiveRegsBitMask final_arg_regs - in - (safe_amodes, liveness_mask, arg_assts) - where - fake_isw_chkr :: IntSwitchChecker - fake_isw_chkr x = Nothing -\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 :: IntSwitchChecker - -> [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 isw_chkr regs_in_use kinds - = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use) - where +assignRegs regs_in_use kinds + = assign_reg kinds [] (mkRegTbl regs_in_use) - 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, IBOX(f):float_rs, double_rs, long_rs) + = assign_reg ks (FloatReg 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, IBOX(d):double_rs, long_rs) + = assign_reg ks (DoubleReg 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, IBOX(u):long_rs) + = assign_reg ks (LongReg Word64Rep 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, IBOX(l):long_rs) + = assign_reg ks (LongReg Int64Rep 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) + | not (isFloatingRep k || is64BitRep k) + = assign_reg ks (VanillaReg k 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. -\begin{code} -floatRegNos, doubleRegNos :: [Int] -floatRegNos = [1 .. mAX_Float_REG] -doubleRegNos = [1 .. mAX_Double_REG] - -mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int]) +We take these register supplies from the *real* registers, i.e. those +that are guaranteed to map to machine registers. -mkRegTbl isw_chkr regs_in_use - = (ok_vanilla, ok_float, ok_double) +\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] + +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] + +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_allRegs :: [MagicId] -> AvailRegs +mkRegTbl_allRegs regs_in_use + = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos + +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 (isw_chkr ReturnInRegsThreshold) of - Nothing -> rs -- no flag set; use all of them - Just n -> take n rs + 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) + -- rep isn't looked at, hence we can use any old rep. select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int -- one we've unboxed the Int, we make a MagicId