Commit 096b7e66 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Switch off lazy flattening (fix Trac #3064)

See Note [Lazy flattening] in TcFlatten.

Lazy flattening was an apparently good idea which actually made
the type inference engine go a LOTS slower in T3064.  So I switched
it off again.
parent 528cbd72
...@@ -682,12 +682,15 @@ mkInferredPolyId poly_name qtvs theta mono_ty ...@@ -682,12 +682,15 @@ mkInferredPolyId poly_name qtvs theta mono_ty
= do { fam_envs <- tcGetFamInstEnvs = do { fam_envs <- tcGetFamInstEnvs
; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty
-- Unification may not have normalised the type, so do it -- Unification may not have normalised the type,
-- (see Note [Lazy flattening] in TcFlatten) so do it
-- here to make it as uncomplicated as possible. -- here to make it as uncomplicated as possible.
-- Example: f :: [F Int] -> Bool -- Example: f :: [F Int] -> Bool
-- should be rewritten to f :: [Char] -> Bool, if possible -- should be rewritten to f :: [Char] -> Bool, if possible
my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty)) my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty))
-- Include kind variables! Trac #7916 -- Include kind variables! Trac #7916
my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order
my_theta = filter (quantifyPred my_tvs2) theta my_theta = filter (quantifyPred my_tvs2) theta
inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty
......
...@@ -676,9 +676,11 @@ canEqTyVar ev swapped tv1 ty2 ps_ty2 -- ev :: tv ~ s2 ...@@ -676,9 +676,11 @@ canEqTyVar ev swapped tv1 ty2 ps_ty2 -- ev :: tv ~ s2
Stop ev s -> return (Stop ev s) Stop ev s -> return (Stop ev s)
ContinueWith new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 } ContinueWith new_ev -> can_eq_nc new_ev ty1 ty1 ty2 ps_ty2 }
Left tv1' -> do { let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True } Left tv1' -> do { -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
-- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
-- Flatten the RHS less vigorously, to avoid gratuitous flattening -- Flatten the RHS less vigorously, to avoid gratuitous flattening
-- True <=> xi2 should not itself be a type-function application -- True <=> xi2 should not itself be a type-function application
let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
; (xi2, co2) <- flatten fmode ps_ty2 -- co2 :: xi2 ~ ps_ty2 ; (xi2, co2) <- flatten fmode ps_ty2 -- co2 :: xi2 ~ ps_ty2
-- Use ps_ty2 to preserve type synonyms if poss -- Use ps_ty2 to preserve type synonyms if poss
; dflags <- getDynFlags ; dflags <- getDynFlags
......
...@@ -19,6 +19,7 @@ import TypeRep ...@@ -19,6 +19,7 @@ import TypeRep
import Kind( isSubKind ) import Kind( isSubKind )
import Var import Var
import VarEnv import VarEnv
import NameEnv
import Outputable import Outputable
import VarSet import VarSet
import TcSMonad as TcS import TcSMonad as TcS
...@@ -571,7 +572,8 @@ data FlattenEnv ...@@ -571,7 +572,8 @@ data FlattenEnv
data FlattenMode -- Postcondition for all three: inert wrt the type substitution data FlattenMode -- Postcondition for all three: inert wrt the type substitution
= FM_FlattenAll -- Postcondition: function-free = FM_FlattenAll -- Postcondition: function-free
| FM_Avoid TcTyVar Bool -- Postcondition: | FM_Avoid TcTyVar Bool -- See Note [Lazy flattening]
-- Postcondition:
-- * tyvar is only mentioned in result under a rigid path -- * tyvar is only mentioned in result under a rigid path
-- e.g. [a] is ok, but F a won't happen -- e.g. [a] is ok, but F a won't happen
-- * If flat_top is True, top level is not a function application -- * If flat_top is True, top level is not a function application
...@@ -580,6 +582,29 @@ data FlattenMode -- Postcondition for all three: inert wrt the type substitutio ...@@ -580,6 +582,29 @@ data FlattenMode -- Postcondition for all three: inert wrt the type substitutio
| FM_SubstOnly -- See Note [Flattening under a forall] | FM_SubstOnly -- See Note [Flattening under a forall]
\end{code} \end{code}
Note [Lazy flattening]
~~~~~~~~~~~~~~~~~~~~~~
The idea of FM_Avoid mode is to flatten less aggressively. If we have
a ~ [F Int]
there seems to be no great merit in lifting out (F Int). But if it was
a ~ [G a Int]
then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,
which gets rid of the occurs-check problem. (For the flat_top Bool, see
comments above and at call sites.)
HOWEVER, the lazy flattening actually seems to make type inference go
*slower*, not faster. perf/compiler/T3064 is a case in point; it gets
*dramatically* worse with FM_Avoid. I think it may be because
floating the types out means we normalise them, and that often makes
them smaller and perhaps allows more re-use of previously solved
goals. But to be honest I'm not absolutely certain, so I am leaving
FM_Avoid in the code base. What I'm removing is the unique place
where it is *used*, namely in TcCanonical.canEqTyVar.
Bottom line: FM_Avoid is unused for now (Nov 14).
Note: T5321Fun got faster when I disabled FM_Avoid
T5837 did too, but it's pathalogical anyway
\begin{code} \begin{code}
-- Flatten a bunch of types all at once. -- Flatten a bunch of types all at once.
flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion]) flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion])
...@@ -641,12 +666,13 @@ flatten fmode (TyConApp tc tys) ...@@ -641,12 +666,13 @@ flatten fmode (TyConApp tc tys)
-- For * a normal data type application -- For * a normal data type application
-- * data family application -- * data family application
-- we just recursively flatten the arguments. -- we just recursively flatten the arguments.
| otherwise -- Switch off the flat_top bit in FM_Avoid | otherwise
, let fmode' = case fmode of -- FM_Avoid stuff commented out; see Note [Lazy flattening]
FE { fe_mode = FM_Avoid tv _ } -- , let fmode' = case fmode of -- Switch off the flat_top bit in FM_Avoid
-> fmode { fe_mode = FM_Avoid tv False } -- FE { fe_mode = FM_Avoid tv _ }
_ -> fmode -- -> fmode { fe_mode = FM_Avoid tv False }
= flattenTyConApp fmode' tc tys -- _ -> fmode
= flattenTyConApp fmode tc tys
flatten fmode ty@(ForAllTy {}) flatten fmode ty@(ForAllTy {})
-- We allow for-alls when, but only when, no type function -- We allow for-alls when, but only when, no type function
...@@ -728,6 +754,8 @@ flattenFamApp fmode tc tys -- Can be over-saturated ...@@ -728,6 +754,8 @@ flattenFamApp fmode tc tys -- Can be over-saturated
flattenExactFamApp fmode tc tys flattenExactFamApp fmode tc tys
= case fe_mode fmode of = case fe_mode fmode of
FM_FlattenAll -> flattenExactFamApp_fully fmode tc tys
FM_SubstOnly -> do { (xis, cos) <- flattenMany fmode tys FM_SubstOnly -> do { (xis, cos) <- flattenMany fmode tys
; return ( mkTyConApp tc xis ; return ( mkTyConApp tc xis
, mkTcTyConAppCo Nominal tc cos ) } , mkTcTyConAppCo Nominal tc cos ) }
...@@ -737,7 +765,6 @@ flattenExactFamApp fmode tc tys ...@@ -737,7 +765,6 @@ flattenExactFamApp fmode tc tys
then flattenExactFamApp_fully fmode tc tys then flattenExactFamApp_fully fmode tc tys
else return ( mkTyConApp tc xis else return ( mkTyConApp tc xis
, mkTcTyConAppCo Nominal tc cos ) } , mkTcTyConAppCo Nominal tc cos ) }
FM_FlattenAll -> flattenExactFamApp_fully fmode tc tys
flattenExactFamApp_fully fmode tc tys flattenExactFamApp_fully fmode tc tys
= do { (xis, cos) <- flattenMany (fmode { fe_mode = FM_FlattenAll })tys = do { (xis, cos) <- flattenMany (fmode { fe_mode = FM_FlattenAll })tys
......
T2664.hs:31:33: T2664.hs:31:52:
Could not deduce (Dual b ~ Dual a) Could not deduce (a ~ b)
from the context ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) from the context ((a :*: b) ~ Dual c, c ~ Dual (a :*: b))
bound by the type signature for bound by the type signature for
newPChan :: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) => newPChan :: ((a :*: b) ~ Dual c, c ~ Dual (a :*: b)) =>
IO (PChan (a :*: b), PChan c) IO (PChan (a :*: b), PChan c)
at T2664.hs:23:5-12 at T2664.hs:23:5-12
NB: ‘Dual’ is a type function, and may not be injective ‘a’ is a rigid type variable bound by
Expected type: PChan c the instance declaration at T2664.hs:22:10
Actual type: PChan (Dual b :+: Dual a) ‘b’ is a rigid type variable bound by
the instance declaration at T2664.hs:22:10
Expected type: Dual (Dual a)
Actual type: b
Relevant bindings include Relevant bindings include
v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9) v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9)
newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5) newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5)
In the third argument of ‘pchoose’, namely ‘newPChan’
In the first argument of ‘E’, namely ‘(pchoose Right v newPChan)’
In the expression: In the expression:
E (pchoose Right v newPChan) (pchoose Left v newPChan) E (pchoose Right v newPChan) (pchoose Left v newPChan)
In the first argument of ‘return’, namely
‘(O $ takeMVar v,
E (pchoose Right v newPChan) (pchoose Left v newPChan))’
T7010.hs:53:27: T7010.hs:53:27:
Couldn't match type ‘IO Float’ with ‘Serial (ValueTuple Float)’ Couldn't match type ‘IO Float’ with ‘Serial (IO Float)’
Expected type: (Float, ValueTuple Vector) Expected type: (Float, ValueTuple Vector)
Actual type: (Float, ValueTuple Float) Actual type: (Float, ValueTuple Float)
In the first argument of ‘withArgs’, namely ‘plug’ In the first argument of ‘withArgs’, namely ‘plug’
......
T8518.hs:17:78: T8518.hs:14:18:
Couldn't match expected type ‘F a1’ Couldn't match expected type ‘Maybe (F c)’ with actual type ‘F c’
with actual type ‘Z a1 -> B a1 -> F a1’ Relevant bindings include
Relevant bindings include b :: B c (bound at T8518.hs:14:14)
c'' :: a1 (bound at T8518.hs:17:30) z :: Z c (bound at T8518.hs:14:12)
b' :: B a1 (bound at T8518.hs:17:21) c :: c (bound at T8518.hs:14:10)
z' :: Z a1 (bound at T8518.hs:17:18) callCont :: c -> Z c -> B c -> Maybe (F c) (bound at T8518.hs:14:1)
c' :: a1 (bound at T8518.hs:17:15) In the expression: rpt (4 :: Int) c z b
rpt :: a -> a1 -> Z a1 -> B a1 -> F a1 (bound at T8518.hs:16:9) In an equation for ‘callCont’:
In the expression: rpt (i - 1) c'' callCont c z b
In the expression: = rpt (4 :: Int) c z b
let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i - 1) c'' where
rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b'))
rpt i c' z' b' = let ... in rpt (i - 1) c''
T8518.hs:17:78:
Couldn't match expected type ‘F a1’
with actual type ‘Z a1 -> B a1 -> F a1’
Relevant bindings include
c'' :: a1 (bound at T8518.hs:17:30)
b' :: B a1 (bound at T8518.hs:17:21)
z' :: Z a1 (bound at T8518.hs:17:18)
c' :: a1 (bound at T8518.hs:17:15)
rpt :: a -> a1 -> Z a1 -> B a1 -> F a1 (bound at T8518.hs:16:9)
In the expression: rpt (i - 1) c''
In the expression:
let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i - 1) c''
...@@ -393,14 +393,14 @@ test('T5321Fun', ...@@ -393,14 +393,14 @@ test('T5321Fun',
# 2012-10-08: 344416344 x86/Linux # 2012-10-08: 344416344 x86/Linux
# (increase due to new codegen) # (increase due to new codegen)
# 2014-09-03: 299656164 (specialisation and inlining) # 2014-09-03: 299656164 (specialisation and inlining)
(wordsize(64), 601629032, 10)]) (wordsize(64), 541287000, 10)])
# prev: 585521080 # prev: 585521080
# 29/08/2012: 713385808 # (increase due to new codegen) # 29/08/2012: 713385808 # (increase due to new codegen)
# 15/05/2013: 628341952 # (reason for decrease unknown) # 15/05/2013: 628341952 # (reason for decrease unknown)
# 24/06/2013: 694019152 # (reason for re-increase unknown) # 24/06/2013: 694019152 # (reason for re-increase unknown)
# 12/05/2014: 614409344 # (specialisation and inlining changes) # 12/05/2014: 614409344 # (specialisation and inlining changes)
# 10/09/2014: 601629032 # post-AMP-cleanp # 10/09/2014: 601629032 # post-AMP-cleanp
# 06/11/2014: 541287000 # Simon's flat-skol changes to the constraint solver
], ],
compile,['']) compile,[''])
...@@ -457,7 +457,7 @@ test('T5837', ...@@ -457,7 +457,7 @@ test('T5837',
# 40000000 (x86/Linux) # 40000000 (x86/Linux)
# 2013-11-13: 45520936 (x86/Windows, 64bit machine) # 2013-11-13: 45520936 (x86/Windows, 64bit machine)
# 2041-09-03: 37096484 (Windows laptop, w/w for INLINABLE things # 2041-09-03: 37096484 (Windows laptop, w/w for INLINABLE things
(wordsize(64), 651924880, 10)]) (wordsize(64), 271028976, 10)])
# sample: 3926235424 (amd64/Linux, 15/2/2012) # sample: 3926235424 (amd64/Linux, 15/2/2012)
# 2012-10-02 81879216 # 2012-10-02 81879216
# 2012-09-20 87254264 amd64/Linux # 2012-09-20 87254264 amd64/Linux
...@@ -466,7 +466,7 @@ test('T5837', ...@@ -466,7 +466,7 @@ test('T5837',
# for constraints solving # for constraints solving
# 2014-08-29 73639840 amd64/Linux, w/w for INLINABLE things # 2014-08-29 73639840 amd64/Linux, w/w for INLINABLE things
# 2014-10-08 73639840 amd64/Linux, Burning Bridges and other small changes # 2014-10-08 73639840 amd64/Linux, Burning Bridges and other small changes
# 2014-11-02 651924880 Linux, Accept big regression; # 2014-11-06 271028976 Linux, Accept big regression;
# See Note [An alternative story for the inert substitution] in TcFlatten # See Note [An alternative story for the inert substitution] in TcFlatten
], ],
compile_fail,['-ftype-function-depth=50']) compile_fail,['-ftype-function-depth=50'])
......
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