[commit: ghc] master: Kill varEnvElts in tcPragExpr (13e40f9)
git at git.haskell.org
git at git.haskell.org
Thu May 19 00:19:59 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/13e40f998e15a626a4212bde0987ddbc98b3f56f/ghc
>---------------------------------------------------------------
commit 13e40f998e15a626a4212bde0987ddbc98b3f56f
Author: Bartosz Nitka <niteria at gmail.com>
Date: Wed May 18 16:47:29 2016 -0700
Kill varEnvElts in tcPragExpr
I had to refactor some things to take VarSet instead of [Var],
but I think it's more precise this way.
Test Plan: ./validate
Reviewers: simonmar, simonpj, austin, bgamari, goldfire
Reviewed By: simonpj
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2227
GHC Trac Issues: #4012
>---------------------------------------------------------------
13e40f998e15a626a4212bde0987ddbc98b3f56f
compiler/coreSyn/CoreLint.hs | 10 ++++++++--
compiler/iface/IfaceEnv.hs | 16 ++++++++--------
compiler/iface/TcIface.hs | 13 +++++++++----
compiler/typecheck/TcRnMonad.hs | 5 ++---
compiler/typecheck/TcRnTypes.hs | 4 ++--
5 files changed, 29 insertions(+), 19 deletions(-)
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 2a2284b..0261f7e 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -428,7 +428,7 @@ We use this to check all unfoldings that come in from interfaces
lintUnfolding :: DynFlags
-> SrcLoc
- -> [Var] -- Treat these as in scope
+ -> VarSet -- Treat these as in scope
-> CoreExpr
-> Maybe MsgDoc -- Nothing => OK
@@ -438,7 +438,7 @@ lintUnfolding dflags locn vars expr
where
(_warns, errs) = initL dflags defaultLintFlags linter
linter = addLoc (ImportedUnfolding locn) $
- addInScopeVars vars $
+ addInScopeVarSet vars $
lintCoreExpr expr
lintExpr :: DynFlags
@@ -1778,6 +1778,12 @@ addInScopeVars vars m
unLintM m (env { le_subst = extendTCvInScopeList (le_subst env) vars })
errs
+addInScopeVarSet :: VarSet -> LintM a -> LintM a
+addInScopeVarSet vars m
+ = LintM $ \ env errs ->
+ unLintM m (env { le_subst = extendTCvInScopeSet (le_subst env) vars })
+ errs
+
addInScopeVar :: Var -> LintM a -> LintM a
addInScopeVar var m
= LintM $ \ env errs ->
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index 20b497b..0c8d8e9 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -30,8 +30,8 @@ import Var
import Name
import Avail
import Module
-import UniqFM
import FastString
+import FastStringEnv
import IfaceType
import UniqSupply
import SrcLoc
@@ -259,7 +259,7 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
- ; case (lookupUFM (if_id_env lcl) occ) of
+ ; case (lookupFsEnv (if_id_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
}
@@ -267,7 +267,7 @@ tcIfaceLclId occ
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids thing_inside
= do { env <- getLclEnv
- ; let { id_env' = addListToUFM (if_id_env env) pairs
+ ; let { id_env' = extendFsEnvList (if_id_env env) pairs
; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
; setLclEnv (env { if_id_env = id_env' }) thing_inside }
@@ -275,7 +275,7 @@ extendIfaceIdEnv ids thing_inside
tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
- ; case (lookupUFM (if_tv_env lcl) occ) of
+ ; case (lookupFsEnv (if_tv_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
@@ -283,20 +283,20 @@ tcIfaceTyVar occ
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar (occ, _)
= do { lcl <- getLclEnv
- ; return (lookupUFM (if_tv_env lcl) occ) }
+ ; return (lookupFsEnv (if_tv_env lcl) occ) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (occ, _))
= do { lcl <- getLclEnv
- ; return (lookupUFM (if_id_env lcl) occ) }
+ ; return (lookupFsEnv (if_id_env lcl) occ) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
- ; return (lookupUFM (if_tv_env lcl) occ) }
+ ; return (lookupFsEnv (if_tv_env lcl) occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
= do { env <- getLclEnv
- ; let { tv_env' = addListToUFM (if_tv_env env) pairs
+ ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 9a4a5c7..8bc0dd1 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1277,7 +1277,7 @@ tcPragExpr name expr
where
doc = text "Unfolding of" <+> ppr name
- get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+ get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
; rec_ids <- case if_rec_types gbl_env of
@@ -1285,9 +1285,14 @@ tcPragExpr name expr
Just (_, get_env) -> do
{ type_env <- setLclEnv () get_env
; return (typeEnvIds type_env) }
- ; return (varEnvElts (if_tv_env lcl_env) ++
- varEnvElts (if_id_env lcl_env) ++
- rec_ids) }
+ ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
+ bindingsVars (if_id_env lcl_env) `unionVarSet`
+ mkVarSet rec_ids) }
+
+ bindingsVars :: FastStringEnv Var -> VarSet
+ bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
+ -- It's OK to use nonDetEltsUFM here because we immediately forget
+ -- the ordering by creating a set
{-
************************************************************************
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index c4e66a0..88c63f9 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -42,7 +42,6 @@ import NameSet
import Bag
import Outputable
import UniqSupply
-import UniqFM
import DynFlags
import StaticFlags
import FastString
@@ -1465,8 +1464,8 @@ setLocalRdrEnv rdr_env thing_inside
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
if_loc = loc,
- if_tv_env = emptyUFM,
- if_id_env = emptyUFM }
+ if_tv_env = emptyFsEnv,
+ if_id_env = emptyFsEnv }
-- | Run an 'IfG' (top-level interface monad) computation inside an existing
-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 3fd2a83..dede932 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -279,8 +279,8 @@ data IfLclEnv
-- .hi file, or GHCi state, or ext core
-- plus which bit is currently being examined
- if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings
- if_id_env :: UniqFM Id -- Nested id binding
+ if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings
+ if_id_env :: FastStringEnv Id -- Nested id binding
}
{-
More information about the ghc-commits
mailing list