Kill some unnecessary varSetElems
authorBartosz Nitka <niteria@gmail.com>
Fri, 15 Apr 2016 11:46:21 +0000 (04:46 -0700)
committerBartosz Nitka <niteria@gmail.com>
Mon, 25 Jul 2016 14:09:03 +0000 (07:09 -0700)
When you do `varSetElems (tyCoVarsOfType x)` it's equivalent to
`tyCoVarsOfTypeList x`.

Why? If you look at the implementation:
```
tyCoVarsOfTypeList ty = runFVList $ tyCoVarsOfTypeAcc ty
tyCoVarsOfType ty = runFVSet $ tyCoVarsOfTypeAcc ty
```
they use the same helper function. The helper function returns a
deterministically ordered list and a set. The only difference
between the two is which part of the result they take. It is redundant
to take the set and then immediately convert it to a list.

This helps with determinism and we eventually want to replace the uses
of `varSetElems` with functions that don't leak the values of uniques.
This change gets rid of some instances that are easy to kill.

I chose not to annotate every place where I got rid of `varSetElems`
with a comment about non-determinism, because once we get rid of
`varSetElems` it will not be possible to do the wrong thing.

Test Plan: ./validate

Reviewers: goldfire, austin, simonmar, bgamari, simonpj

Reviewed By: simonpj

Subscribers: thomie

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

GHC Trac Issues: #4012

(cherry picked from commit 928d74733975fe4677e2b558d031779f58a0883c)

13 files changed:
compiler/coreSyn/CoreFVs.hs
compiler/coreSyn/CoreLint.hs
compiler/deSugar/Desugar.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsBinds.hs
compiler/main/InteractiveEval.hs
compiler/main/TidyPgm.hs
compiler/specialise/Rules.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcTyDecls.hs
compiler/typecheck/TcValidity.hs

index d3767e7..07edee8 100644 (file)
@@ -12,7 +12,9 @@ module CoreFVs (
         -- * Free variables of expressions and binding groups
         exprFreeVars,
         exprFreeVarsDSet,
+        exprFreeVarsList,
         exprFreeIds,
+        exprsFreeIdsList,
         exprsFreeVars,
         exprsFreeVarsList,
         bindFreeVars,
@@ -20,6 +22,7 @@ module CoreFVs (
         -- * Selective free variables of expressions
         InterestingVarFun,
         exprSomeFreeVars, exprsSomeFreeVars,
+        exprsSomeFreeVarsList,
 
         -- * Free variables of Rules, Vars and Ids
         varTypeTyCoVars,
@@ -30,7 +33,7 @@ module CoreFVs (
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
         ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
         rulesFreeVarsDSet,
-        ruleLhsFreeIds,
+        ruleLhsFreeIds, ruleLhsFreeIdsList,
         vectsFreeVars,
 
         expr_fvs,
@@ -109,10 +112,20 @@ exprFreeVarsAcc = filterFV isLocalVar . expr_fvs
 exprFreeVarsDSet :: CoreExpr -> DVarSet
 exprFreeVarsDSet = runFVDSet . exprFreeVarsAcc
 
+-- | Find all locally-defined free Ids or type variables in an expression
+-- returning a deterministically ordered list.
+exprFreeVarsList :: CoreExpr -> [Var]
+exprFreeVarsList = runFVList . exprFreeVarsAcc
+
 -- | Find all locally-defined free Ids in an expression
 exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids
 exprFreeIds = exprSomeFreeVars isLocalId
 
+-- | Find all locally-defined free Ids in an expression
+-- returning a deterministically ordered list.
+exprsFreeIdsList :: [CoreExpr] -> [Id]   -- Find all locally-defined free Ids
+exprsFreeIdsList = exprsSomeFreeVarsList isLocalId
+
 -- | Find all locally-defined free Ids or type variables in several expressions
 -- returning a non-deterministic set.
 exprsFreeVars :: [CoreExpr] -> VarSet
@@ -149,6 +162,14 @@ exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting
 exprsSomeFreeVars fv_cand es =
   runFVSet $ filterFV fv_cand $ mapUnionFV expr_fvs es
 
+-- | Finds free variables in several expressions selected by a predicate
+-- returning a deterministically ordered list.
+exprsSomeFreeVarsList :: InterestingVarFun  -- Says which 'Var's are interesting
+                      -> [CoreExpr]
+                      -> [Var]
+exprsSomeFreeVarsList fv_cand es =
+  runFVList $ filterFV fv_cand $ mapUnionFV expr_fvs es
+
 --      Comment about obselete code
 -- We used to gather the free variables the RULES at a variable occurrence
 -- with the following cryptic comment:
@@ -422,9 +443,20 @@ rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
 
 ruleLhsFreeIds :: CoreRule -> VarSet
 -- ^ This finds all locally-defined free Ids on the left hand side of a rule
-ruleLhsFreeIds (BuiltinRule {}) = noFVs
-ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
-  = runFVSet $ filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
+-- and returns them as a non-deterministic set
+ruleLhsFreeIds = runFVSet . ruleLhsFreeIdsAcc
+
+ruleLhsFreeIdsList :: CoreRule -> [Var]
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns them as a determinisitcally ordered list
+ruleLhsFreeIdsList = runFVList . ruleLhsFreeIdsAcc
+
+ruleLhsFreeIdsAcc :: CoreRule -> FV
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns an FV computation
+ruleLhsFreeIdsAcc (BuiltinRule {}) = noVars
+ruleLhsFreeIdsAcc (Rule { ru_bndrs = bndrs, ru_args = args })
+  = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
 
 {-
 Note [Rule free var hack]  (Not a hack any more)
index c5bbf90..2106e2d 100644 (file)
@@ -339,7 +339,7 @@ interactiveInScope :: HscEnv -> [Var]
 --
 -- See Trac #8215 for an example
 interactiveInScope hsc_env
-  = varSetElems tyvars ++ ids
+  = tyvars ++ ids
   where
     -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
     ictxt                   = hsc_IC hsc_env
@@ -347,7 +347,7 @@ interactiveInScope hsc_env
     te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
     te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
     ids    = typeEnvIds te
-    tyvars = mapUnionVarSet (tyCoVarsOfType . idType) ids
+    tyvars = tyCoVarsOfTypesList $ map idType ids
               -- Why the type variables?  How can the top level envt have free tyvars?
               -- I think it's because of the GHCi debugger, which can bind variables
               --   f :: [t] -> [t]
index ff33177..db4c867 100644 (file)
@@ -30,7 +30,7 @@ import InstEnv
 import Class
 import Avail
 import CoreSyn
-import CoreFVs( exprsSomeFreeVars )
+import CoreFVs( exprsSomeFreeVarsList )
 import CoreSubst
 import PprCore
 import DsMonad
@@ -574,7 +574,9 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
               fn_name   = idName fn_id
               final_rhs = simpleOptExpr rhs''    -- De-crap it
               rule_name = snd (unLoc name)
-              arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
+              final_bndrs_set = mkVarSet final_bndrs
+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
+                        exprsSomeFreeVarsList isId args
 
         ; dflags <- getDynFlags
         ; rule <- dsMkUserRule this_mod is_local
index 1738a5d..ea10b74 100644 (file)
@@ -937,7 +937,7 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
     core_rec_rets <- mapM dsExpr rec_rets
     let
         -- possibly polymorphic version of vars of later_ids and rec_ids
-        out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
         out_ty = mkBigCoreVarTupTy out_ids
 
         later_tuple = mkBigCoreTup core_later_rets
index 9d740ed..801bbab 100644 (file)
@@ -780,7 +780,9 @@ decomposeRuleLhs orig_bndrs orig_lhs
         -- Add extra dict binders: Note [Free dictionaries]
    mk_extra_dict_bndrs fn_id args
      = [ mkLocalId (localiseName (idName d)) (idType d)
-       | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs))
+       | d <- exprsFreeVarsList args
+       , not (d `elemVarSet` orig_bndr_set)
+       , not (d == fn_id)
               -- fn_id: do not quantify over the function itself, which may
               -- itself be a dictionary (in pathological cases, Trac #10251)
        , isDictId d ]
index c58bf04..b879eec 100644 (file)
@@ -516,8 +516,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
 
        (ids, offsets) = unzip pointers
 
-       free_tvs = mapUnionVarSet (tyCoVarsOfType . idType) ids
-                  `unionVarSet` tyCoVarsOfType result_ty
+       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
 
    -- It might be that getIdValFromApStack fails, because the AP_STACK
    -- has been accidentally evaluated, or something else has gone wrong.
@@ -563,12 +562,12 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
      = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
           ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
 
-   newTyVars :: UniqSupply -> TcTyVarSet -> TCvSubst
+   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
      -- Similarly, clone the type variables mentioned in the types
      -- we have here, *and* make them all RuntimeUnk tyars
    newTyVars us tvs
      = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
-                    | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
+                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us
                     , let name = setNameUnique (tyVarName tv) uniq ]
 
 rttiEnvironment :: HscEnv -> IO HscEnv
index 89d7585..9a8d4c6 100644 (file)
@@ -950,7 +950,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
 
     expose_rule rule
         | omit_prags = False
-        | otherwise  = all is_external_id (varSetElems (ruleLhsFreeIds rule))
+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
                 -- Don't expose a rule whose LHS mentions a locally-defined
                 -- Id that is completely internal (i.e. not visible to an
                 -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
index fbae186..02fe775 100644 (file)
@@ -33,7 +33,7 @@ import Module           ( Module, ModuleSet, elemModuleSet )
 import CoreSubst
 import OccurAnal        ( occurAnalyseExpr )
 import CoreFVs          ( exprFreeVars, exprsFreeVars, bindFreeVars
-                        , rulesFreeVarsDSet, exprsOrphNames )
+                        , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
 import CoreUtils        ( exprType, eqExpr, mkTick, mkTicks,
                           stripTicksTopT, stripTicksTopE )
 import PprCore          ( pprRules )
@@ -898,7 +898,7 @@ match_tmpl_var :: RuleMatchEnv
 match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })
                subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })
                v1' e2
-  | any (inRnEnvR rn_env) (varSetElems (exprFreeVars e2))
+  | any (inRnEnvR rn_env) (exprFreeVarsList e2)
   = Nothing     -- Occurs check failure
                 -- e.g. match forall a. (\x-> a x) against (\y. y y)
 
index c6ba6f3..1418a2b 100644 (file)
@@ -1945,7 +1945,7 @@ mkDictErr ctxt cts
     is_no_inst (ct, (matches, unifiers, _))
       =  no_givens
       && null matches
-      && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyCoVarsOfCt ct)))
+      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
 
     lookup_cls_inst inst_envs ct
                 -- Note [Flattening in error message generation]
index 6f7afa0..39ad787 100644 (file)
@@ -392,7 +392,7 @@ runSolverPipeline pipeline workItem
            ContinueWith ct -> do { traceFireTcS (ctEvidence ct) (text "Kept as inert")
                                  ; traceTcS "End solver pipeline (kept as inert) }" $
                                        vcat [ text "final_item =" <+> ppr ct
-                                            , pprTvBndrs (varSetElems $ tyCoVarsOfCt ct)
+                                            , pprTvBndrs $ tyCoVarsOfCtList ct
                                             , text "inerts     =" <+> ppr final_is]
                                  ; addInertCan ct }
        }
index 56f1fc9..c86785d 100644 (file)
@@ -570,7 +570,8 @@ simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds
                                --     hence "incl_derivs"
 
               else do { let quant_cand = approximateWC wanted_transformed
-                            meta_tvs   = filter isMetaTyVar (varSetElems (tyCoVarsOfCts quant_cand))
+                            meta_tvs   = filter isMetaTyVar $
+                                         tyCoVarsOfCtsList quant_cand
 
                       ; gbl_tvs <- tcGetGlobalTyCoVars
                             -- Miminise quant_cand.  We are not interested in any evidence
@@ -1785,7 +1786,7 @@ floatEqualities skols no_given_eqs
   | otherwise
   = do { outer_tclvl <- TcS.getTcLevel
        ; mapM_ (promoteTyVarTcS outer_tclvl)
-               (varSetElems (tyCoVarsOfCts float_eqs))
+               (tyCoVarsOfCtsList float_eqs)
            -- See Note [Promoting unification variables]
 
        ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
index 54d7d5b..a4b6537 100644 (file)
@@ -672,8 +672,8 @@ irClass cls
     cls_tv_set = mkVarSet cls_tvs
 
     ir_at at_tc
-      = mapM_ (updateRole Nominal) (varSetElems nvars)
-      where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set
+      = mapM_ (updateRole Nominal) nvars
+      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc
 
 -- See Note [Role inference]
 irDataCon :: DataCon -> RoleM ()
index 84c79e7..de61b22 100644 (file)
@@ -1725,8 +1725,9 @@ checkZonkValidTelescope hs_tvs orig_tvs extra
         -- over it in kindGeneralize, as we should.
 
     go errs in_scope  (tv:tvs)
-      = let bad_tvs = tyCoVarsOfType (tyVarKind tv) `minusVarSet` in_scope in
-        go (varSetElems bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
+      = let bad_tvs = filterOut (`elemVarSet` in_scope) $
+                      tyCoVarsOfTypeList (tyVarKind tv)
+        in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
 
 -- | After inferring kinds of type variables, check to make sure that the
 -- inferred kinds any of the type variables bound in a smaller scope.