summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/CoreSubst.lhs6
-rw-r--r--compiler/main/DynFlags.hs3
-rw-r--r--compiler/main/StaticFlags.hs5
-rw-r--r--compiler/rename/RnEnv.lhs43
-rw-r--r--compiler/typecheck/TcHsSyn.lhs801
-rw-r--r--compiler/typecheck/TcSMonad.lhs14
-rw-r--r--ghc.mk4
-rw-r--r--includes/ghc.mk2
-rw-r--r--rts/RtsAPI.c11
-rw-r--r--rts/ghc.mk11
-rw-r--r--rules/build-dependencies.mk14
-rw-r--r--rules/c-sources.mk5
12 files changed, 454 insertions, 465 deletions
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 4f6883ab6e..95cb7f8fbb 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -919,10 +919,8 @@ type OutExpr = CoreExpr
-- In these functions the substitution maps InVar -> OutExpr
----------------------
-simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
-simple_opt_expr s e = simple_opt_expr' s e
-
-simple_opt_expr' subst expr
+simple_opt_expr :: Subst -> InExpr -> OutExpr
+simple_opt_expr subst expr
= go expr
where
go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 905c0d884e..61d64e407c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -349,6 +349,7 @@ data GeneralFlag
| Opt_RPath
| Opt_RelativeDynlibPaths
| Opt_Hpc
+ | Opt_FlatCache
-- PreInlining is on by default. The option is there just to see how
-- bad things get if you turn it off!
@@ -2500,6 +2501,7 @@ fFlags = [
( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ),
( "hpc", Opt_Hpc, nop ),
( "pre-inlining", Opt_SimplPreInlining, nop ),
+ ( "flat-cache", Opt_FlatCache, nop ),
( "use-rpaths", Opt_RPath, nop )
]
@@ -2690,6 +2692,7 @@ defaultFlags settings
Opt_HelpfulErrors,
Opt_ProfCountEntries,
Opt_SimplPreInlining,
+ Opt_FlatCache,
Opt_RPath
]
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index cbdfea682d..a1104de5f6 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -30,7 +30,6 @@ module StaticFlags (
opt_NoStateHack,
opt_CprOff,
opt_NoOptCoercion,
- opt_NoFlatCache,
-- For the parser
addOpt, removeOpt, v_opt_C_ready,
@@ -146,7 +145,6 @@ isStaticFlag f =
"fdicts-strict",
"fno-state-hack",
"fno-opt-coercion",
- "fno-flat-cache",
"fcpr-off"
]
@@ -198,9 +196,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off")
opt_NoOptCoercion :: Bool
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
-opt_NoFlatCache :: Bool
-opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache")
-
-----------------------------------------------------------------------------
-- Convert sizes like "3.5M" into integers
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 90061b10a2..6db6011656 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -72,12 +72,6 @@ import qualified Data.Set as Set
import Constants ( mAX_TUPLE_SIZE )
\end{code}
-\begin{code}
--- XXX
-thenM :: Monad a => a b -> (b -> a c) -> a c
-thenM = (>>=)
-\end{code}
-
%*********************************************************
%* *
Source-code binders
@@ -530,8 +524,8 @@ we'll miss the fact that the qualified import is redundant.
\begin{code}
getLookupOccRn :: RnM (Name -> Maybe Name)
getLookupOccRn
- = getLocalRdrEnv `thenM` \ local_env ->
- return (lookupLocalRdrOcc local_env . nameOccName)
+ = do local_env <- getLocalRdrEnv
+ return (lookupLocalRdrOcc local_env . nameOccName)
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
lookupLocatedOccRn = wrapLocM lookupOccRn
@@ -814,15 +808,15 @@ lookupQualifiedName rdr_name
| Just (mod,occ) <- isQual_maybe rdr_name
-- Note: we want to behave as we would for a source file import here,
-- and respect hiddenness of modules/packages, hence loadSrcInterface.
- = loadSrcInterface doc mod False Nothing `thenM` \ iface ->
+ = do iface <- loadSrcInterface doc mod False Nothing
- case [ name
- | avail <- mi_exports iface,
- name <- availNames avail,
- nameOccName name == occ ] of
- (n:ns) -> ASSERT (null ns) return (Just n)
- _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name)
- ; return Nothing }
+ case [ name
+ | avail <- mi_exports iface,
+ name <- availNames avail,
+ nameOccName name == occ ] of
+ (n:ns) -> ASSERT (null ns) return (Just n)
+ _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name)
+ ; return Nothing }
| otherwise
= pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
@@ -1089,9 +1083,9 @@ lookupFixity is a bit strange.
\begin{code}
lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name
- = getModule `thenM` \ this_mod ->
- if nameIsLocalOrFrom this_mod name
+lookupFixityRn name = do
+ this_mod <- getModule
+ if nameIsLocalOrFrom this_mod name
then do -- It's defined in this module
local_fix_env <- getFixityEnv
traceRn (text "lookupFixityRn: looking up name in local environment:" <+>
@@ -1114,11 +1108,10 @@ lookupFixityRn name
--
-- loadInterfaceForName will find B.hi even if B is a hidden module,
-- and that's what we want.
- loadInterfaceForName doc name `thenM` \ iface -> do {
- traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
- vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]);
+ do iface <- loadInterfaceForName doc name
+ traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
+ vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)])
return (mi_fix_fn iface (nameOccName name))
- }
where
doc = ptext (sLit "Checking fixity for") <+> ppr name
@@ -1262,8 +1255,8 @@ bindLocatedLocalsFV :: [Located RdrName]
-> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
bindLocatedLocalsFV rdr_names enclosed_scope
= bindLocatedLocalsRn rdr_names $ \ names ->
- enclosed_scope names `thenM` \ (thing, fvs) ->
- return (thing, delFVs names fvs)
+ do (thing, fvs) <- enclosed_scope names
+ return (thing, delFVs names fvs)
-------------------------------------
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 1e2961258d..04e5582df1 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -9,26 +9,19 @@ This module is an extension of @HsSyn@ syntax, for use in the type
checker.
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module TcHsSyn (
- mkHsConApp, mkHsDictLet, mkHsApp,
- hsLitType, hsLPatType, hsPatType,
- mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit,
- shortCutLit, hsOverLitName,
-
- -- re-exported from TcMonad
- TcId, TcIdSet,
-
- zonkTopDecls, zonkTopExpr, zonkTopLExpr,
- zonkTopBndrs, zonkTyBndrsX,
- emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv,
+ mkHsConApp, mkHsDictLet, mkHsApp,
+ hsLitType, hsLPatType, hsPatType,
+ mkHsAppTy, mkSimpleHsAlt,
+ nlHsIntLit,
+ shortCutLit, hsOverLitName,
+
+ -- re-exported from TcMonad
+ TcId, TcIdSet,
+
+ zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+ zonkTopBndrs, zonkTyBndrsX,
+ emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv,
zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc,
) where
@@ -60,26 +53,12 @@ import Bag
import FastString
import Outputable
import Util
--- import Data.Traversable( traverse )
-\end{code}
-
-\begin{code}
--- XXX
-thenM :: Monad a => a b -> (b -> a c) -> a c
-thenM = (>>=)
-
-returnM :: Monad m => a -> m a
-returnM = return
-
-mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
-mappM = mapM
\end{code}
-
%************************************************************************
-%* *
+%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
-%* *
+%* *
%************************************************************************
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
@@ -133,11 +112,11 @@ shortCutLit dflags (HsIntegral i) ty
| isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
| otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty
- -- The 'otherwise' case is important
- -- Consider (3 :: Float). Syntactically it looks like an IntLit,
- -- so we'll call shortCutIntLit, but of course it's a float
- -- This can make a big difference for programs with a lot of
- -- literals, compiled without -O
+ -- The 'otherwise' case is important
+ -- Consider (3 :: Float). Syntactically it looks like an IntLit,
+ -- so we'll call shortCutIntLit, but of course it's a float
+ -- This can make a big difference for programs with a lot of
+ -- literals, compiled without -O
shortCutLit _ (HsFractional f) ty
| isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
@@ -160,9 +139,9 @@ hsOverLitName (HsIsString {}) = fromStringName
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%* *
+%* *
%************************************************************************
The rest of the zonking is done *after* typechecking.
@@ -179,26 +158,26 @@ The Ids are converted by binding them in the normal Tc envt; that
way we maintain sharing; eg an Id is zonked at its binding site and they
all occurrences of that Id point to the common zonked copy
-It's all pretty boring stuff, because HsSyn is such a large type, and
+It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
-type UnboundTyVarZonker = TcTyVar-> TcM Type
- -- How to zonk an unbound type variable
+type UnboundTyVarZonker = TcTyVar-> TcM Type
+ -- How to zonk an unbound type variable
-- Note [Zonking the LHS of a RULE]
-data ZonkEnv
- = ZonkEnv
+data ZonkEnv
+ = ZonkEnv
UnboundTyVarZonker
- (TyVarEnv TyVar) --
- (IdEnv Var) -- What variables are in scope
- -- Maps an Id or EvVar to its zonked version; both have the same Name
- -- Note that all evidence (coercion variables as well as dictionaries)
- -- are kept in the ZonkEnv
- -- Only *type* abstraction is done by side effect
- -- Is only consulted lazily; hence knot-tying
-
-instance Outputable ZonkEnv where
+ (TyVarEnv TyVar) --
+ (IdEnv Var) -- What variables are in scope
+ -- Maps an Id or EvVar to its zonked version; both have the same Name
+ -- Note that all evidence (coercion variables as well as dictionaries)
+ -- are kept in the ZonkEnv
+ -- Only *type* abstraction is done by side effect
+ -- Is only consulted lazily; hence knot-tying
+
+instance Outputable ZonkEnv where
ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))
@@ -209,11 +188,11 @@ mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
-extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids
+extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids
= ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
-extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
+extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
= ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
@@ -230,43 +209,43 @@ zonkEnvIds :: ZonkEnv -> [Id]
zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env
zonkIdOcc :: ZonkEnv -> TcId -> Id
--- Ids defined in this module should be in the envt;
+-- Ids defined in this module should be in the envt;
-- ignore others. (Actually, data constructors are also
-- not LocalVars, even when locally defined, but that is fine.)
-- (Also foreign-imported things aren't currently in the ZonkEnv;
-- that's ok because they don't need zonking.)
--
-- Actually, Template Haskell works in 'chunks' of declarations, and
--- an earlier chunk won't be in the 'env' that the zonking phase
+-- an earlier chunk won't be in the 'env' that the zonking phase
-- carries around. Instead it'll be in the tcg_gbl_env, already fully
--- zonked. There's no point in looking it up there (except for error
+-- zonked. There's no point in looking it up there (except for error
-- checking), and it's not conveniently to hand; hence the simple
-- 'orElse' case in the LocalVar branch.
--
-- Even without template splices, in module Main, the checking of
-- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id
+zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id
| isLocalVar id = lookupVarEnv env id `orElse` id
- | otherwise = id
+ | otherwise = id
zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
zonkIdOccs env ids = map (zonkIdOcc env) ids
-- zonkIdBndr is used *after* typechecking to get the Id's type
--- to its final form. The TyVarEnv give
+-- to its final form. The TyVarEnv give
zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
zonkIdBndr env id
- = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
- returnM (Id.setIdType id ty')
+ = do ty' <- zonkTcTypeToType env (idType id)
+ return (Id.setIdType id ty')
zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
-zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
zonkTopBndrs :: [TcId] -> TcM [Id]
zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
-zonkEvBndrsX = mapAccumLM zonkEvBndrX
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
-- Works for dictionaries and coercions
@@ -277,9 +256,9 @@ zonkEvBndrX env var
zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
-zonkEvBndr env var
+zonkEvBndr env var
= do { let var_ty = varType var
- ; ty <-
+ ; ty <-
{-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
zonkTcTypeToType env var_ty
; return (setVarType var ty) }
@@ -288,7 +267,7 @@ zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
zonkEvVarOcc env v = zonkIdOcc env v
zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
-zonkTyBndrsX = mapAccumLM zonkTyBndrX
+zonkTyBndrsX = mapAccumLM zonkTyBndrX
zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar)
-- This guarantees to return a TyVar (not a TcTyVar)
@@ -307,10 +286,10 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e
zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
-zonkTopDecls :: Bag EvBind
+zonkTopDecls :: Bag EvBind
-> LHsBinds TcId -> NameSet
-> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
- -> TcM ([Id],
+ -> TcM ([Id],
Bag EvBind,
Bag (LHsBind Id),
[LForeignDecl Id],
@@ -320,8 +299,8 @@ zonkTopDecls :: Bag EvBind
zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords
= do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
- -- Warn about missing signatures
- -- Do this only when we we have a type to offer
+ -- Warn about missing signatures
+ -- Do this only when we we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSigs
; let sig_warn | warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn
@@ -343,43 +322,42 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
= panic "zonkLocalBinds" -- Not in typechecker output
zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs))
- = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
+ = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
; let sig_warn | not warn_missing_sigs = noSigWarn
| otherwise = localSigWarn sig_ns
sig_ns = getTypeSigNames vb
- ; (env1, new_binds) <- go env sig_warn binds
+ ; (env1, new_binds) <- go env sig_warn binds
; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
where
go env _ []
= return (env, [])
- go env sig_warn ((r,b):bs)
+ go env sig_warn ((r,b):bs)
= do { (env1, b') <- zonkRecMonoBinds env sig_warn b
- ; (env2, bs') <- go env1 sig_warn bs
- ; return (env2, (r,b'):bs') }
+ ; (env2, bs') <- go env1 sig_warn bs
+ ; return (env2, (r,b'):bs') }
-zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
- = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds ->
+zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
+ new_binds <- mapM (wrapLocM zonk_ip_bind) binds
let
- env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
- in
- zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) ->
- returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
+ env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds]
+ (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
+ return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
where
zonk_ip_bind (IPBind n e)
- = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
- zonkLExpr env e `thenM` \ e' ->
- returnM (IPBind n' e')
+ = do n' <- mapIPNameTc (zonkIdBndr env) n
+ e' <- zonkLExpr env e
+ return (IPBind n' e')
---------------------------------------------
zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
-zonkRecMonoBinds env sig_warn binds
- = fixM (\ ~(_, new_binds) -> do
- { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
+zonkRecMonoBinds env sig_warn binds
+ = fixM (\ ~(_, new_binds) -> do
+ { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds)
; binds' <- zonkMonoBinds env1 sig_warn binds
; return (env1, binds') })
---------------------------------------------
-type SigWarn = Bool -> [Id] -> TcM ()
+type SigWarn = Bool -> [Id] -> TcM ()
-- Missing-signature warning
-- The Bool is True for an AbsBinds, False otherwise
@@ -428,11 +406,11 @@ zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) b
zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
- = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
+ = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
; sig_warn False (collectPatBinders new_pat)
- ; new_grhss <- zonkGRHSs env zonkLExpr grhss
- ; new_ty <- zonkTcTypeToType env ty
- ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
+ ; new_grhss <- zonkGRHSs env zonkLExpr grhss
+ ; new_ty <- zonkTcTypeToType env ty
+ ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
= do { new_var <- zonkIdBndr env var
@@ -451,7 +429,7 @@ zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms
zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
- , abs_exports = exports
+ , abs_exports = exports
, abs_binds = val_binds })
= ASSERT( all isImmutableTyVar tyvars )
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
@@ -459,21 +437,22 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
- ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
- ; new_exports <- mapM (zonkExport env3) exports
- ; return (new_val_binds, new_exports) }
+ ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
+ ; new_exports <- mapM (zonkExport env3) exports
+ ; return (new_val_binds, new_exports) }
; sig_warn True (map abe_poly new_exports)
; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
- , abs_exports = new_exports, abs_binds = new_val_bind }) }
+ , abs_exports = new_exports, abs_binds = new_val_bind }) }
where
zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id
, abe_mono = mono_id, abe_prags = prags })
- = zonkIdBndr env poly_id `thenM` \ new_poly_id ->
- zonkCoFn env wrap `thenM` \ (_, new_wrap) ->
- zonkSpecPrags env prags `thenM` \ new_prags ->
- returnM (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
- , abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags })
+ = do new_poly_id <- zonkIdBndr env poly_id
+ (_, new_wrap) <- zonkCoFn env wrap
+ new_prags <- zonkSpecPrags env prags
+ return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id
+ , abe_mono = zonkIdOcc env mono_id
+ , abe_prags = new_prags })
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
@@ -485,55 +464,54 @@ zonkLTcSpecPrags env ps
= mapM zonk_prag ps
where
zonk_prag (L loc (SpecPrag id co_fn inl))
- = do { (_, co_fn') <- zonkCoFn env co_fn
- ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+ = do { (_, co_fn') <- zonkCoFn env co_fn
+ ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
-%* *
+%* *
%************************************************************************
\begin{code}
-zonkMatchGroup :: ZonkEnv
+zonkMatchGroup :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
-zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty })
- = do { ms' <- mapM (zonkMatch env zBody) ms
- ; arg_tys' <- zonkTcTypeToTypes env arg_tys
- ; res_ty' <- zonkTcTypeToType env res_ty
- ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) }
+zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty })
+ = do { ms' <- mapM (zonkMatch env zBody) ms
+ ; arg_tys' <- zonkTcTypeToTypes env arg_tys
+ ; res_ty' <- zonkTcTypeToType env res_ty
+ ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) }
-zonkMatch :: ZonkEnv
+zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
zonkMatch env zBody (L loc (Match pats _ grhss))
- = do { (env1, new_pats) <- zonkPats env pats
- ; new_grhss <- zonkGRHSs env1 zBody grhss
- ; return (L loc (Match new_pats Nothing new_grhss)) }
+ = do { (env1, new_pats) <- zonkPats env pats
+ ; new_grhss <- zonkGRHSs env1 zBody grhss
+ ; return (L loc (Match new_pats Nothing new_grhss)) }
-------------------------------------------------------------------------
-zonkGRHSs :: ZonkEnv
+zonkGRHSs :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
-zonkGRHSs env zBody (GRHSs grhss binds)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
+zonkGRHSs env zBody (GRHSs grhss binds) = do
+ (new_env, new_binds) <- zonkLocalBinds env binds
let
zonk_grhs (GRHS guarded rhs)
- = zonkStmts new_env zonkLExpr guarded `thenM` \ (env2, new_guarded) ->
- zBody env2 rhs `thenM` \ new_rhs ->
- returnM (GRHS new_guarded new_rhs)
- in
- mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss ->
- returnM (GRHSs new_grhss new_binds)
+ = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
+ new_rhs <- zBody env2 rhs
+ return (GRHS new_guarded new_rhs)
+ new_grhss <- mapM (wrapLocM zonk_grhs) grhss
+ return (GRHSs new_grhss new_binds)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -541,74 +519,74 @@ zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
-zonkLExprs env exprs = mappM (zonkLExpr env) exprs
+zonkLExprs env exprs = mapM (zonkLExpr env) exprs
zonkLExpr env expr = wrapLocM (zonkExpr env) expr
zonkExpr env (HsVar id)
- = returnM (HsVar (zonkIdOcc env id))
+ = return (HsVar (zonkIdOcc env id))
zonkExpr _ (HsIPVar id)
- = returnM (HsIPVar id)
+ = return (HsIPVar id)
zonkExpr env (HsLit (HsRat f ty))
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsLit (HsRat f new_ty))
+ = do new_ty <- zonkTcTypeToType env ty
+ return (HsLit (HsRat f new_ty))
zonkExpr _ (HsLit lit)
- = returnM (HsLit lit)
+ = return (HsLit lit)
zonkExpr env (HsOverLit lit)
- = do { lit' <- zonkOverLit env lit
- ; return (HsOverLit lit') }
+ = do { lit' <- zonkOverLit env lit
+ ; return (HsOverLit lit') }
zonkExpr env (HsLam matches)
- = zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches ->
- returnM (HsLam new_matches)
+ = do new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLam new_matches)
zonkExpr env (HsLamCase arg matches)
- = zonkTcTypeToType env arg `thenM` \ new_arg ->
- zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches ->
- returnM (HsLamCase new_arg new_matches)
+ = do new_arg <- zonkTcTypeToType env arg
+ new_matches <- zonkMatchGroup env zonkLExpr matches
+ return (HsLamCase new_arg new_matches)
zonkExpr env (HsApp e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (HsApp new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (HsApp new_e1 new_e2)
-zonkExpr env (HsBracketOut body bs)
- = mappM zonk_b bs `thenM` \ bs' ->
- returnM (HsBracketOut body bs')
+zonkExpr env (HsBracketOut body bs)
+ = do bs' <- mapM zonk_b bs
+ return (HsBracketOut body bs')
where
- zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
- returnM (n,e')
+ zonk_b (n,e) = do e' <- zonkLExpr env e
+ return (n,e')
zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
- returnM (HsSpliceE s)
+ return (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env op `thenM` \ new_op ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (OpApp new_e1 new_op fixity new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_op <- zonkLExpr env op
+ new_e2 <- zonkLExpr env e2
+ return (OpApp new_e1 new_op fixity new_e2)
zonkExpr env (NegApp expr op)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkExpr env op `thenM` \ new_op ->
- returnM (NegApp new_expr new_op)
+ = do new_expr <- zonkLExpr env expr
+ new_op <- zonkExpr env op
+ return (NegApp new_expr new_op)
-zonkExpr env (HsPar e)
- = zonkLExpr env e `thenM` \new_e ->
- returnM (HsPar new_e)
+zonkExpr env (HsPar e)
+ = do new_e <- zonkLExpr env e
+ return (HsPar new_e)
zonkExpr env (SectionL expr op)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkLExpr env op `thenM` \ new_op ->
- returnM (SectionL new_expr new_op)
+ = do new_expr <- zonkLExpr env expr
+ new_op <- zonkLExpr env op
+ return (SectionL new_expr new_op)
zonkExpr env (SectionR op expr)
- = zonkLExpr env op `thenM` \ new_op ->
- zonkLExpr env expr `thenM` \ new_expr ->
- returnM (SectionR new_op new_expr)
+ = do new_op <- zonkLExpr env op
+ new_expr <- zonkLExpr env expr
+ return (SectionR new_op new_expr)
zonkExpr env (ExplicitTuple tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
@@ -618,105 +596,105 @@ zonkExpr env (ExplicitTuple tup_args boxed)
zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') }
zonkExpr env (HsCase expr ms)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkMatchGroup env zonkLExpr ms `thenM` \ new_ms ->
- returnM (HsCase new_expr new_ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLExpr ms
+ return (HsCase new_expr new_ms)
zonkExpr env (HsIf e0 e1 e2 e3)
= do { new_e0 <- fmapMaybeM (zonkExpr env) e0
; new_e1 <- zonkLExpr env e1
; new_e2 <- zonkLExpr env e2
; new_e3 <- zonkLExpr env e3
- ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
+ ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
zonkExpr env (HsMultiIf ty alts)
= do { alts' <- mapM (wrapLocM zonk_alt) alts
; ty' <- zonkTcTypeToType env ty
- ; returnM $ HsMultiIf ty' alts' }
+ ; return $ HsMultiIf ty' alts' }
where zonk_alt (GRHS guard expr)
= do { (env', guard') <- zonkStmts env zonkLExpr guard
; expr' <- zonkLExpr env' expr
- ; returnM $ GRHS guard' expr' }
+ ; return $ GRHS guard' expr' }
zonkExpr env (HsLet binds expr)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkLExpr new_env expr `thenM` \ new_expr ->
- returnM (HsLet new_binds new_expr)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_expr <- zonkLExpr new_env expr
+ return (HsLet new_binds new_expr)
zonkExpr env (HsDo do_or_lc stmts ty)
- = zonkStmts env zonkLExpr stmts `thenM` \ (_, new_stmts) ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts new_ty)
+ = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
+ new_ty <- zonkTcTypeToType env ty
+ return (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty wit exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkWit env wit `thenM` \ new_wit ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitList new_ty new_wit new_exprs)
- where zonkWit _ Nothing = returnM Nothing
- zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
- returnM (Just new_fln)
+ = do new_ty <- zonkTcTypeToType env ty
+ new_wit <- zonkWit env wit
+ new_exprs <- zonkLExprs env exprs
+ return (ExplicitList new_ty new_wit new_exprs)
+ where zonkWit _ Nothing = return Nothing
+ zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
+ return (Just new_fln)
zonkExpr env (ExplicitPArr ty exprs)
- = zonkTcTypeToType env ty `thenM` \ new_ty ->
- zonkLExprs env exprs `thenM` \ new_exprs ->
- returnM (ExplicitPArr new_ty new_exprs)
+ = do new_ty <- zonkTcTypeToType env ty
+ new_exprs <- zonkLExprs env exprs
+ return (ExplicitPArr new_ty new_exprs)
zonkExpr env (RecordCon data_con con_expr rbinds)
- = do { new_con_expr <- zonkExpr env con_expr
- ; new_rbinds <- zonkRecFields env rbinds
- ; return (RecordCon data_con new_con_expr new_rbinds) }
+ = do { new_con_expr <- zonkExpr env con_expr
+ ; new_rbinds <- zonkRecFields env rbinds
+ ; return (RecordCon data_con new_con_expr new_rbinds) }
zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys)
- = do { new_expr <- zonkLExpr env expr
- ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
- ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
- ; new_rbinds <- zonkRecFields env rbinds
- ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
+ = do { new_expr <- zonkLExpr env expr
+ ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
+ ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
+ ; new_rbinds <- zonkRecFields env rbinds
+ ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) }
-zonkExpr env (ExprWithTySigOut e ty)
+zonkExpr env (ExprWithTySigOut e ty)
= do { e' <- zonkLExpr env e
; return (ExprWithTySigOut e' ty) }
zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
zonkExpr env (ArithSeq expr wit info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkWit env wit `thenM` \ new_wit ->
- zonkArithSeq env info `thenM` \ new_info ->
- returnM (ArithSeq new_expr new_wit new_info)
- where zonkWit _ Nothing = returnM Nothing
- zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
- returnM (Just new_fln)
+ = do new_expr <- zonkExpr env expr
+ new_wit <- zonkWit env wit
+ new_info <- zonkArithSeq env info
+ return (ArithSeq new_expr new_wit new_info)
+ where zonkWit _ Nothing = return Nothing
+ zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
+ return (Just new_fln)
zonkExpr env (PArrSeq expr info)
- = zonkExpr env expr `thenM` \ new_expr ->
- zonkArithSeq env info `thenM` \ new_info ->
- returnM (PArrSeq new_expr new_info)
+ = do new_expr <- zonkExpr env expr
+ new_info <- zonkArithSeq env info
+ return (PArrSeq new_expr new_info)
zonkExpr env (HsSCC lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (HsSCC lbl new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsSCC lbl new_expr)
zonkExpr env (HsTickPragma info expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (HsTickPragma info new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsTickPragma info new_expr)
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
- = zonkLExpr env expr `thenM` \ new_expr ->
- returnM (HsCoreAnn lbl new_expr)
+ = do new_expr <- zonkLExpr env expr
+ return (HsCoreAnn lbl new_expr)
-- arrow notation extensions
zonkExpr env (HsProc pat body)
- = do { (env1, new_pat) <- zonkPat env pat
- ; new_body <- zonkCmdTop env1 body
- ; return (HsProc new_pat new_body) }
+ = do { (env1, new_pat) <- zonkPat env pat
+ ; new_body <- zonkCmdTop env1 body
+ ; return (HsProc new_pat new_body) }
zonkExpr env (HsWrap co_fn expr)
- = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) ->
- zonkExpr env1 expr `thenM` \ new_expr ->
- return (HsWrap new_co_fn new_expr)
+ = do (env1, new_co_fn) <- zonkCoFn env co_fn
+ new_expr <- zonkExpr env1 expr
+ return (HsWrap new_co_fn new_expr)
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
@@ -732,53 +710,53 @@ zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
zonkCmd env (HsCmdCast co cmd)
= do { co' <- zonkTcLCoToLCo env co
- ; cmd' <- zonkCmd env cmd
+ ; cmd' <- zonkCmd env cmd
; return (HsCmdCast co' cmd') }
zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_ty <- zonkTcTypeToType env ty
+ return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
zonkCmd env (HsCmdArrForm op fixity args)
- = zonkLExpr env op `thenM` \ new_op ->
- mappM (zonkCmdTop env) args `thenM` \ new_args ->
- returnM (HsCmdArrForm new_op fixity new_args)
+ = do new_op <- zonkLExpr env op
+ new_args <- mapM (zonkCmdTop env) args
+ return (HsCmdArrForm new_op fixity new_args)
zonkCmd env (HsCmdApp c e)
- = zonkLCmd env c `thenM` \ new_c ->
- zonkLExpr env e `thenM` \ new_e ->
- returnM (HsCmdApp new_c new_e)
+ = do new_c <- zonkLCmd env c
+ new_e <- zonkLExpr env e
+ return (HsCmdApp new_c new_e)
zonkCmd env (HsCmdLam matches)
- = zonkMatchGroup env zonkLCmd matches `thenM` \ new_matches ->
- returnM (HsCmdLam new_matches)
+ = do new_matches <- zonkMatchGroup env zonkLCmd matches
+ return (HsCmdLam new_matches)
-zonkCmd env (HsCmdPar c)
- = zonkLCmd env c `thenM` \new_c ->
- returnM (HsCmdPar new_c)
+zonkCmd env (HsCmdPar c)
+ = do new_c <- zonkLCmd env c
+ return (HsCmdPar new_c)
zonkCmd env (HsCmdCase expr ms)
- = zonkLExpr env expr `thenM` \ new_expr ->
- zonkMatchGroup env zonkLCmd ms `thenM` \ new_ms ->
- returnM (HsCmdCase new_expr new_ms)
+ = do new_expr <- zonkLExpr env expr
+ new_ms <- zonkMatchGroup env zonkLCmd ms
+ return (HsCmdCase new_expr new_ms)
zonkCmd env (HsCmdIf eCond ePred cThen cElse)
= do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
; new_ePred <- zonkLExpr env ePred
; new_cThen <- zonkLCmd env cThen
; new_cElse <- zonkLCmd env cElse
- ; returnM (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
+ ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
zonkCmd env (HsCmdLet binds cmd)
- = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) ->
- zonkLCmd new_env cmd `thenM` \ new_cmd ->
- returnM (HsCmdLet new_binds new_cmd)
+ = do (new_env, new_binds) <- zonkLocalBinds env binds
+ new_cmd <- zonkLCmd new_env cmd
+ return (HsCmdLet new_binds new_cmd)
zonkCmd env (HsCmdDo stmts ty)
- = zonkStmts env zonkLCmd stmts `thenM` \ (_, new_stmts) ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsCmdDo new_stmts new_ty)
+ = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
+ new_ty <- zonkTcTypeToType env ty
+ return (HsCmdDo new_stmts new_ty)
@@ -789,65 +767,65 @@ zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
- = zonkLCmd env cmd `thenM` \ new_cmd ->
- zonkTcTypeToType env stack_tys `thenM` \ new_stack_tys ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- mapSndM (zonkExpr env) ids `thenM` \ new_ids ->
- returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
+ = do new_cmd <- zonkLCmd env cmd
+ new_stack_tys <- zonkTcTypeToType env stack_tys
+ new_ty <- zonkTcTypeToType env ty
+ new_ids <- mapSndM (zonkExpr env) ids
+ return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
zonkCoFn env WpHole = return (env, WpHole)
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
- ; (env2, c2') <- zonkCoFn env1 c2
- ; return (env2, WpCompose c1' c2') }
+ ; (env2, c2') <- zonkCoFn env1 c2
+ ; return (env2, WpCompose c1' c2') }
zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co
- ; return (env, WpCast co') }
+ ; return (env, WpCast co') }
zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
- ; return (env', WpEvLam ev') }
-zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
+ ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
; return (env, WpEvApp arg') }
zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
do { (env', tv') <- zonkTyBndrX env tv
- ; return (env', WpTyLam tv') }
+ ; return (env', WpTyLam tv') }
zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
- ; return (env, WpTyApp ty') }
+ ; return (env, WpTyApp ty') }
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
- ; return (env1, WpLet bs') }
+ ; return (env1, WpLet bs') }
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
- = do { ty' <- zonkTcTypeToType env ty
- ; e' <- zonkExpr env e
- ; return (lit { ol_witness = e', ol_type = ty' }) }
+ = do { ty' <- zonkTcTypeToType env ty
+ ; e' <- zonkExpr env e
+ ; return (lit { ol_witness = e', ol_type = ty' }) }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
zonkArithSeq env (From e)
- = zonkLExpr env e `thenM` \ new_e ->
- returnM (From new_e)
+ = do new_e <- zonkLExpr env e
+ return (From new_e)
zonkArithSeq env (FromThen e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (FromThen new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromThen new_e1 new_e2)
zonkArithSeq env (FromTo e1 e2)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- returnM (FromTo new_e1 new_e2)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ return (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
- = zonkLExpr env e1 `thenM` \ new_e1 ->
- zonkLExpr env e2 `thenM` \ new_e2 ->
- zonkLExpr env e3 `thenM` \ new_e3 ->
- returnM (FromThenTo new_e1 new_e2 new_e3)
+ = do new_e1 <- zonkLExpr env e1
+ new_e2 <- zonkLExpr env e2
+ new_e3 <- zonkLExpr env e3
+ return (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
-zonkStmts :: ZonkEnv
+zonkStmts :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
zonkStmts env _ [] = return (env, [])
@@ -855,21 +833,21 @@ zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody
; (env2, ss') <- zonkStmts env1 zBody ss
; return (env2, s' : ss') }
-zonkStmt :: ZonkEnv
+zonkStmt :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op)
= do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
- env1 = extendIdZonkEnv env new_binders
+ env1 = extendIdZonkEnv env new_binders
; new_mzip <- zonkExpr env1 mzip_op
; new_bind <- zonkExpr env1 bind_op
; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
where
- zonk_branch (ParStmtBlock stmts bndrs return_op)
+ zonk_branch (ParStmtBlock stmts bndrs return_op)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_return <- zonkExpr env1 return_op
- ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
+ ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
@@ -883,8 +861,8 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_
; new_bind_id <- zonkExpr env bind_id
; let env1 = extendIdZonkEnv env new_rvs
; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts
- -- Zonk the ret-expressions in an envt that
- -- has the polymorphic bindings in the envt
+ -- Zonk the ret-expressions in an envt that
+ -- has the polymorphic bindings in the envt
; new_later_rets <- mapM (zonkExpr env2) later_rets
; new_rec_rets <- mapM (zonkExpr env2) rec_rets
; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed
@@ -895,22 +873,22 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_
, recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
zonkStmt env zBody (BodyStmt body then_op guard_op ty)
- = zBody env body `thenM` \ new_body ->
- zonkExpr env then_op `thenM` \ new_then ->
- zonkExpr env guard_op `thenM` \ new_guard ->
- zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, BodyStmt new_body new_then new_guard new_ty)
+ = do new_body <- zBody env body
+ new_then <- zonkExpr env then_op
+ new_guard <- zonkExpr env guard_op
+ new_ty <- zonkTcTypeToType env ty
+ return (env, BodyStmt new_body new_then new_guard new_ty)
zonkStmt env zBody (LastStmt body ret_op)
- = zBody env body `thenM` \ new_body ->
- zonkExpr env ret_op `thenM` \ new_ret ->
- returnM (env, LastStmt new_body new_ret)
+ = do new_body <- zBody env body
+ new_ret <- zonkExpr env ret_op
+ return (env, LastStmt new_body new_ret)
zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_form = form, trS_using = using
, trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
- = do { (env', stmts') <- zonkStmts env zonkLExpr stmts
- ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
+ = do { (env', stmts') <- zonkStmts env zonkLExpr stmts
+ ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap
; by' <- fmapMaybeM (zonkLExpr env') by
; using' <- zonkLExpr env using
; return_op' <- zonkExpr env' return_op
@@ -921,44 +899,45 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by', trS_form = form, trS_using = using'
, trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
where
- zonkBinderMapEntry env (oldBinder, newBinder) = do
+ zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
newBinder' <- zonkIdBndr env newBinder
- return (oldBinder', newBinder')
+ return (oldBinder', newBinder')
zonkStmt env _ (LetStmt binds)
- = zonkLocalBinds env binds `thenM` \ (env1, new_binds) ->
- returnM (env1, LetStmt new_binds)
+ = do (env1, new_binds) <- zonkLocalBinds env binds
+ return (env1, LetStmt new_binds)
zonkStmt env zBody (BindStmt pat body bind_op fail_op)
- = do { new_body <- zBody env body
- ; (env1, new_pat) <- zonkPat env pat
- ; new_bind <- zonkExpr env bind_op
- ; new_fail <- zonkExpr env fail_op
- ; return (env1, BindStmt new_pat new_body new_bind new_fail) }
+ = do { new_body <- zBody env body
+ ; (env1, new_pat) <- zonkPat env pat
+ ; new_bind <- zonkExpr env bind_op
+ ; new_fail <- zonkExpr env fail_op
+ ; return (env1, BindStmt new_pat new_body new_bind new_fail) }
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
- = do { flds' <- mappM zonk_rbind flds
- ; return (HsRecFields flds' dd) }
+ = do { flds' <- mapM zonk_rbind flds
+ ; return (HsRecFields flds' dd) }
where
zonk_rbind fld
= do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
- ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
- ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
+ ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
-mapIPNameTc _ (Left x) = returnM (Left x)
-mapIPNameTc f (Right x) = f x `thenM` \ r -> returnM (Right r)
+mapIPNameTc _ (Left x) = return (Left x)
+mapIPNameTc f (Right x) = do r <- f x
+ return (Right r)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[BackSubst-Pats]{Patterns}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -970,97 +949,97 @@ zonkPat env pat = wrapLocSndM (zonk_pat env) pat
zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
zonk_pat env (ParPat p)
- = do { (env', p') <- zonkPat env p
- ; return (env', ParPat p') }
+ = do { (env', p') <- zonkPat env p
+ ; return (env', ParPat p') }
zonk_pat env (WildPat ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; return (env, WildPat ty') }
+ = do { ty' <- zonkTcTypeToType env ty
+ ; return (env, WildPat ty') }
zonk_pat env (VarPat v)
- = do { v' <- zonkIdBndr env v
- ; return (extendIdZonkEnv1 env v', VarPat v') }
+ = do { v' <- zonkIdBndr env v
+ ; return (extendIdZonkEnv1 env v', VarPat v') }
zonk_pat env (LazyPat pat)
- = do { (env', pat') <- zonkPat env pat
- ; return (env', LazyPat pat') }
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', LazyPat pat') }
zonk_pat env (BangPat pat)
- = do { (env', pat') <- zonkPat env pat
- ; return (env', BangPat pat') }
+ = do { (env', pat') <- zonkPat env pat
+ ; return (env', BangPat pat') }
zonk_pat env (AsPat (L loc v) pat)
- = do { v' <- zonkIdBndr env v
- ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
- ; return (env', AsPat (L loc v') pat') }
+ = do { v' <- zonkIdBndr env v
+ ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
+ ; return (env', AsPat (L loc v') pat') }
zonk_pat env (ViewPat expr pat ty)
- = do { expr' <- zonkLExpr env expr
- ; (env', pat') <- zonkPat env pat
- ; ty' <- zonkTcTypeToType env ty
- ; return (env', ViewPat expr' pat' ty') }
+ = do { expr' <- zonkLExpr env expr
+ ; (env', pat') <- zonkPat env pat
+ ; ty' <- zonkTcTypeToType env ty
+ ; return (env', ViewPat expr' pat' ty') }
zonk_pat env (ListPat pats ty Nothing)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', ListPat pats' ty' Nothing) }
-
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', ListPat pats' ty' Nothing) }
+
zonk_pat env (ListPat pats ty (Just (ty2,wit)))
- = do { wit' <- zonkExpr env wit
+ = do { wit' <- zonkExpr env wit
; ty2' <- zonkTcTypeToType env ty2
; ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', ListPat pats' ty' (Just (ty2',wit'))) }
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', ListPat pats' ty' (Just (ty2',wit'))) }
zonk_pat env (PArrPat pats ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', PArrPat pats' ty') }
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', PArrPat pats' ty') }
zonk_pat env (TuplePat pats boxed ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pats') <- zonkPats env pats
- ; return (env', TuplePat pats' boxed ty') }
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pats') <- zonkPats env pats
+ ; return (env', TuplePat pats' boxed ty') }
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars
, pat_dicts = evs, pat_binds = binds
, pat_args = args })
- = ASSERT( all isImmutableTyVar tyvars )
- do { new_ty <- zonkTcTypeToType env ty
+ = ASSERT( all isImmutableTyVar tyvars )
+ do { new_ty <- zonkTcTypeToType env ty
; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
-- Must zonk the existential variables, because their
-- /kind/ need potential zonking.
-- cf typecheck/should_compile/tc221.hs
- ; (env1, new_evs) <- zonkEvBndrsX env0 evs
- ; (env2, new_binds) <- zonkTcEvBinds env1 binds
- ; (env', new_args) <- zonkConStuff env2 args
- ; returnM (env', p { pat_ty = new_ty,
- pat_tvs = new_tyvars,
- pat_dicts = new_evs,
- pat_binds = new_binds,
- pat_args = new_args }) }
+ ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+ ; (env2, new_binds) <- zonkTcEvBinds env1 binds
+ ; (env', new_args) <- zonkConStuff env2 args
+ ; return (env', p { pat_ty = new_ty,
+ pat_tvs = new_tyvars,
+ pat_dicts = new_evs,
+ pat_binds = new_binds,
+ pat_args = new_args }) }
zonk_pat env (LitPat lit) = return (env, LitPat lit)
zonk_pat env (SigPatOut pat ty)
- = do { ty' <- zonkTcTypeToType env ty
- ; (env', pat') <- zonkPat env pat
- ; return (env', SigPatOut pat' ty') }
+ = do { ty' <- zonkTcTypeToType env ty
+ ; (env', pat') <- zonkPat env pat
+ ; return (env', SigPatOut pat' ty') }
zonk_pat env (NPat lit mb_neg eq_expr)
- = do { lit' <- zonkOverLit env lit
- ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
- ; eq_expr' <- zonkExpr env eq_expr
- ; return (env, NPat lit' mb_neg' eq_expr') }
+ = do { lit' <- zonkOverLit env lit
+ ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
+ ; eq_expr' <- zonkExpr env eq_expr
+ ; return (env, NPat lit' mb_neg' eq_expr') }
zonk_pat env (NPlusKPat (L loc n) lit e1 e2)
- = do { n' <- zonkIdBndr env n
- ; lit' <- zonkOverLit env lit
- ; e1' <- zonkExpr env e1
- ; e2' <- zonkExpr env e2
- ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
+ = do { n' <- zonkIdBndr env n
+ ; lit' <- zonkOverLit env lit
+ ; e1' <- zonkExpr env e1
+ ; e2' <- zonkExpr env e2
+ ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') }
-zonk_pat env (CoPat co_fn pat ty)
+zonk_pat env (CoPat co_fn pat ty)
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToType env'' ty
@@ -1074,49 +1053,49 @@ zonkConStuff :: ZonkEnv
-> TcM (ZonkEnv,
HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
zonkConStuff env (PrefixCon pats)
- = do { (env', pats') <- zonkPats env pats
- ; return (env', PrefixCon pats') }
+ = do { (env', pats') <- zonkPats env pats
+ ; return (env', PrefixCon pats') }
zonkConStuff env (InfixCon p1 p2)
- = do { (env1, p1') <- zonkPat env p1
- ; (env', p2') <- zonkPat env1 p2
- ; return (env', InfixCon p1' p2') }
+ = do { (env1, p1') <- zonkPat env p1
+ ; (env', p2') <- zonkPat env1 p2
+ ; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon (HsRecFields rpats dd))
- = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
- ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
- ; returnM (env', RecCon (HsRecFields rpats' dd)) }
- -- Field selectors have declared types; hence no zonking
+ = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats)
+ ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats'
+ ; return (env', RecCon (HsRecFields rpats' dd)) }
+ -- Field selectors have declared types; hence no zonking
---------------------------
zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
-zonkPats env [] = return (env, [])
+zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
- ; (env', pats') <- zonkPats env1 pats
- ; return (env', pat':pats') }
+ ; (env', pats') <- zonkPats env1 pats
+ ; return (env', pat':pats') }
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[BackSubst-Foreign]{Foreign exports}
-%* *
+%* *
%************************************************************************
\begin{code}
zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
-zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls
+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
zonkForeignExport env (ForeignExport i _hs_ty co spec) =
- returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
-zonkForeignExport _ for_imp
- = returnM for_imp -- Foreign imports don't need zonking
+ return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
+zonkForeignExport _ for_imp
+ = return for_imp -- Foreign imports don't need zonking
\end{code}
\begin{code}
zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
-zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
@@ -1136,10 +1115,10 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
(varSetElemsKvsFirst unbound_tkvs)
++ new_bndrs
- ; return $
+ ; return $
HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
where
- zonk_bndr env (RuleBndr (L loc v))
+ zonk_bndr env (RuleBndr (L loc v))
= do { (env', v') <- zonk_it env v
; return (env', RuleBndr (L loc v')) }
zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
@@ -1149,14 +1128,14 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
; return (extendIdZonkEnv1 env v', v') }
| otherwise = ASSERT( isImmutableTyVar v)
zonkTyBndrX env v
- -- DV: used to be return (env,v) but that is plain
- -- wrong because we may need to go inside the kind
+ -- DV: used to be return (env,v) but that is plain
+ -- wrong because we may need to go inside the kind
-- of v and zonk there!
\end{code}
\begin{code}
zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
-zonkVects env = mappM (wrapLocM (zonkVect env))
+zonkVects env = mapM (wrapLocM (zonkVect env))
zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
zonkVect env (HsVect v e)
@@ -1180,14 +1159,14 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
\end{code}
%************************************************************************
-%* *
+%* *
Constraints and evidence
-%* *
+%* *
%************************************************************************
\begin{code}
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
-zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
+zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
return (EvId (zonkIdOcc env v))
zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co
; return (EvCoercion co') }
@@ -1211,9 +1190,9 @@ zonkEvTerm env (EvDelayedError ty msg)
zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
- ; return (env', EvBinds bs') }
+ ; return (env', EvBinds bs') }
zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs
- ; return (env', EvBinds bs') }
+ ; return (env', EvBinds bs') }
zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
@@ -1223,12 +1202,12 @@ zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
zonkEvBinds env binds
= {-# SCC "zonkEvBinds" #-}
fixM (\ ~( _, new_binds) -> do
- { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
+ { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
; binds' <- mapBagM (zonkEvBind env1) binds
; return (env1, binds') })
where
collect_ev_bndrs :: Bag EvBind -> [EvVar]
- collect_ev_bndrs = foldrBag add []
+ collect_ev_bndrs = foldrBag add []
add (EvBind var _) vars = var : vars
zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
@@ -1240,21 +1219,21 @@ zonkEvBind env (EvBind var term)
-- This has a very big effect on some programs (eg Trac #5030)
; let ty' = idType var'
; case getEqPredTys_maybe ty' of
- Just (ty1, ty2) | ty1 `eqType` ty2
+ Just (ty1, ty2) | ty1 `eqType` ty2
-> return (EvBind var' (EvCoercion (mkTcReflCo ty1)))
- _other -> do { term' <- zonkEvTerm env term
+ _other -> do { term' <- zonkEvTerm env term
; return (EvBind var' term') } }
\end{code}
%************************************************************************
-%* *
+%* *
Zonking types
-%* *
+%* *
%************************************************************************
Note [Zonking the LHS of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to gather the type variables mentioned on the LHS so we can
+We need to gather the type variables mentioned on the LHS so we can
quantify over them. Example:
data T a = C
@@ -1266,7 +1245,7 @@ quantify over them. Example:
After type checking the LHS becomes (foo a (C a))
and we do not want to zap the unbound tyvar 'a' to (), because
that limits the applicability of the rule. Instead, we
-want to quantify over it!
+want to quantify over it!
It's easiest to get zonkTvCollecting to gather the free tyvars
here. Attempts to do so earlier are tiresome, because (a) the data
@@ -1300,11 +1279,11 @@ not the ill-kinded Any BOX).
Note [Optimise coercion zonkind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When optimising evidence binds we may come across situations where
+When optimising evidence binds we may come across situations where
a coercion looks like
cv = ReflCo ty
or cv1 = cv2
-where the type 'ty' is big. In such cases it is a waste of time to zonk both
+where the type 'ty' is big. In such cases it is a waste of time to zonk both
* The variable on the LHS
* The coercion on the RHS
Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
@@ -1321,13 +1300,13 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
SkolemTv {} -> lookup_in_env
RuntimeUnk {} -> lookup_in_env
FlatSkol ty -> zonkTcTypeToType env ty
- MetaTv { mtv_ref = ref }
+ MetaTv { mtv_ref = ref }
-> do { cts <- readMutVar ref
- ; case cts of
- Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
+ ; case cts of
+ Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
zonkTcTypeToType env (tyVarKind tv)
; zonk_unbound_tyvar (setTyVarKind tv kind) }
- Indirect ty -> do { zty <- zonkTcTypeToType env ty
+ Indirect ty -> do { zty <- zonkTcTypeToType env ty
-- Small optimisation: shortern-out indirect steps
-- so that the old type may be more easily collected.
; writeMutVar ref (Indirect zty)
@@ -1356,11 +1335,11 @@ zonkTcTypeToType env ty
go (AppTy fun arg) = do fun' <- go fun
arg' <- go arg
return (mkAppTy fun' arg')
- -- NB the mkAppTy; we might have instantiated a
- -- type variable to a type constructor, so we need
- -- to pull the TyConApp to the top.
+ -- NB the mkAppTy; we might have instantiated a
+ -- type variable to a type constructor, so we need
+ -- to pull the TyConApp to the top.
- -- The two interesting cases!
+ -- The two interesting cases!
go (TyVarTy tv) = zonkTyVarOcc env tv
go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index f6bb4b7cad..e03368de5c 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -135,7 +135,6 @@ import TcRnTypes
import Unique
import UniqFM
import Maybes ( orElse, catMaybes, firstJust )
-import StaticFlags( opt_NoFlatCache )
import Control.Monad( unless, when, zipWithM )
import Data.IORef
@@ -1382,8 +1381,9 @@ newFlattenSkolem Given fam_ty
; let rhs_ty = mkTyVarTy tv
ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty
, ctev_evtm = EvCoercion (mkTcReflCo fam_ty) }
+ ; dflags <- getDynFlags
; updInertTcS $ \ is@(IS { inert_fsks = fsks }) ->
- extendFlatCache fam_ty ctev rhs_ty
+ extendFlatCache dflags fam_ty ctev rhs_ty
is { inert_fsks = tv : fsks }
; return (ctev, rhs_ty) }
@@ -1393,12 +1393,14 @@ newFlattenSkolem _ fam_ty -- Wanted or Derived: make new unification variable
; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty)
-- NC (no-cache) version because we've already
-- looked in the solved goals an inerts (lookupFlatEqn)
- ; updInertTcS $ extendFlatCache fam_ty ctev rhs_ty
+ ; dflags <- getDynFlags
+ ; updInertTcS $ extendFlatCache dflags fam_ty ctev rhs_ty
; return (ctev, rhs_ty) }
-extendFlatCache :: TcType -> CtEvidence -> TcType -> InertSet -> InertSet
-extendFlatCache
- | opt_NoFlatCache
+extendFlatCache :: DynFlags -> TcType -> CtEvidence -> TcType
+ -> InertSet -> InertSet
+extendFlatCache dflags
+ | not (gopt Opt_FlatCache dflags)
= \ _ _ _ is -> is
| otherwise
= \ fam_ty ctev rhs_ty is@(IS { inert_flat_cache = fc }) ->
diff --git a/ghc.mk b/ghc.mk
index d519c2044f..eaee8720f4 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -167,7 +167,7 @@ include rules/clean-target.mk
# -----------------------------------------------------------------------------
# The inplace tree
-$(eval $(call clean-target,inplace,,inplace/bin inplace/lib))
+$(eval $(call clean-target,root,inplace,inplace/bin inplace/lib))
# -----------------------------------------------------------------------------
# Whether to build dependencies or not
@@ -698,7 +698,7 @@ $(shell echo "[]" >$(BOOTSTRAPPING_CONF))
endif
endif
-$(eval $(call clean-target,$(BOOTSTRAPPING_CONF),,$(BOOTSTRAPPING_CONF)))
+$(eval $(call clean-target,root,bootstrapping_conf,$(BOOTSTRAPPING_CONF)))
# register the boot packages in strict sequence, because running
# multiple ghc-pkgs in parallel doesn't work (registrations may get
diff --git a/includes/ghc.mk b/includes/ghc.mk
index dd5d62fb70..fb3800165a 100644
--- a/includes/ghc.mk
+++ b/includes/ghc.mk
@@ -180,7 +180,7 @@ endif
$(eval $(call clean-target,includes,,\
$(includes_H_CONFIG) $(includes_H_PLATFORM)))
-$(eval $(call all-target,includes,,\
+$(eval $(call all-target,includes,\
$(includes_H_CONFIG) $(includes_H_PLATFORM) \
$(includes_GHCCONSTANTS_HASKELL_TYPE) \
$(includes_GHCCONSTANTS_HASKELL_VALUE) \
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index ec19b169b6..720b732323 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -522,7 +522,16 @@ rts_checkSchedStatus (char* site, Capability *cap)
stg_exit(EXIT_FAILURE);
case Interrupted:
errorBelch("%s: interrupted", site);
- stg_exit(EXIT_FAILURE);
+#ifdef THREADED_RTS
+ // The RTS is shutting down, and the process will probably
+ // soon exit. We don't want to preempt the shutdown
+ // by exiting the whole process here, so we just terminate the
+ // current thread. Don't forget to release the cap first though.
+ rts_unlock(cap);
+ shutdownThread();
+#else
+ stg_exit(EXIT_FAILURE);
+#endif
default:
errorBelch("%s: Return code (%d) not ok",(site),(rc));
stg_exit(EXIT_FAILURE);
diff --git a/rts/ghc.mk b/rts/ghc.mk
index 5164ca4958..30f6c0810c 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -24,7 +24,7 @@ rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays))
rts_dist_WAYS = $(rts_WAYS)
ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf))
-all_rts : $(ALL_RTS_LIBS)
+$(eval $(call all-target,rts,$(ALL_RTS_LIBS)))
# -----------------------------------------------------------------------------
# Defining the sources
@@ -484,9 +484,12 @@ endif
rts_WAYS_DASHED = $(subst $(space),,$(patsubst %,-%,$(strip $(rts_WAYS))))
rts_dist_depfile_base = rts/dist/build/.depend$(rts_WAYS_DASHED)
-rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS)
-rts_dist_S_SRCS = $(rts_S_SRCS)
-rts_dist_C_FILES = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) $(rts_S_SRCS)
+rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS)
+rts_dist_S_SRCS = $(rts_S_SRCS)
+rts_dist_CMM_SRCS = $(rts_CMM_SRCS)
+rts_dist_C_FILES = $(rts_dist_C_SRCS)
+rts_dist_S_FILES = $(rts_dist_S_SRCS)
+rts_dist_CMM_FILES = $(rts_dist_CMM_SRCS)
# Hack: we define every way-related option here, so that we get (hopefully)
# a superset of the dependencies. To do this properly, we should generate
diff --git a/rules/build-dependencies.mk b/rules/build-dependencies.mk
index 9de49aa513..02640bf1ab 100644
--- a/rules/build-dependencies.mk
+++ b/rules/build-dependencies.mk
@@ -65,14 +65,14 @@ endif
# includes files.
$$($1_$2_depfile_c_asm) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM)
-$$($1_$2_depfile_c_asm) : $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) | $$$$(dir $$$$@)/.
+$$($1_$2_depfile_c_asm) : $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) $$($1_$2_CMM_FILES) | $$$$(dir $$$$@)/.
$$(call removeFiles,$$@.tmp)
-ifneq "$$(strip $$($1_$2_C_FILES_DEPS)$$($1_$2_S_FILES))" ""
+ifneq "$$(strip $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES)) $$($1_$2_CMM_FILES))" ""
# We ought to actually do this for each way in $$($1_$2_WAYS), but then
# it takes a long time to make the C deps for the RTS (30 seconds rather
# than 3), so instead we just pass the list of ways in and let addCFileDeps
# copy the deps for each way on the assumption that they are the same
- $$(foreach f,$$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES), \
+ $$(foreach f,$$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) $$($1_$2_CMM_FILES), \
$$(call addCFileDeps,$1,$2,$$($1_$2_depfile_c_asm),$$f,$$($1_$2_WAYS)))
$$(call removeFiles,$$@.bit)
endif
@@ -135,9 +135,15 @@ endef
# need to do the substitution case-insensitively on Windows. But
# the s///i modifier isn't portable, so we set CASE_INSENSITIVE_SED
# to "i" on Windows and "" on any other platform.
+
+# We use this not only for .c files, but also for .S and .cmm files.
+# As gcc doesn't know what a .cmm file is, it treats it as a linker
+# input and ignores it. We therefore tell gcc that all files are C
+# files with "-x c" so that it actually processes them all.
+
define addCFileDeps
- $(CPP) $($1_$2_MKDEPENDC_OPTS) $($1_$2_$(firstword $($1_$2_WAYS))_ALL_CC_OPTS) $($(basename $4)_CC_OPTS) -MM $4 -MF $3.bit
+ $(CPP) $($1_$2_MKDEPENDC_OPTS) $($1_$2_$(firstword $($1_$2_WAYS))_ALL_CC_OPTS) $($(basename $4)_CC_OPTS) -MM -x c $4 -MF $3.bit
$(foreach w,$5,sed -e 's|\\|/|g' -e 's| /$$| \\|' -e "1s|\.o|\.$($w_osuf)|" -e "1s|^|$(dir $4)|" -e "1s|$1/|$1/$2/build/|" -e "1s|$2/build/$2/build|$2/build|g" -e "s|$(TOP)/||g$(CASE_INSENSITIVE_SED)" $3.bit >> $3.tmp &&) true
endef
diff --git a/rules/c-sources.mk b/rules/c-sources.mk
index 2f0eb9821d..309f9a0e88 100644
--- a/rules/c-sources.mk
+++ b/rules/c-sources.mk
@@ -11,6 +11,7 @@
# -----------------------------------------------------------------------------
define c-sources # args: $1 = dir, $2 = distdir
-$1_$2_C_FILES = $$(patsubst %,$1/%,$$($1_$2_C_SRCS))
-$1_$2_S_FILES = $$(patsubst %,$1/%,$$($1_$2_S_SRCS))
+$1_$2_C_FILES = $$(patsubst %,$1/%,$$($1_$2_C_SRCS))
+$1_$2_S_FILES = $$(patsubst %,$1/%,$$($1_$2_S_SRCS))
+$1_$2_CMM_FILES = $$(patsubst %,$1/%,$$($1_$2_CMM_SRCS))
endef
View Lorry Controller Status