[commit: ghc] origin/wip/new-flatten-skolems-Aug14: More wip on flatten-skolems (84b3463)

[git at git.haskell.org]

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

On branch  : origin/wip/new-flatten-skolems-Aug14
Link       : http://ghc.haskell.org/trac/ghc/changeset/84b34639ae19ce5c04f93dfead4d40f0349b8d09/ghc

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

commit 84b34639ae19ce5c04f93dfead4d40f0349b8d09
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Sep 9 17:29:50 2014 +0100

    More wip on flatten-skolems


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

84b34639ae19ce5c04f93dfead4d40f0349b8d09
 compiler/typecheck/TcRnTypes.lhs  |  5 ++--
 compiler/typecheck/TcSMonad.lhs   |  2 +-
 compiler/typecheck/TcSimplify.lhs | 48 ++++++++++++++++++++++++++++++++-------
 3 files changed, 44 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index b0d0c6c..1072d99 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1285,8 +1285,9 @@ data Implication
                                  --   (order does not matter)
                                  -- See Invariant (GivenInv) in TcType
 
-      ic_fsks  :: [TcTyVar],     -- Extra flatten-skolems introduced by
-                                 -- by flattening the givens
+      ic_fsks  :: Cts            -- Extra Given constraints, all CFunEqCans,
+                                 -- arising from flattening the givens
+
       ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure
                                  -- False <=> ic_givens might have equalities
 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index f542c1e..a5275d1 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1970,7 +1970,7 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
                                                   , ic_skols  = skol_tvs
                                                   , ic_no_eqs = True
                                                   , ic_given  = []
-                                                  , ic_fsks   = []
+                                                  , ic_fsks   = emptyCts
                                                   , ic_wanted = wc
                                                   , ic_insol  = False
                                                   , ic_binds  = ev_binds_var
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index b14715f..4a1aff2 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1122,7 +1122,10 @@ they carry evidence).
 
 
 \begin{code}
-floatEqualities :: [TcTyVar] -> Bool -> [TcTyVar]
+data SkolStatus = Pinned | CanFloat | Pending
+
+floatEqualities :: [TcTyVar] -> Bool
+                -> Cts          -- Given fsks
                 -> WantedConstraints -> TcS (Cts, WantedConstraints)
 -- Main idea: see Note [Float Equalities out of Implications]
 --
@@ -1140,14 +1143,43 @@ floatEqualities skols no_given_eqs fsks wanteds@(WC { wc_flat = flats })
   | otherwise
   = 
   where
-    (ufsk_funeqs, others) = partitionBag isCFunEqCan flats
+    skol_set = mkVarSet skols
+    (ufsks, others) = partitionBag isCFunEqCan flats
+    all_fsks = ufsks `andCts` fsks
+
+    fsk_tvs :: VarEnv [TcTyVar]
+    fsk_tvs = foldBag (\env (CFunEqCan { cc_fsk = tv, cc_tyargs = xis })
+                       -> extendVarEnv env tv (varSetElems (tyVarsOfTypes xis)))
+                      emptyVarEnv all_fsks
+
+    fsk_map :: VarEnv SkolStatus  -- True <=> pinned by skolem
+    fsk_map = foldrBag mk_fsk_map emptyVarEnv (ufsks `andCts` fsks)
+
+    mk_fsk_map :: Ct -> VarEnv SkolStatus -> VarEnv SkolStatus
+    mk_fsk_map (CFunEqCan { cc_fsk = tv }) map_so_far
+      = snd (mk_fsk_map_tv map_so_far tv)
+
+    mk_fsk_map_tv :: VarEnv SkolStatus -> TcTyVar -> (Bool, VarEnv SkolStatus)
+    mk_fsk_map_tv map_so_far tv
+      | Just status <- lookupVarEnv map_so_far tv
+      = (status, map_so_far)
+      | tv `elem skol_set
+      = (Pinned, extendVarEnv map_so_far tv Pinned)
+      | Just new_tvs <- lookupVarEnv fsk_tvs tv
+      , (status, map_so_far') <- mk_fsk_map_tvs (extendVarEnv map_so_far tv Pending) new_tvs
+      = (status, extendVarEnv map_so_far' tv status)
+      | otherwise
+      = (CanFloat, extendVarEnv map_so_far tv CanFloat)
+
+    mk_fsk_map_tvs :: VarEnv Bool -> [TcTyVar] -> (Bool, VarEnv Bool)
+    mk_fsk_map_tvs map_so_far []
+       = (CanFloat, map_so_far)
+    mk_fsk_map_tvs map_so_far (tv:tvs)
+       | (status, map_so_far') <- mk_fsk_map_tv map_so_far tv
+       = case status of
+           Pinned -> (Pinned, map_so_far')
+           _      -> mk_fsk_map_tvs map_so_far' tvs
 
-    pinned_tvs = fixVarSet mk_next (mkVarSet skols)
-    mk_next tvs = foldr grow_one tvs flat_eqs
-    grow_one (tvs1,tvs2) tvs
-      | intersectsVarSet tvs tvs1 = tvs `unionVarSet` tvs2
-      | intersectsVarSet tvs tvs2 = tvs `unionVarSet` tvs2
-      | otherwise                 = tvs
 
     (float_candidates, flats1) = partitionBag is_candidate flats
     is_candidate (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })