[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)