projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Do less simplification when doing let-generalisation
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcSMonad.lhs
diff --git
a/compiler/typecheck/TcSMonad.lhs
b/compiler/typecheck/TcSMonad.lhs
index
4965a93
..
a71548c
100644
(file)
--- a/
compiler/typecheck/TcSMonad.lhs
+++ b/
compiler/typecheck/TcSMonad.lhs
@@
-31,11
+31,12
@@
module TcSMonad (
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
- getTcEvBindsBag, getTcSContext, getTcSTyBinds,
+ getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
newFlattenSkolemTy, -- Flatten skolems
newFlattenSkolemTy, -- Flatten skolems
+
instDFunTypes, -- Instantiation
instDFunConstraints,
instDFunTypes, -- Instantiation
instDFunConstraints,
@@
-63,7
+64,6
@@
module TcSMonad (
import HscTypes
import BasicTypes
import HscTypes
import BasicTypes
-import Type
import Inst
import InstEnv
import Inst
import InstEnv
@@
-83,8
+83,11
@@
import DynFlags
import Coercion
import Class
import TyCon
import Coercion
import Class
import TyCon
+import TypeRep
+
import Name
import Var
import Name
import Var
+import VarEnv
import Outputable
import Bag
import MonadUtils
import Outputable
import Bag
import MonadUtils
@@
-334,7
+337,7
@@
data TcSEnv
tcs_ev_binds :: EvBindsVar,
-- Evidence bindings
tcs_ev_binds :: EvBindsVar,
-- Evidence bindings
- tcs_ty_binds :: IORef (Bag (TcTyVar, TcType)),
+ tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
-- Global type bindings
tcs_context :: SimplContext
-- Global type bindings
tcs_context :: SimplContext
@@
-413,7
+416,7
@@
runTcS :: SimplContext
-> TcS a -- What to run
-> TcM (a, Bag EvBind)
runTcS context untouch tcs
-> TcS a -- What to run
-> TcM (a, Bag EvBind)
runTcS context untouch tcs
- = do { ty_binds_var <- TcM.newTcRef emptyBag
+ = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
@@
-424,13
+427,14
@@
runTcS context untouch tcs
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
-- Perform the type unifications required
; ty_binds <- TcM.readTcRef ty_binds_var
- ; mapBagM_ do_unification ty_binds
+ ; mapM_ do_unification (varEnvElts ty_binds)
-- And return
; ev_binds <- TcM.readTcRef evb_ref
; return (res, evBindMapBinds ev_binds) }
where
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
-- And return
; ev_binds <- TcM.readTcRef evb_ref
; return (res, evBindMapBinds ev_binds) }
where
do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
+
nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
nestImplicTcS ref untouch tcs
nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a
nestImplicTcS ref untouch tcs
@@
-451,7
+455,7
@@
tryTcS :: TcTyVarSet -> TcS a -> TcS a
-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
tryTcS untch tcs
-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
tryTcS untch tcs
- = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyBag
+ = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
; let env1 = env { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var }
; ev_binds_var <- TcM.newTcEvBinds
; let env1 = env { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var }
@@
-469,9
+473,13
@@
getTcSContext = TcS (return . tcs_context)
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
getTcEvBinds :: TcS EvBindsVar
getTcEvBinds = TcS (return . tcs_ev_binds)
-getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
+getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
getTcSTyBinds = TcS (return . tcs_ty_binds)
getTcSTyBinds = TcS (return . tcs_ty_binds)
+getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
+getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
+
+
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
@@
-492,7
+500,7
@@
setWantedTyBind tv ty
= do { ref <- getTcSTyBinds
; wrapTcS $
do { ty_binds <- TcM.readTcRef ref
= do { ref <- getTcSTyBinds
; wrapTcS $
do { ty_binds <- TcM.readTcRef ref
- ; TcM.writeTcRef ref (ty_binds `snocBag` (tv,ty)) } }
+ ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
setIPBind :: EvVar -> EvTerm -> TcS ()
setIPBind = setEvBind
setIPBind :: EvVar -> EvTerm -> TcS ()
setIPBind = setEvBind
@@
-570,7
+578,8
@@
newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
newFlattenSkolemTyVar ty
= wrapTcS $ do { uniq <- TcM.newUnique
; let name = mkSysTvName uniq (fsLit "f")
newFlattenSkolemTyVar ty
= wrapTcS $ do { uniq <- TcM.newUnique
; let name = mkSysTvName uniq (fsLit "f")
- ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
+ ; return $
+ mkTcTyVar name (typeKind ty) (FlatSkol ty)
}
-- Instantiations
}
-- Instantiations