Replace fixVarSet with transCloVarSet
authorSimon Peyton Jones <simonpj@microsoft.com>
Sat, 3 Jan 2015 23:36:09 +0000 (23:36 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 Jan 2015 14:18:45 +0000 (14:18 +0000)
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

compiler/basicTypes/VarSet.hs
compiler/typecheck/TcSimplify.hs

index c134124..6c920ba 100644 (file)
@@ -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` ()
index 01da61f..0c9b093 100644 (file)
@@ -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