[commit: ghc] wip/T9388: Simplify typeArity (e7420c7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9388
Link       : http://ghc.haskell.org/trac/ghc/changeset/e7420c731d0c307fcaf61c1a2ffd4daa64a8e7b1/ghc

>---------------------------------------------------------------

commit e7420c731d0c307fcaf61c1a2ffd4daa64a8e7b1
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sun Feb 22 10:49:18 2015 +0100

    Simplify typeArity
    
    Without the state hack here, this can have the very nice type
    typeArity :: Type -> Arity


>---------------------------------------------------------------

e7420c731d0c307fcaf61c1a2ffd4daa64a8e7b1
 compiler/coreSyn/CoreArity.hs   | 20 ++++++++++----------
 compiler/simplCore/CallArity.hs |  2 +-
 2 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index 7e054e4..8c53f1f 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -95,10 +95,10 @@ exprArity e = go e
     go _                           = 0
 
     trim_arity :: Arity -> Type -> Arity
-    trim_arity arity ty = arity `min` length (typeArity ty)
+    trim_arity arity ty = arity `min` typeArity ty
 
 ---------------
-typeArity :: Type -> [OneShotInfo]
+typeArity :: Type -> Arity
 -- How many value arrows are visible in the type?
 -- We look through foralls, and newtypes
 -- See Note [exprArity invariant]
@@ -109,8 +109,8 @@ typeArity ty
       | Just (_, ty')  <- splitForAllTy_maybe ty
       = go rec_nts ty'
 
-      | Just (arg,res) <- splitFunTy_maybe ty
-      = NoOneShotInfo : go rec_nts res
+      | Just (_,res) <- splitFunTy_maybe ty
+      = 1 + go rec_nts res
       | Just (tc,tys) <- splitTyConApp_maybe ty
       , Just (ty', _) <- instNewTyCon_maybe tc tys
       , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]
@@ -127,7 +127,7 @@ typeArity ty
         -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))
 
       | otherwise
-      = []
+      = 0
 
 ---------------
 exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
@@ -700,7 +700,7 @@ arityType env (Cast e co)
       ATop os -> ATop (take co_arity os)
       ABot n  -> ABot (n `min` co_arity)
   where
-    co_arity = length (typeArity (pSnd (coercionKind co)))
+    co_arity = typeArity (pSnd (coercionKind co))
     -- See Note [exprArity invariant] (2); must be true of
     -- arityType too, since that is how we compute the arity
     -- of variables, and they in turn affect result of exprArity
@@ -714,12 +714,12 @@ arityType _ (Var v)
   , (ds, res) <- splitStrictSig strict_sig
   , let arity = length ds
   = if isBotRes res then ABot arity
-                    else ATop (take arity one_shots)
+                    else ATop (replicate (arity `min` type_arity) noOneShotInfo)
   | otherwise
-  = ATop (take (idArity v) one_shots)
+  = ATop (replicate (idArity v `min` type_arity) noOneShotInfo)
   where
-    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type
-    one_shots = typeArity (idType v)
+    type_arity :: Arity  -- maximum Arity derived from the type
+    type_arity = typeArity (idType v)
 
         -- Lambdas; increase arity
 arityType env (Lam x e)
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 7bfd2f5..32226e8 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -475,7 +475,7 @@ callArityAnal arity int (Let bind e)
 -- See Note [Which variables are interesting]
 interestingBinds :: CoreBind -> [Var]
 interestingBinds = filter go . bindersOf
-  where go v = 0 < length (typeArity (idType v))
+  where go v = 0 < typeArity (idType v)
 
 addInterestingBinds :: VarSet -> CoreBind -> VarSet
 addInterestingBinds int bind