X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgRetConv.lhs;h=7389c0d62a3ffcb78e6c3f77e136f176f4e43376;hb=34cb1a0464a3d370b3c2e9de2fb399b8fbfab8c7;hp=679b7c07dfa91584a671c89a3f9d7435d416be38;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 679b7c0..7389c0d 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -15,41 +15,43 @@ module CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, - mkLiveRegsBitMask, noLiveRegsMask, - dataReturnConvPrim, assignPrimOpResultRegs, makePrimOpArgsRobust, - assignRegs, - - -- and to make the interface self-sufficient... - MagicId, PrimKind, Id, CLabel, TyCon + assignRegs ) where -import AbsCSyn +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) -- paranoia checking -import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC, - getPrimOpResultInfo, integerDataCon, PrimKind - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import AbsCSyn -- quite a few things +import AbsCUtils ( mkAbstractCs, getAmodeRep, + amodeCanSurviveGC + ) +import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, + mAX_Vanilla_REG, mAX_Float_REG, + mAX_Double_REG ) -import AbsUniType ( getTyConFamilySize, kindFromType, getTyConDataCons, - TyVarTemplate, TyCon, Class, - TauType(..), ThetaType(..), UniType - IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) - IF_ATTACK_PRAGMAS(COMMA cmpUniType) +import CmdLineOpts ( opt_ReturnInRegsThreshold ) +import Id ( isDataCon, dataConRawArgTys, + SYN_IE(DataCon), GenId{-instance Eq-}, + SYN_IE(Id) ) -import CgCompInfo -- various things -import CgMonad ( IntSwitchChecker(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( Id, getDataConSig, fIRST_TAG, isDataCon, - DataCon(..), ConTag(..) +import Maybes ( catMaybes ) +import Outputable ( PprStyle(..), Outputable(..) ) +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 Pretty ( Doc ) +import Util ( zipWithEqual, mapAccumL, isn'tIn, + pprError, pprTrace, panic, assertPanic, assertPprPanic ) -import Maybes ( catMaybes, Maybe(..) ) -import PrimKind -import Util -import Pretty \end{code} %************************************************************************ @@ -70,7 +72,7 @@ data-constructor is returned. \begin{code} data DataReturnConvention = ReturnInHeap - | ReturnInRegs [MagicId] + | ReturnInRegs [MagicId] \end{code} The register assignment given by a @ReturnInRegs@ obeys three rules: \begin{itemize} @@ -91,11 +93,11 @@ 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" + = case (tyConFamilySize tycon) of + 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $ + UnvectoredReturn 0 -- e.g., w/ "data Bin" - Just size -> -- we're supposed to know... + size -> -- we're supposed to know... if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then VectoredReturn size else @@ -113,72 +115,21 @@ 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 :: DataCon -> DataReturnConvention -dataReturnConvAlg isw_chkr data_con - = ASSERT(isDataCon data_con) +dataReturnConvAlg data_con + = ASSERT2(isDataCon data_con, (ppr PprDebug data_con)) case leftover_kinds of [] -> ReturnInRegs reg_assignment other -> ReturnInHeap -- Didn't fit in registers where - (_, _, arg_tys, _) = getDataConSig data_con + arg_tys = dataConRawArgTys data_con (reg_assignment, leftover_kinds) - = assignRegs isw_chkr_to_use - [node, infoptr] -- taken... - (map kindFromType arg_tys) - - isw_chkr_to_use = isw_chkr -{-OLD: - = if is_prim_result_ty {-and therefore *ignore* any return-in-regs threshold-} - then \ x -> Nothing - else isw_chkr --} - is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11) + = assignRegs [node, infoptr] -- taken... + (map typePrimRep arg_tys) \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) - | isFollowableKind 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) - | isFollowableKind 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} @@ -189,35 +140,29 @@ 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 :: PrimKind -> MagicId +dataReturnConvPrim :: PrimRep -> MagicId -#ifndef DPH -dataReturnConvPrim IntKind = VanillaReg IntKind ILIT(1) -dataReturnConvPrim WordKind = VanillaReg WordKind ILIT(1) -dataReturnConvPrim AddrKind = VanillaReg AddrKind ILIT(1) -dataReturnConvPrim CharKind = VanillaReg CharKind ILIT(1) -dataReturnConvPrim FloatKind = FloatReg ILIT(1) -dataReturnConvPrim DoubleKind = DoubleReg ILIT(1) -dataReturnConvPrim VoidKind = VoidReg +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 VoidRep = VoidReg -- Return a primitive-array pointer in the usual register: -dataReturnConvPrim ArrayKind = VanillaReg ArrayKind ILIT(1) -dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1) +dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1) +dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1) -dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1) -dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1) +dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1) +dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1) -dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind" +#ifdef DEBUG +dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep" dataReturnConvPrim _ = panic "dataReturnConvPrim: other" - -#else -dataReturnConvPrim VoidKind = VoidReg -dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind" -dataReturnConvPrim kind = DataReg kind 2 -- Don't Hog a Modifier reg. -#endif {- Data Parallel Haskell -} +#endif \end{code} - %******************************************************** %* * \subsection[primop-stuff]{Argument and return conventions for Prim Ops} @@ -237,21 +182,18 @@ assignPrimOpResultRegs op ReturnsAlg tycon -> let - cons = getTyConDataCons tycon + 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 IntKind ILIT(1)) : result_regs + other -> (VanillaReg IntRep ILIT(1)) : result_regs where get_return_regs con - = case (dataReturnConvAlg fake_isw_chkr con) of + = case (dataReturnConvAlg 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 @@ -262,8 +204,8 @@ 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.) +\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... @@ -279,30 +221,29 @@ makePrimOpArgsRobust op arg_amodes = ASSERT (primOpCanTriggerGC op) let non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes - arg_kinds = map getAmodeKind non_robust_amodes + arg_kinds = map getAmodeRep non_robust_amodes (arg_regs, extra_args) - = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds + = 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 -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op)) + 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) - arg_assts = mkAbstractCs (zipWith 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) + 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 + liveness_mask = mkLiveRegsMask final_arg_regs in (safe_amodes, liveness_mask, arg_assts) - where - fake_isw_chkr :: IntSwitchChecker - fake_isw_chkr x = Nothing \end{code} %************************************************************************ @@ -319,34 +260,33 @@ 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. \begin{code} -assignRegs :: IntSwitchChecker - -> [MagicId] -- Unavailable registers - -> [PrimKind] -- Arg or result kinds to assign +assignRegs :: [MagicId] -- Unavailable registers + -> [PrimRep] -- Arg or result kinds to assign -> ([MagicId], -- Register assignment in same order -- for *initial segment of* input list - [PrimKind])-- leftover kinds + [PrimRep])-- leftover kinds -assignRegs isw_chkr regs_in_use kinds - = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use) +assignRegs regs_in_use kinds + = assign_reg kinds [] (mkRegTbl regs_in_use) where - assign_reg :: [PrimKind] -- arg kinds being scrutinized + assign_reg :: [PrimRep] -- arg kinds being scrutinized -> [MagicId] -- accum. regs assigned so far (reversed) -> ([Int], [Int], [Int]) -- regs still avail: Vanilla, Float, Double - -> ([MagicId], [PrimKind]) + -> ([MagicId], [PrimRep]) - assign_reg (VoidKind:ks) acc supply + assign_reg (VoidRep:ks) acc supply = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody! - assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs) + 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 (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs) + 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 (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs) - | not (isFloatingKind k) + | not (isFloatingRep k) = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs) -- The catch-all. It can happen because either @@ -371,18 +311,18 @@ floatRegNos, doubleRegNos :: [Int] floatRegNos = [1 .. mAX_Float_REG] doubleRegNos = [1 .. mAX_Double_REG] -mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int]) +mkRegTbl :: [MagicId] -> ([Int], [Int], [Int]) -mkRegTbl isw_chkr regs_in_use +mkRegTbl regs_in_use = (ok_vanilla, ok_float, ok_double) where - ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) (taker vanillaRegNos)) + 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 + = case (opt_ReturnInRegsThreshold) of Nothing -> rs -- no flag set; use all of them Just n -> take n rs