Remove some gratitious varSetElemsWellScoped
authorBartosz Nitka <niteria@gmail.com>
Fri, 15 Apr 2016 11:48:45 +0000 (04:48 -0700)
committerBartosz Nitka <niteria@gmail.com>
Fri, 15 Apr 2016 11:48:51 +0000 (04:48 -0700)
Summary:
`varSetElemsWellScoped` uses `varSetElems` under the hood which
introduces unnecessary nondeterminism.
This does the same thing, possibly cheaper, while preserving
determinism.

Test Plan: ./validate

Reviewers: simonmar, goldfire, austin, bgamari, simonpj

Reviewed By: simonpj

Subscribers: thomie, RyanGlScott

Differential Revision: https://phabricator.haskell.org/D2116

GHC Trac Issues: #4012

compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcGenGenerics.hs

index 602ef64..48b0e56 100644 (file)
@@ -26,7 +26,7 @@ import TcBinds
 import TcUnify
 import TcHsType
 import TcMType
-import Type     ( getClassPredTys_maybe, varSetElemsWellScoped, piResultTys )
+import Type     ( getClassPredTys_maybe, piResultTys )
 import TcType
 import TcRnMonad
 import BuildTyCl( TcMethInfo )
@@ -41,7 +41,6 @@ import NameEnv
 import NameSet
 import Var
 import VarEnv
-import VarSet
 import Outputable
 import SrcLoc
 import TyCon
@@ -53,7 +52,7 @@ import BooleanFormula
 import Util
 
 import Control.Monad
-import Data.List ( mapAccumL )
+import Data.List ( mapAccumL, partition )
 
 {-
 Dictionary handling
@@ -454,10 +453,10 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
   = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
                                             (tyConTyVars fam_tc)
              rhs'     = substTyUnchecked subst' rhs_ty
-             tcv_set' = tyCoVarsOfTypes pat_tys'
-             (tv_set', cv_set') = partitionVarSet isTyVar tcv_set'
-             tvs'     = varSetElemsWellScoped tv_set'
-             cvs'     = varSetElemsWellScoped cv_set'
+             tcv' = tyCoVarsOfTypesList pat_tys'
+             (tv', cv') = partition isTyVar tcv'
+             tvs'     = toposortTyVars tv'
+             cvs'     = toposortTyVars cv'
        ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
        ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
                                      fam_tc pat_tys' rhs'
index d3c9295..d88686f 100644 (file)
@@ -1586,7 +1586,7 @@ mkNewTypeEqn dflags overlap_mode tvs
        case mtheta of
         Just theta -> return $ GivenTheta $ DS
             { ds_loc = loc
-            , ds_name = dfun_name, ds_tvs = varSetElemsWellScoped dfun_tvs
+            , ds_name = dfun_name, ds_tvs = dfun_tvs
             , ds_cls = cls, ds_tys = inst_tys
             , ds_tc = rep_tycon
             , ds_theta = theta
@@ -1594,7 +1594,7 @@ mkNewTypeEqn dflags overlap_mode tvs
             , ds_newtype = Just rep_inst_ty }
         Nothing -> return $ InferTheta $ DS
             { ds_loc = loc
-            , ds_name = dfun_name, ds_tvs = varSetElemsWellScoped dfun_tvs
+            , ds_name = dfun_name, ds_tvs = dfun_tvs
             , ds_cls = cls, ds_tys = inst_tys
             , ds_tc = rep_tycon
             , ds_theta = all_preds
@@ -1689,7 +1689,7 @@ mkNewTypeEqn dflags overlap_mode tvs
         -- Next we figure out what superclass dictionaries to use
         -- See Note [Newtype deriving superclasses] above
         cls_tyvars = classTyVars cls
-        dfun_tvs   = tyCoVarsOfTypes inst_tys
+        dfun_tvs   = tyCoVarsOfTypesWellScoped inst_tys
         inst_ty    = mkTyConApp tycon tc_args
         inst_tys   = cls_tys ++ [inst_ty]
         sc_theta   = mkThetaOrigin DerivOrigin TypeLevel $
@@ -1701,7 +1701,7 @@ mkNewTypeEqn dflags overlap_mode tvs
         -- newtype type; precisely the constraints required for the
         -- calls to coercible that we are going to generate.
         coercible_constraints =
-            [ let (Pair t1 t2) = mkCoerceClassMethEqn cls (varSetElemsWellScoped dfun_tvs) inst_tys rep_inst_ty meth
+            [ let (Pair t1 t2) = mkCoerceClassMethEqn cls dfun_tvs inst_tys rep_inst_ty meth
               in mkPredOrigin (DerivOriginCoerce meth t1 t2) TypeLevel
                               (mkReprPrimEqPred t1 t2)
             | meth <- classMethods cls ]
index 03b4d65..ebe9303 100644 (file)
@@ -37,13 +37,13 @@ import ErrUtils( Validity(..), andValid )
 import SrcLoc
 import Bag
 import VarEnv
-import VarSet (elemVarSet, partitionVarSet)
+import VarSet (elemVarSet)
 import Outputable
 import FastString
 import Util
 
 import Control.Monad (mplus)
-import Data.List (zip4)
+import Data.List (zip4, partition)
 import Data.Maybe (isJust)
 
 #include "HsVersions.h"
@@ -395,10 +395,10 @@ tc_mkRepFamInsts gk tycon inst_ty mod =
            in_scope = mkInScopeSet (tyCoVarsOfType inst_ty)
            subst    = mkTvSubst in_scope env
            repTy'   = substTy  subst repTy
-           tcv_set' = tyCoVarsOfType inst_ty
-           (tv_set', cv_set') = partitionVarSet isTyVar tcv_set'
-           tvs'     = varSetElemsWellScoped tv_set'
-           cvs'     = varSetElemsWellScoped cv_set'
+           tcv' = tyCoVarsOfTypeList inst_ty
+           (tv', cv') = partition isTyVar tcv'
+           tvs'     = toposortTyVars tv'
+           cvs'     = toposortTyVars cv'
            axiom    = mkSingleCoAxiom Nominal rep_name tvs' cvs'
                                       fam_tc [inst_ty] repTy'