Use DVarEnv for vectInfoVar

This makes sure that we don't introduce unnecessary
nondeterminism from vectorization.

Also updates dph submodule to reflect the change in types.

GHC Trac: #4012

8 files changed, 40 insertions, 33 deletions

diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index ee63e2c3a2..626b5cdd45 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -27,15 +27,16 @@ module VarEnv (
         DVarEnv, DIdEnv, DTyVarEnv,
 
         -- ** Manipulating these environments
-        emptyDVarEnv,
+        emptyDVarEnv, mkDVarEnv,
         dVarEnvElts,
         extendDVarEnv, extendDVarEnv_C,
+        extendDVarEnvList,
         lookupDVarEnv,
         isEmptyDVarEnv, foldDVarEnv,
         mapDVarEnv,
         modifyDVarEnv,
         alterDVarEnv,
-        plusDVarEnv_C,
+        plusDVarEnv, plusDVarEnv_C,
         unitDVarEnv,
         delDVarEnv,
         delDVarEnvList,
@@ -515,6 +516,9 @@ emptyDVarEnv = emptyUDFM
 dVarEnvElts :: DVarEnv a -> [a]
 dVarEnvElts = eltsUDFM
 
+mkDVarEnv :: [(Var, a)] -> DVarEnv a
+mkDVarEnv = listToUDFM
+
 extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a
 extendDVarEnv = addToUDFM
 
@@ -530,6 +534,9 @@ mapDVarEnv = mapUDFM
 alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a
 alterDVarEnv = alterUDFM
 
+plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a
+plusDVarEnv = plusUDFM
+
 plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a
 plusDVarEnv_C = plusUDFM_C
 
@@ -557,5 +564,8 @@ modifyDVarEnv mangle_fn env key
 partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a)
 partitionDVarEnv = partitionUDFM
 
+extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a
+extendDVarEnvList = addListToUDFM
+
 anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool
 anyDVarEnv = anyUDFM
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index d6a70e4d43..9ebc03c143 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -324,7 +324,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                                , vectInfoParallelTyCons = vParallelTyCons
                                }) =
        IfaceVectInfo
-       { ifaceVectInfoVar            = [Var.varName v | (v, _  ) <- varEnvElts  vVar]
+       { ifaceVectInfoVar            = [Var.varName v | (v, _  ) <- dVarEnvElts vVar]
        , ifaceVectInfoTyCon          = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
        , ifaceVectInfoTyConReuse     = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
        , ifaceVectInfoParallelVars   = [Var.varName v | v <- dVarSetElems vParallelVars]
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 1f83221725..f366c516cd 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -783,7 +783,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        ; vParallelVars <- mapM vectVar                         parallelVars
        ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo
-                  { vectInfoVar            = mkVarEnv  vVars `extendVarEnvList` concat vScSels
+                  { vectInfoVar            = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
                   , vectInfoTyCon          = mkNameEnv vTyCons
                   , vectInfoDataCon        = mkNameEnv (concat vDataCons)
                   , vectInfoParallelVars   = mkDVarSet vParallelVars
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index b71e8ae6e6..99c51cd328 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -2640,7 +2640,7 @@ on just the OccName easily in a Core pass.
 --
 data VectInfo
   = VectInfo
-    { vectInfoVar            :: VarEnv  (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
+    { vectInfoVar            :: DVarEnv (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
     , vectInfoTyCon          :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@
     , vectInfoDataCon        :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@
     , vectInfoParallelVars   :: DVarSet                     -- ^ set of parallel variables
@@ -2674,11 +2674,11 @@ data IfaceVectInfo
 
 noVectInfo :: VectInfo
 noVectInfo
-  = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet
+  = VectInfo emptyDVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet
 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 =
-  VectInfo (vectInfoVar            vi1 `plusVarEnv`    vectInfoVar            vi2)
+  VectInfo (vectInfoVar            vi1 `plusDVarEnv`   vectInfoVar            vi2)
            (vectInfoTyCon          vi1 `plusNameEnv`   vectInfoTyCon          vi2)
            (vectInfoDataCon        vi1 `plusNameEnv`   vectInfoDataCon        vi2)
            (vectInfoParallelVars   vi1 `unionDVarSet`  vectInfoParallelVars   vi2)
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index c02c786ed5..915cd12450 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -57,7 +57,7 @@ import Maybes
 import UniqSupply
 import ErrUtils (Severity(..))
 import Outputable
-import UniqFM
+import UniqDFM
 import SrcLoc
 import qualified ErrUtils as Err
 
@@ -484,17 +484,14 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
   where
       -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
       -- inconsistent)
-    tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
-                         | (var, var_v) <- nonDetEltsUFM vars
-                         -- It's OK to use nonDetEltsUFM here because we
-                         -- immediately forget the ordering by creating
-                         -- a new env
-                         , let tidy_var   = lookup_var var
-                               tidy_var_v = lookup_var var_v
-                         , isExternalId tidy_var   && isExportedId tidy_var
-                         , isExternalId tidy_var_v && isExportedId tidy_var_v
-                         , isDataConWorkId var || not (isImplicitId var)
-                         ]
+    tidy_vars = mkDVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
+                          | (var, var_v) <- eltsUDFM vars
+                          , let tidy_var   = lookup_var var
+                                tidy_var_v = lookup_var var_v
+                          , isExternalId tidy_var   && isExportedId tidy_var
+                          , isExternalId tidy_var_v && isExportedId tidy_var_v
+                          , isDataConWorkId var || not (isImplicitId var)
+                          ]
 
     tidy_parallelVars = mkDVarSet
                           [ tidy_var
@@ -625,7 +622,7 @@ chooseExternalIds :: HscEnv
                   -> [CoreBind]
                   -> [CoreBind]
                   -> [CoreRule]
-                  -> VarEnv (Var, Var)
+                  -> DVarEnv (Var, Var)
                   -> IO (UnfoldEnv, TidyOccEnv)
                   -- Step 1 from the notes above
 
@@ -662,9 +659,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
     isJust $ collectStaticPtrSatArgs e
 
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
-  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nonDetEltsUFM vect_vars, isGlobalId var]
-    -- It's OK to use nonDetEltsUFM here because we immediately forget the
-    -- ordering by creating a set
+  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
 
   flatten_binds    = flattenBinds binds
   binders          = map fst flatten_binds
@@ -716,7 +711,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                 | otherwise  = addExternal expose_all refined_id
 
                 -- add vectorised version if any exists
-          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc)
+          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupDVarEnv vect_vars idocc)
 
                 -- 'idocc' is an *occurrence*, but we need to see the
                 -- unfolding in the *definition*; so look up in binder_set
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 29035c87bb..8bc03929f0 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -659,10 +659,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
                    -- (In contrast to automatically vectorised variables, their unvectorised versions
                    -- don't depend on them.)
                  vectVars = mkVarSet $
-                              catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
+                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
                                         | Vect bndr _ <- mg_vect_decls guts]
                               ++
-                              catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
+                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
                                         | bndr <- bindersOfBinds binds]
                                         -- FIXME: This second comprehensions is only needed as long as we
                                         --        have vectorised bindings where we get "Could NOT call
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index e4ab79eed7..faaad69ba7 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -149,7 +149,7 @@ initGlobalEnv :: Bool
 initGlobalEnv vectAvoid info vectDecls instEnvs famInstEnvs
   = GlobalEnv
   { global_vect_avoid           = vectAvoid
-  , global_vars                 = mapVarEnv snd $ vectInfoVar info
+  , global_vars                 = mapVarEnv snd $ udfmToUfm $ vectInfoVar info
   , global_vect_decls           = mkVarEnv vects
   , global_parallel_vars        = vectInfoParallelVars info
   , global_parallel_tycons      = vectInfoParallelTyCons info
@@ -206,7 +206,7 @@ setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
 modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
 modVectInfo env mg_ids mg_tyCons vectDecls info
   = info
-    { vectInfoVar            = mk_env ids      (global_vars     env)
+    { vectInfoVar            = mk_denv ids     (global_vars     env)
     , vectInfoTyCon          = mk_env tyCons   (global_tycons   env)
     , vectInfoDataCon        = mk_env dataCons (global_datacons env)
     , vectInfoParallelVars   = (global_parallel_vars   env `minusDVarSet`  vectInfoParallelVars   info)
@@ -228,8 +228,10 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
                              , cls <- maybeToList . tyConClass_maybe $ tycon]
 
     -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
-    mk_env decls inspectedEnv
-      = mkNameEnv [(name, (decl, to))
-                  | decl     <- decls
-                  , let name = getName decl
-                  , Just to  <- [lookupNameEnv inspectedEnv name]]
+    mk_env decls inspectedEnv = mkNameEnv $ mk_assoc_env decls inspectedEnv
+    mk_denv decls inspectedEnv = listToUDFM $ mk_assoc_env decls inspectedEnv
+    mk_assoc_env decls inspectedEnv
+      = [(name, (decl, to))
+        | decl     <- decls
+        , let name = getName decl
+        , Just to  <- [lookupNameEnv inspectedEnv name]]
diff --git a/libraries/dph b/libraries/dph
-Subproject 33eb2fb7e178c18f2afd0d537d791d021ff7523
+Subproject 64eca669f13f4d216af9024474a3fc73ce10179