Commit a1a67b58 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add TyCon.checkRecTc, and use in in typeArity

This just formalises an abstraction we've been using anyway,
namely to expand "recursive" TyCons until we see them twice.
We weren't doing this in typeArity, and that inconsistency
was leading to a subsequent ASSERT failure, when compiling
Stream.hs, which has a newtype like this

   newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))
parent 62653122
......@@ -30,7 +30,7 @@ import Var
import VarEnv
import Id
import Type
import TyCon ( isRecursiveTyCon, isClassTyCon )
import TyCon ( initRecTc, checkRecTc )
import Coercion
import BasicTypes
import Unique
......@@ -88,7 +88,7 @@ exprArity e = go e
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Tick t e) | not (tickishIsCode t) = go e
go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co)))
go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co))
-- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
......@@ -97,6 +97,8 @@ exprArity e = go e
go _ = 0
trim_arity :: Arity -> Type -> Arity
trim_arity arity ty = arity `min` length (typeArity ty)
---------------
typeArity :: Type -> [OneShot]
......@@ -104,24 +106,32 @@ typeArity :: Type -> [OneShot]
-- We look through foralls, and newtypes
-- See Note [exprArity invariant]
typeArity ty
| Just (_, ty') <- splitForAllTy_maybe ty
= typeArity ty'
| Just (arg,res) <- splitFunTy_maybe ty
= isStateHackType arg : typeArity res
| Just (tc,tys) <- splitTyConApp_maybe ty
, Just (ty', _) <- instNewTyCon_maybe tc tys
, not (isRecursiveTyCon tc)
, not (isClassTyCon tc) -- Do not eta-expand through newtype classes
-- See Note [Newtype classes and eta expansion]
= typeArity ty'
= go initRecTc ty
where
go rec_nts ty
| Just (_, ty') <- splitForAllTy_maybe ty
= go rec_nts ty'
| Just (arg,res) <- splitFunTy_maybe ty
= isStateHackType arg : 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]
-- in TyCon
-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes
-- -- See Note [Newtype classes and eta expansion]
-- (no longer required)
= go rec_nts' ty'
-- Important to look through non-recursive newtypes, so that, eg
-- (f x) where f has arity 2, f :: Int -> IO ()
-- Here we want to get arity 1 for the result!
--
-- AND through a layer of recursive newtypes
-- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))
| otherwise
= []
| otherwise
= []
---------------
exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
......@@ -168,6 +178,11 @@ in exprArity. That is a less local change, so I'm going to leave it for today!
Note [Newtype classes and eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: this nasty special case is no longer required, becuase
for newtype classes we don't use the class-op rule mechanism
at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013
-------- Old out of date comments, just for interest -----------
We have to be careful when eta-expanding through newtypes. In general
it's a good idea, but annoyingly it interacts badly with the class-op
rule mechanism. Consider
......@@ -207,6 +222,7 @@ exprIsConApp_maybe won't hold of the argument to op. I considered
trying to *make* it hold, but it's tricky and I gave up.
The test simplCore/should_compile/T3722 is an excellent example.
-------- End of old out of date comments, just for interest -----------
Note [exprArity for applications]
......@@ -542,7 +558,7 @@ PAPSs
f = g d ==> f = \x. g d x
because that might in turn make g inline (if it has an inline pragma),
which we might not want. After all, INLINE pragmas say "inline only
when saturate" so we don't want to be too gung-ho about saturating!
when saturated" so we don't want to be too gung-ho about saturating!
\begin{code}
arityLam :: Id -> ArityType -> ArityType
......@@ -726,7 +742,7 @@ The biggest reason for doing this is for cases like
True -> \y -> e1
False -> \y -> e2
Here we want to get the lambdas together. A good exmaple is the nofib
Here we want to get the lambdas together. A good example is the nofib
program fibheaps, which gets 25% more allocation if you don't do this
eta-expansion.
......
......@@ -74,9 +74,9 @@ normaliseFfiType ty
normaliseFfiType' fam_envs ty
normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
normaliseFfiType' env ty0 = go [] ty0
normaliseFfiType' env ty0 = go initRecTc ty0
where
go :: [TyCon] -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
......@@ -87,8 +87,15 @@ normaliseFfiType' env ty0 = go [] ty0
= children_only
| isNewTyCon tc -- Expand newtypes
, Just rec_nts' <- checkRecTc rec_nts tc
-- See Note [Expanding newtypes] in TyCon.lhs
-- We can't just use isRecursiveTyCon; sometimes recursion is ok:
-- newtype T = T (Ptr T)
-- Here, we don't reject the type for being recursive.
-- If this is a recursive newtype then it will normally
-- be rejected later as not being a valid FFI type.
= do { rdr_env <- getGlobalRdrEnv
; case checkNewtypeFFI rdr_env rec_nts tc of
; case checkNewtypeFFI rdr_env tc of
Nothing -> children_only
Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
......@@ -110,9 +117,6 @@ normaliseFfiType' env ty0 = go [] ty0
nt_co = mkUnbranchedAxInstCo (newTyConCo tc) tys
nt_rhs = newTyConInstRhs tc tys
rec_nts' | isRecursiveTyCon tc = tc:rec_nts
| otherwise = rec_nts
go rec_nts (AppTy ty1 ty2)
= do (coi1, nty1, gres1) <- go rec_nts ty1
(coi2, nty2, gres2) <- go rec_nts ty2
......@@ -131,16 +135,9 @@ normaliseFfiType' env ty0 = go [] ty0
go _ ty@(LitTy {}) = return (Refl ty, ty, emptyBag)
checkNewtypeFFI :: GlobalRdrEnv -> [TyCon] -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env rec_nts tc
| not (tc `elem` rec_nts)
-- See Note [Expanding newtypes] in Type.lhs
-- We can't just use isRecursiveTyCon; sometimes recursion is ok:
-- newtype T = T (Ptr T)
-- Here, we don't reject the type for being recursive.
-- If this is a recursive newtype then it will normally
-- be rejected later as not being a valid FFI type.
, Just con <- tyConSingleDataCon_maybe tc
checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
checkNewtypeFFI rdr_env tc
| Just con <- tyConSingleDataCon_maybe tc
, [gre] <- lookupGRE_Name rdr_env (dataConName con)
= Just gre -- See Note [Newtype constructor usage in foreign declarations]
| otherwise
......
......@@ -96,7 +96,6 @@ import VarEnv
import VarSet
import Maybes ( orElse )
import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan )
import NameSet
import OccName ( parenSymOcc )
import Util
import BasicTypes
......@@ -884,25 +883,21 @@ splitNewTypeRepCo_maybe _
topNormaliseNewType :: Type -> Maybe (Type, Coercion)
topNormaliseNewType ty
= case topNormaliseNewTypeX emptyNameSet ty of
= case topNormaliseNewTypeX initRecTc ty of
Just (_, co, ty) -> Just (ty, co)
Nothing -> Nothing
topNormaliseNewTypeX :: NameSet -> Type -> Maybe (NameSet, Coercion, Type)
topNormaliseNewTypeX :: RecTcChecker -> Type -> Maybe (RecTcChecker, Coercion, Type)
topNormaliseNewTypeX rec_nts ty
| Just ty' <- coreView ty -- Expand predicates and synonyms
= topNormaliseNewTypeX rec_nts ty'
topNormaliseNewTypeX rec_nts (TyConApp tc tys)
| Just (rep_ty, co) <- instNewTyCon_maybe tc tys
, not (tc_name `elemNameSet` rec_nts) -- See Note [Expanding newtypes] in Type
| Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon
, Just (rep_ty, co) <- instNewTyCon_maybe tc tys
= case topNormaliseNewTypeX rec_nts' rep_ty of
Nothing -> Just (rec_nts', co, rep_ty)
Just (rec_nts', co', rep_ty') -> Just (rec_nts', co `mkTransCo` co', rep_ty')
where
tc_name = tyConName tc
rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
| otherwise = rec_nts
topNormaliseNewTypeX _ _ = Nothing
\end{code}
......
......@@ -832,9 +832,9 @@ topNormaliseType :: FamInstEnvs
-- Its a bit like Type.repType, but handles type families too
topNormaliseType env ty
= go emptyNameSet ty
= go initRecTc ty
where
go :: NameSet -> Type -> Maybe (Coercion, Type)
go :: RecTcChecker -> Type -> Maybe (Coercion, Type)
go rec_nts ty
| Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
......
......@@ -81,7 +81,10 @@ module TyCon(
-- * Primitive representations of Types
PrimRep(..), PrimElemRep(..),
tyConPrimRep,
primRepSizeW, primElemRepSizeB
primRepSizeW, primElemRepSizeB,
-- * Recursion breaking
RecTcChecker, initRecTc, checkRecTc
) where
#include "HsVersions.h"
......@@ -95,6 +98,7 @@ import BasicTypes
import DynFlags
import ForeignCall
import Name
import NameSet
import CoAxiom
import PrelNames
import Maybes
......@@ -1549,3 +1553,55 @@ instance Data.Data TyCon where
dataTypeOf _ = mkNoRepType "TyCon"
\end{code}
%************************************************************************
%* *
Walking over recursive TyCons
%* *
%************************************************************************
Note [Expanding newtypes and products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:
newtype Id x = MkId x
newtype Fix f = MkFix (f (Fix f))
newtype T = MkT (T -> T)
Type Expansion
--------------------------
T T -> T
Fix Maybe Maybe (Fix Maybe)
Id (Id Int) Int
Fix Id NO NO NO
Notice that we can expand T, even though it's recursive.
And we can expand Id (Id Int), even though the Id shows up
twice at the outer level.
So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bale out if we see it again.
We sometimes want to do the same for product types, so that the
strictness analyser doesn't unbox infinitely deeply.
The function that manages this is checkRecTc.
\begin{code}
newtype RecTcChecker = RC NameSet
initRecTc :: RecTcChecker
initRecTc = RC emptyNameSet
checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
-- Nothing => Recursion detected
-- Just rec_tcs => Keep going
checkRecTc (RC rec_nts) tc
| not (isRecursiveTyCon tc) = Just (RC rec_nts)
| tc_name `elemNameSet` rec_nts = Nothing
| otherwise = Just (RC (addOneToNameSet rec_nts tc_name))
where
tc_name = tyConName tc
\end{code}
\ No newline at end of file
......@@ -166,7 +166,6 @@ import CoAxiom
-- others
import Unique ( Unique, hasKey )
import BasicTypes ( Arity, RepArity )
import NameSet
import StaticFlags
import Util
import Outputable
......@@ -590,31 +589,6 @@ The reason is that we then get better (shorter) type signatures in
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
Note [Expanding newtypes]
~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:
newtype Id x = MkId x
newtype Fix f = MkFix (f (Fix f))
newtype T = MkT (T -> T)
Type Expansion
--------------------------
T T -> T
Fix Maybe Maybe (Fix Maybe)
Id (Id Int) Int
Fix Id NO NO NO
Notice that we can expand T, even though it's recursive.
And we can expand Id (Id Int), even though the Id shows up
twice at the outer level.
So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bale out if we see it again.
Representation types
~~~~~~~~~~~~~~~~~~~~
......@@ -649,9 +623,9 @@ flattenRepType (UnaryRep ty) = [ty]
-- It's useful in the back end of the compiler.
repType :: Type -> RepType
repType ty
= go emptyNameSet ty
= go initRecTc ty
where
go :: NameSet -> Type -> RepType
go :: RecTcChecker -> Type -> RepType
go rec_nts ty -- Expand predicates and synonyms
| Just ty' <- coreView ty
= go rec_nts ty'
......@@ -662,10 +636,7 @@ repType ty
go rec_nts (TyConApp tc tys) -- Expand newtypes
| isNewTyCon tc
, tys `lengthAtLeast` tyConArity tc
, let tc_name = tyConName tc
rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
| otherwise = rec_nts
, not (tc_name `elemNameSet` rec_nts) -- See Note [Expanding newtypes]
, Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon
= go rec_nts' (newTyConInstRhs tc tys)
| isUnboxedTupleTyCon tc
......
Markdown is supported
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