From: simonpj Date: Fri, 8 Mar 2002 15:47:19 +0000 (+0000) Subject: [project @ 2002-03-08 15:47:18 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~2295 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4593b1053cdc55c10f3df804630a1d90890d8473;p=ghc-hetmet.git [project @ 2002-03-08 15:47:18 by simonpj] ------------------------ Kill Type.splitRepFunTys ------------------------ splitRepFunTys was a Bad Function that split up a function type looking through even recursive newtypes. Alas, it diverged if when we had a recursive newtype with a function whose result was the newtype itself. I've replaced it with ordinary splitFunTys, plus a new function Type.dropForAlls, which does what you would expect. --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 1f631d8..1863229 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -32,7 +32,7 @@ import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) -import Type ( Type, repType, splitRepFunTys ) +import Type ( Type, repType, splitFunTys, dropForAlls ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem, isSingleton, lengthIs ) import DataCon ( dataConRepArity ) @@ -976,7 +976,7 @@ mkDummyLiteral pr maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty - = let (a_tys, r_ty) = splitRepFunTys fn_ty + = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 41de1f9..edd3402 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -291,7 +291,7 @@ boxHigherOrderArgs almost_expr args do_arg ids bindings arg@(StgVarArg old_var) | (not (isLocalVar old_var) || elemVarSet old_var ids) - && isFunType var_type + && isFunTy (dropForAlls var_type) = -- make a trivial let-binding for the top-level function getUniqueMM `thenMM` \ uniq -> let @@ -314,10 +314,6 @@ boxHigherOrderArgs almost_expr args StgLet (StgNonRec NoSRT{-eeek!!!-} new_var rhs_closure) body where bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" - -isFunType var_type - = case splitForAllTys var_type of - (_, ty) -> maybeToBool (splitFunTy_Maybe ty) #endif \end{code} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 89dca58..a46580b 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -32,8 +32,8 @@ import BasicTypes ( OccInfo(..), isOneOcc ) import VarSet import VarEnv -import Type ( splitFunTy_maybe, splitForAllTys ) -import Maybes ( maybeToBool, orElse ) +import Type ( isFunTy, dropForAlls ) +import Maybes ( orElse ) import Digraph ( stronglyConnCompR, SCC(..) ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) @@ -485,9 +485,7 @@ reOrderRec env (CyclicSCC (bind : binds)) -- we didn't stupidly choose d as the loop breaker. -- But we won't because constructor args are marked "Many". - not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty)) - where - (_, rho_ty) = splitForAllTys ty + not_fun_ty ty = not (isFunTy (dropForAlls ty)) \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 9fcfb70..aeaa760 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -36,7 +36,7 @@ import Id ( Id, idType, idInfo, ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, seqType, splitRepFunTys, isStrictType, +import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) import TcType ( isDictTy ) @@ -232,14 +232,14 @@ getContArgs chkr fun orig_cont computed_stricts = zipWith (||) fun_stricts arg_stricts ---------------------------- - (val_arg_tys, _) = splitRepFunTys (idType fun) + (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun)) arg_stricts = map isStrictType val_arg_tys ++ repeat False -- These argument types are used as a cheap and cheerful way to find -- unboxed arguments, which must be strict. But it's an InType -- and so there might be a type variable where we expect a function -- type (the substitution hasn't happened yet). And we don't bother -- doing the type applications for a polymorphic function. - -- Hence the split*Rep*FunTys + -- Hence the splitFunTys*IgnoringForAlls* ---------------------------- -- If fun_stricts is finite, it means the function returns bottom diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index af593eb..2b3f183 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -20,7 +20,7 @@ import Maybes ( catMaybes ) import Name ( getSrcLoc ) import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc ) import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, - isUnLiftedType, isTyVarTy, splitForAllTys, Type + isUnLiftedType, isTyVarTy, dropForAlls, Type ) import TyCon ( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons ) import Util ( zipEqual, equalLength ) @@ -427,8 +427,7 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg loc scope errs = cfa res_ty expected_arg_tys arg_tys where - (_, de_forall_ty) = splitForAllTys fun_ty - (expected_arg_tys, res_ty) = splitFunTys de_forall_ty + (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty) cfa res_ty expected [] -- Args have run out; that's fine = (Just (mkFunTys expected res_ty), errs) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index fa6c806..7a14c32 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -244,8 +244,8 @@ mkWWargs fun_ty demands one_shots | not (null demands) = getUniquesUs `thenUs` \ wrap_uniqs -> let - (tyvars, tau) = splitForAllTys fun_ty - (arg_tys, body_ty) = splitFunTys tau + (tyvars, tau) = splitForAllTys fun_ty + (arg_tys, body_ty) = splitFunTys tau n_demands = length demands n_arg_tys = length arg_tys diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 7c1adf7..dc642d0 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -31,7 +31,7 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, - funResultTy, funArgTy, zipFunTys, + funResultTy, funArgTy, zipFunTys, isFunTy, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, @@ -39,10 +39,10 @@ module Type ( mkSynTy, - repType, splitRepFunTys, typePrimRep, + repType, typePrimRep, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, isForAllTy, + applyTy, applyTys, isForAllTy, dropForAlls, -- Source types SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, @@ -107,6 +107,7 @@ import Unique ( Uniquable(..) ) import Util ( mapAccumL, seqList, lengthIs ) import Outputable import UniqSet ( sizeUniqSet ) -- Should come via VarSet +import Maybe ( isJust ) \end{code} @@ -253,6 +254,9 @@ mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr FunTy ty tys +isFunTy :: Type -> Bool +isFunTy ty = isJust (splitFunTy_maybe ty) + splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty @@ -389,7 +393,6 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. Representation types ~~~~~~~~~~~~~~~~~~~~ - repType looks through (a) for-alls, and (b) synonyms @@ -411,12 +414,6 @@ repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc = repType (newTypeRep tc tys) repType ty = ty -splitRepFunTys :: Type -> ([Type], Type) --- Like splitFunTys, but looks through newtypes and for-alls -splitRepFunTys ty = split [] (repType ty) - where - split args (FunTy arg res) = split (arg:args) (repType res) - split args ty = (reverse args, ty) typePrimRep :: Type -> PrimRep typePrimRep ty = case repType ty of @@ -460,6 +457,9 @@ splitForAllTys ty = split ty ty [] split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs split orig_ty t tvs = (reverse tvs, orig_ty) + +dropForAlls :: Type -> Type +dropForAlls ty = snd (splitForAllTys ty) \end{code} -- (mkPiType now in CoreUtils)