[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.

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) 

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}
 

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

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

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)

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

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)