Commit 4593b105 authored by simonpj's avatar simonpj
Browse files

[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.
parent 354f17ec
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment