[commit: ghc] wip/redundant-constraints: Replace fixVarSet with transCloVarSet (6912660)

[git at git.haskell.org]

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

On branch  : wip/redundant-constraints
Link       : http://ghc.haskell.org/trac/ghc/changeset/6912660d9122ecee83b118d0aa052ec25b6fb1e9/ghc

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

commit 6912660d9122ecee83b118d0aa052ec25b6fb1e9
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Sat Jan 3 23:36:09 2015 +0000

    Replace fixVarSet with transCloVarSet
    
    I think the new implementation is a bit more efficient, because
    it uses a work-list, rather than iterating over the entire set
    every time


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

6912660d9122ecee83b118d0aa052ec25b6fb1e9
 compiler/basicTypes/VarSet.hs    | 29 ++++++++++++++++++++++-------
 compiler/typecheck/TcSimplify.hs | 31 +++++++++++++++++--------------
 2 files changed, 39 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs
index c134124..6c920ba 100644
--- a/compiler/basicTypes/VarSet.hs
+++ b/compiler/basicTypes/VarSet.hs
@@ -16,7 +16,8 @@ module VarSet (
         unionVarSet, unionVarSets, mapUnionVarSet,
         intersectVarSet, intersectsVarSet, disjointVarSet,
         isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
-        minusVarSet, foldVarSet, filterVarSet, fixVarSet,
+        minusVarSet, foldVarSet, filterVarSet, 
+        transCloVarSet,
         lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
         elemVarSetByKey, partitionVarSet
     ) where
@@ -69,7 +70,6 @@ extendVarSet_C  :: (Var->Var->Var) -> VarSet -> Var -> VarSet
 
 delVarSetByKey  :: VarSet -> Unique -> VarSet
 elemVarSetByKey :: Unique -> VarSet -> Bool
-fixVarSet       :: (VarSet -> VarSet) -> VarSet -> VarSet
 partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet)
 
 emptyVarSet     = emptyUniqSet
@@ -110,11 +110,26 @@ intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
 disjointVarSet   s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2)
 subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
 
--- Iterate f to a fixpoint
-fixVarSet f s | new_s `subVarSet` s = s
-              | otherwise           = fixVarSet f new_s
-              where
-                new_s = f s
+transCloVarSet :: (VarSet -> VarSet)
+                  -- Map some variables in the set to 
+                  -- *extra* variables that should be in it
+               -> VarSet -> VarSet
+-- (transCloVarSet f s) repeatedly applies f to the set s, adding any
+-- new variables to s that it finds thereby, until it reaches a fixed
+-- point.  The actual algorithm is a bit more efficient.
+transCloVarSet fn seeds
+  = go seeds seeds
+  where
+    go :: VarSet  -- Accumulating result
+       -> VarSet  -- Work-list; un-processed subset of accumulating result
+       -> VarSet
+    -- Specification: go acc vs = acc `union` transClo fn vs
+   
+    go acc candidates
+       | isEmptyVarSet new_vs = acc
+       | otherwise            = go (acc `unionVarSet` new_vs) new_vs
+       where
+         new_vs = fn candidates `minusVarSet` acc
 
 seqVarSet :: VarSet -> ()
 seqVarSet s = sizeVarSet s `seq` ()
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 01da61f..0c9b093 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -468,17 +468,18 @@ quantifyPred qtvs pred
 growThetaTyVars :: ThetaType -> TyVarSet -> TyVarSet
 -- See Note [Growing the tau-tvs using constraints]
 growThetaTyVars theta tvs
-  | null theta             = tvs
-  | isEmptyVarSet seed_tvs = tvs
-  | otherwise              = fixVarSet mk_next seed_tvs
+  | null theta = tvs
+  | otherwise  = transCloVarSet mk_next seed_tvs
   where
     seed_tvs = tvs `unionVarSet` tyVarsOfTypes ips
     (ips, non_ips) = partition isIPPred theta
                          -- See note [Inheriting implicit parameters]
-    mk_next tvs = foldr grow_one tvs non_ips
-    grow_one pred tvs
-       | pred_tvs `intersectsVarSet` tvs = tvs `unionVarSet` pred_tvs
-       | otherwise                       = tvs
+
+    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips
+    grow_one so_far pred tvs
+       | pred_tvs `intersectsVarSet` so_far = tvs `unionVarSet` pred_tvs
+       | otherwise                          = tvs
        where
          pred_tvs = tyVarsOfType pred
 
@@ -990,14 +991,16 @@ approximateWC wc
       = filterBag is_floatable simples `unionBags`
         do_bag (float_implic new_trapping_tvs) implics
       where
-        new_trapping_tvs = fixVarSet grow trapping_tvs
         is_floatable ct = tyVarsOfCt ct `disjointVarSet` new_trapping_tvs
-
-        grow tvs = foldrBag grow_one tvs simples
-        grow_one ct tvs | ct_tvs `intersectsVarSet` tvs = tvs `unionVarSet` ct_tvs
-                        | otherwise                     = tvs
-                        where
-                          ct_tvs = tyVarsOfCt ct
+        new_trapping_tvs = transCloVarSet grow trapping_tvs
+
+        grow :: VarSet -> VarSet  -- Maps current trapped tyvars to newly-trapped ones
+        grow so_far = foldrBag (grow_one so_far) emptyVarSet simples
+        grow_one so_far ct tvs 
+          | ct_tvs `intersectsVarSet` so_far = tvs `unionVarSet` ct_tvs
+          | otherwise                        = tvs
+          where
+            ct_tvs = tyVarsOfCt ct
 
     float_implic :: TcTyVarSet -> Implication -> Cts
     float_implic trapping_tvs imp