workerInfo, setWorkerInfo, ppWorkerInfo,
-- Unfolding
- unfoldingInfo, setUnfoldingInfo,
+ unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
#ifdef OLD_STRICTNESS
-- Old DemandInfo and StrictnessInfo
#endif
-- Try to avoid spack leaks by seq'ing
-setUnfoldingInfo info uf
+setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the
+ = -- unfolding of an imported Id unless necessary
+ info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.)
+
+setUnfoldingInfo info uf
| isEvaldUnfolding uf
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- Global type variables
tcGetGlobalTyVars,
- -- Random useful things
- RecTcGblEnv, tcLookupRecId_maybe,
-
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
topIdLvl,
)
import NameEnv
import OccName ( mkDFunOcc, occNameString )
-import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
+import HscTypes ( DFunId, TypeEnv, extendTypeEnvList, lookupType,
TyThing(..), ExternalPackageState(..) )
import Rules ( RuleBase )
import BasicTypes ( EP )
%************************************************************************
%* *
-\subsection{Basic lookups}
-%* *
-%************************************************************************
-
-\begin{code}
-type RecTcGblEnv = TcGblEnv
--- This environment is used for getting the 'right' IdInfo
--- on imported things and for looking up Ids in unfoldings
--- The environment doesn't have any local Ids in it
-
-tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
-tcLookupRecId_maybe env name = case lookup_global env name of
- Just (AnId id) -> Just id
- other -> Nothing
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Making new Ids}
%* *
%************************************************************************
(lcl_things, pkg_things) = partition (isLocalThing mod) things
ge' = extendTypeEnvList (tcg_type_env env) lcl_things
eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
- ist' = mkImpTypeEnv eps' hpt
; setEps eps'
- ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
+ ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
\begin{code}
-lookup_global :: TcGblEnv -> Name -> Maybe TyThing
- -- Try the global envt and then the global symbol table
-lookup_global env name
- = lookupNameEnv (tcg_type_env env) name
- `seqMaybe`
- tcg_ist env name
-
tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
+-- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps)
+-- Notice that for imported things we read the current version from the EPS
+-- mutable variable. This is important in situations like
+-- ...$(e1)...$(e2)...
+-- where the code that e1 expands to might import some defns that
+-- also turn out to be needed by the code that e2 expands to.
tcLookupGlobal_maybe name
- = getGblEnv `thenM` \ env ->
- returnM (lookup_global env name)
+ = do { env <- getGblEnv
+ ; if nameIsLocalOrFrom (tcg_mod env) name then
+ -- Defined in this module
+ return (lookupNameEnv (tcg_type_env env) name)
+ else
+ do { env <- getTopEnv
+ ; eps <- readMutVar (top_eps env)
+ ; return (lookupType (top_hpt env) (eps_PTE eps) name) }}
\end{code}
A variety of global lookups, when we know what we are looking for.
getInGlobalScope :: TcRn m (Name -> Bool)
-getInGlobalScope = do { gbl_env <- getGblEnv ;
- return (\n -> isJust (lookup_global gbl_env n)) }
+-- Get all things in the global environment; used for deciding what
+-- rules to suck in. Anything defined in this module (nameIsLocalOrFrom)
+-- is certainly in the envt, so we don't bother to look.
+getInGlobalScope
+ = do { mod <- getModule
+ ; eps <- getEps
+ ; hpt <- getHpt
+ ; return (\n -> nameIsLocalOrFrom mod n ||
+ isJust (lookupType hpt (eps_PTE eps) n)) }
\end{code}
%* *
%************************************************************************
+The TcGblEnv holds a mutable variable containing the current full, instance environment.
+The ExtendInstEnv functions extend this environment by side effect, in case we are
+sucking in new instance declarations deep in the body of a TH splice, which are needed
+in another TH splice. The tcg_insts field of the TcGblEnv contains just the dfuns
+from this module
+
\begin{code}
tcGetInstEnv :: TcM InstEnv
tcGetInstEnv = getGblEnv `thenM` \ env ->
- returnM (tcg_inst_env env)
+ readMutVar (tcg_inst_env env)
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
+-- Horribly imperative;
+-- but used only when temporarily enhancing the instance
+-- envt during 'deriving' context inference
tcSetInstEnv ie thing_inside
= getGblEnv `thenM` \ env ->
- setGblEnv (env {tcg_inst_env = ie}) thing_inside
+ let
+ ie_var = tcg_inst_env env
+ in
+ readMutVar ie_var `thenM` \ old_ie ->
+ writeMutVar ie_var ie `thenM_`
+ thing_inside `thenM` \ result ->
+ writeMutVar ie_var old_ie `thenM_`
+ returnM result
tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
-- Add instances from local or imported
= do { dflags <- getDOpts
; eps <- getEps
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
-- Extend the total inst-env with the new dfuns
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
-- Sort the ones from this module from the others
(lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
(eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
eps' = eps { eps_inst_env = eps_inst_env' }
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = lcl_dfuns ++ tcg_insts env }
+ env' = env { tcg_insts = lcl_dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setEps eps'
; setGblEnv env' thing_inside }
tcExtendLocalInstEnv infos thing_inside
= do { dflags <- getDOpts
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
dfuns = map iDFunId infos
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = dfuns ++ tcg_insts env }
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+ env' = env { tcg_insts = dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setGblEnv env' thing_inside }
traceDFuns dfuns
\begin{code}
module TcIfaceSig ( tcInterfaceSigs,
- tcVar,
tcCoreExpr,
tcCoreLamBndrs,
tcCoreBinds ) where
import TcRnTypes
import TcRnMonad
import TcMonoType ( tcIfaceType, kcHsSigType )
-import TcEnv ( RecTcGblEnv, tcExtendTyVarEnv,
- tcExtendGlobalValEnv,
- tcLookupGlobal_maybe, tcLookupRecId_maybe
- )
+import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId )
import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl )
import HsCore
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
--
+ -- NOTE ALSO: the knot is in two parts:
+ -- * Ids defined in this module are added to the typechecker envt
+ -- which is knot-tied by the fixM.
+ -- * Imported Ids are side-effected into the PCS by the
+ -- tcExtendGlobalValueEnv, so they will be seen there provided
+ -- we don't look them up too early.
+ -- In both cases, we must defer lookups until after the knot is tied
+ --
-- We used to have a much bigger loop (in TcRnDriver), so that the
-- interface pragmas could mention variables bound in this module
-- (by mutual recn), but
\begin{code}
tcIdInfo unf_env in_scope_vars name ty info_ins
- = foldlM tcPrag init_info info_ins
+ = setGblEnv unf_env $
+ -- Use the knot-tied environment for the IdInfo
+ -- In particular: typechecking unfoldings and worker names
+ foldlM tcPrag init_info info_ins
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
init_info = hasCafIdInfo
- tcPrag info (HsNoCafRefs) = returnM (info `setCafInfo` NoCafRefs)
-
- tcPrag info (HsArity arity) =
- returnM (info `setArityInfo` arity)
+ tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
+ tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str)
+ tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity
tcPrag info (HsUnfold inline_prag expr)
- = tcPragExpr unf_env name in_scope_vars expr `thenM` \ maybe_expr' ->
+ = tcPragExpr name in_scope_vars expr `thenM` \ maybe_expr' ->
let
- -- maybe_expr doesn't get looked at if the unfolding
+ -- maybe_expr' doesn't get looked at if the unfolding
-- is never inspected; so the typecheck doesn't even happen
unfold_info = case maybe_expr' of
Nothing -> noUnfolding
Just expr' -> mkTopUnfolding expr'
- info1 = info `setUnfoldingInfo` unfold_info
- info2 = info1 `setInlinePragInfo` inline_prag
in
- returnM info2
-
- tcPrag info (HsStrictness strict_info)
- = returnM (info `setAllStrictnessInfo` Just strict_info)
-
- tcPrag info (HsWorker nm arity)
- = tcWorkerInfo unf_env ty info nm arity
+ returnM (info `setUnfoldingInfoLazily` unfold_info
+ `setInlinePragInfo` inline_prag)
\end{code}
\begin{code}
-tcWorkerInfo unf_env ty info worker_name arity
- = newUniqueSupply `thenM` \ us ->
- let
- wrap_fn = initUs_ us (mkWrapper ty strict_sig)
-
+tcWorkerInfo ty info wkr_name arity
+ = forkM doc (tcVar wkr_name) `thenM` \ maybe_wkr_id ->
-- Watch out! We can't pull on unf_env too eagerly!
- info' = case tcLookupRecId_maybe unf_env worker_name of
- Just worker_id ->
- info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
- `setWorkerInfo` HasWorker worker_id arity
+ -- Hence the forkM
+
+ -- We return without testing maybe_wkr_id, but as soon as info is
+ -- looked at we will test it. That's ok, because its outside the
+ -- knot; and there seems no big reason to further defer the
+ -- tcVar lookup. (Contrast with tcPragExpr, where postponing walking
+ -- over the unfolding until it's actually used does seem worth while.)
+ newUniqueSupply `thenM` \ us ->
+ returnM (case maybe_wkr_id of
+ Nothing -> info
+ Just wkr_id -> info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
+ `setWorkerInfo` HasWorker wkr_id arity)
- Nothing -> pprTrace "tcWorkerInfo failed:"
- (ppr worker_name) info
- in
- returnM info'
where
+ doc = text "worker for" <+> ppr wkr_name
+
+ mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id)
+
-- We are relying here on strictness info always appearing
-- before worker info, fingers crossed ....
- strict_sig = case newStrictnessInfo info of
- Just sig -> sig
- Nothing -> pprPanic "Worker info but no strictness for" (ppr worker_name)
+ strict_sig = case newStrictnessInfo info of
+ Just sig -> sig
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
-tcPragExpr unf_env name in_scope_vars expr
+tcPragExpr :: Name -> [Id] -> UfExpr Name -> TcM (Maybe CoreExpr)
+tcPragExpr name in_scope_vars expr
= forkM doc $
- setGblEnv unf_env $
-
tcCoreExpr expr `thenM` \ core_expr' ->
-- Check for type consistency in the unfolding
Variables in unfoldings
~~~~~~~~~~~~~~~~~~~~~~~
-****** Inside here we use only the Global environment, even for locally bound variables.
-****** Why? Because we know all the types and want to bind them to real Ids.
\begin{code}
tcVar :: Name -> TcM Id
-tcVar name
- = tcLookupGlobal_maybe name `thenM` \ maybe_id ->
- case maybe_id of {
- Just (AnId id) -> returnM id ;
- Nothing -> failWithTc (noDecl name)
- }
-
-noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
+ -- Inside here we use only the Global environment, even for locally bound variables.
+ -- Why? Because we know all the types and want to bind them to real Ids.
+tcVar name = tcLookupGlobalId name
\end{code}
UfCore expressions.
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
+ -- The latter come in via tycl_decls
traceTc (text "Tc2") ;
tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- That is why the tcExtendX functions need to do partitioning.
--
-- If all the decls are from other modules, the returned TcGblEnv
- -- will have an empty tc_genv, but its tc_inst_env and tc_ist
- -- caches may have been augmented.
+ -- will have an empty tc_genv, but its tc_inst_env
+ -- cache may have been augmented.
typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_ruleds = rule_decls })
usg_var <- newIORef emptyUsages ;
nc_var <- newIORef (pcs_nc pcs) ;
eps_var <- newIORef eps ;
-
+ ie_var <- newIORef (mkImpInstEnv dflags eps hpt) ;
+
let {
env = Env { env_top = top_env,
env_gbl = gbl_env,
tcg_fix_env = emptyFixityEnv,
tcg_default = defaultDefaultTys,
tcg_type_env = emptyNameEnv,
- tcg_ist = mkImpTypeEnv eps hpt,
- tcg_inst_env = mkImpInstEnv dflags eps hpt,
+ tcg_inst_env = ie_var,
tcg_exports = [],
tcg_imports = init_imports,
tcg_binds = EmptyMonoBinds,
-- Run thing_inside in an interleaved thread. It gets a separate
-- * errs_var, and
-- * unique supply,
+-- * LIE var is set to bottom (should never be used)
-- but everything else is shared, so this is DANGEROUS.
--
-- It returns Nothing if the computation fails
= do { us <- newUniqueSupply ;
unsafeInterleaveM $
do { us_var <- newMutVar us ;
- (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ;
+ (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $
+ setUsVar us_var thing_inside) ;
case mb_res of
Just r -> return (Just r)
Nothing -> do {
-- PIT, ImportedModuleInfo
-- DeclsMap, IfaceRules, IfaceInsts, InstGates
-- TypeEnv, InstEnv, RuleBase
+ -- Mutable, because we demand-load declarations that extend the state
top_hpt :: HomePackageTable,
-- The home package table that we've accumulated while
-- (Ids defined in this module start in the local envt,
-- though they move to the global envt during zonking)
- -- Cached things
- tcg_ist :: Name -> Maybe TyThing, -- Imported symbol table
- -- Global type env: a combination of tcg_eps, tcg_hpt
- -- (but *not* tcg_type_env; no deep reason)
- -- When the PCS changes this must be refreshed,
- -- notably after running some compile-time code
-
- tcg_inst_env :: InstEnv, -- Global instance env: a combination of
+ tcg_inst_env :: TcRef InstEnv, -- Global instance env: a combination of
-- tc_pcs, tc_hpt, *and* tc_insts
+ -- This field is mutable so that it can be updated inside a
+ -- Template Haskell splice, which might suck in some new
+ -- instance declarations. This is a slightly differen strategy
+ -- than for the type envt, where we look up first in tcg_type_env
+ -- and then in the mutable EPS, because the InstEnv for this module
+ -- is constructed (in principle at least) only from the modules
+ -- 'below' this one, so it's this-module-specific
-- Now a bunch of things about this module that are simply
-- accumulated, but never consulted until the end.
TcThetaType -- The (types of the) dictionaries to which the function
-- must be applied to get the method
- TcTauType -- The type of the method
+ TcTauType -- The tau-type of the method
InstLoc
- -- INVARIANT: in (Method u f tys theta tau loc)
+ -- INVARIANT 1: in (Method u f tys theta tau loc)
-- type of (f tys dicts(from theta)) = tau
+ -- INVARIANT 2: tau must not be of form (Pred -> Tau)
+ -- Reason: two methods are considerd equal if the
+ -- base Id matches, and the instantiating types
+ -- match. The TcThetaType should then match too.
+ -- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
+
| LitInst
Id
HsOverLit -- The literal from the occurrence site
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
import TcMType ( newTyVarTy )
import TcType ( tyVarsOfTypes, openTypeKind )
-import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
+import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
import TcExpr ( tcMonoExpr )
-import TcEnv ( tcExtendLocalValEnv )
+import TcEnv ( tcExtendLocalValEnv, tcLookupGlobalId )
import Inst ( instToId )
import Id ( idType, mkLocalId )
import Outputable
tcRule (IfaceRule name act vars fun args rhs src_loc)
= addSrcLoc src_loc $
addErrCtxt (ruleCtxt name) $
- tcVar fun `thenM` \ fun' ->
+ tcLookupGlobalId fun `thenM` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mappM tcCoreExpr args `thenM` \ args' ->
tcCoreExpr rhs `thenM` \ rhs' ->
returnM (IfaceRuleOut fun' (Rule name act vars' args' rhs'))
tcRule (IfaceRuleOut fun rule) -- Built-in rules come this way
- = tcVar fun `thenM` \ fun' ->
+ = tcLookupGlobalId fun `thenM` \ fun' ->
returnM (IfaceRuleOut fun' rule)
tcRule (HsRule name act vars lhs rhs src_loc)
tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr
+-- Type check an expression that is the body of a top-level splice
+-- (the caller will compile and run it)
tcTopSpliceExpr expr meta_ty
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
projects / ghc-hetmet.git / commitdiff