[Git][ghc/ghc][wip/sjakobi/nondetfolds] Add and use evBindMapToVarSet

[Simon Jakobi]

Simon Jakobi pushed to branch wip/sjakobi/nondetfolds at Glasgow Haskell Compiler / GHC


Commits:
eb7a7b79 by Simon Jakobi at 2020-03-31T04:08:00+02:00
Add and use evBindMapToVarSet

- - - - -


3 changed files:

- compiler/GHC/Types/Unique/DFM.hs
- compiler/typecheck/TcEvidence.hs
- compiler/typecheck/TcSimplify.hs


Changes:

=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -359,7 +359,7 @@ delListFromUDFM = foldl' delFromUDFM
 -- | This allows for lossy conversion from UniqDFM to UniqFM
 udfmToUfm :: UniqDFM elt -> UniqFM elt
 udfmToUfm (UDFM m _i) =
-  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m]
+  listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] -- TODO
 
 listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt
 listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM


=====================================
compiler/typecheck/TcEvidence.hs
=====================================
@@ -19,6 +19,7 @@ module TcEvidence (
   foldEvBindMap, nonDetStrictFoldEvBindMap,
   filterEvBindMap,
   isEmptyEvBindMap,
+  evBindMapToVarSet,
   EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
   evBindVar, isCoEvBindsVar,
 
@@ -57,6 +58,8 @@ module TcEvidence (
 
 import GhcPrelude
 
+import GHC.Types.Unique.DFM
+import GHC.Types.Unique.FM
 import GHC.Types.Var
 import GHC.Core.Coercion.Axiom
 import GHC.Core.Coercion
@@ -505,6 +508,9 @@ filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap
 filterEvBindMap k (EvBindMap { ev_bind_varenv = env })
   = EvBindMap { ev_bind_varenv = filterDVarEnv k env }
 
+evBindMapToVarSet :: EvBindMap -> VarSet
+evBindMapToVarSet (EvBindMap dve) = unsafeUFMToUniqSet (mapUFM evBindVar (udfmToUfm dve))
+
 instance Outputable EvBindMap where
   ppr (EvBindMap m) = ppr m
 


=====================================
compiler/typecheck/TcSimplify.hs
=====================================
@@ -2381,7 +2381,7 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
              seed_skols = mkVarSet skols     `unionVarSet`
                           mkVarSet given_ids `unionVarSet`
                           foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
-                          foldEvBindMap add_one_bind emptyVarSet binds -- TODO
+                          evBindMapToVarSet binds
              -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
              -- Include the EvIds of any non-floating constraints
 
@@ -2406,9 +2406,6 @@ floatEqualities skols given_ids ev_binds_var no_given_eqs
        ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }
 
   where
-    add_one_bind :: EvBind -> VarSet -> VarSet
-    add_one_bind bind acc = extendVarSet acc (evBindVar bind)
-
     add_non_flt_ct :: Ct -> VarSet -> VarSet
     add_non_flt_ct ct acc | isDerivedCt ct = acc
                           | otherwise      = extendVarSet acc (ctEvId ct)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb7a7b79d5001f351668afb24397554e85583a99

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eb7a7b79d5001f351668afb24397554e85583a99
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200330/ef24a881/attachment-0001.html>