Commit e6d00492 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-02-04 12:33:05 by simonpj]

---------------------------------------------------
	Template-Haskell fix to make the global environment
		      more side-effect-ful
	---------------------------------------------------

Consider

	f = $(...foldl...) $(...foldl...)

The first splice sucks in the type sig for foldl, which the second
splice needs.  That means that the second splice is going to have to
consult the persistent compiler state to see the effect of imports
by the first one.

We used to cache the global type environment in the TcGblEnv, but
this commit switches to the obvious thing: consult the persistent
state on every global lookup.  After all, reading a MutVar is no
big deal; and it's a benign, ever-growing cache of type signatures,
so the side effect is fine.

On the way I tidied up the knot-tying in TcIfaceSig a bit more.
Previously, I think the setUnfoldingInfo was being strict in the
unfolding, which forced it to be type-checked.  Now it's lazy.
That could mean a lot less typechecking overall, for things whose
unfolding isn't looked at.  I hope I havn't broken it, though.
parent 115f0fae
......@@ -38,7 +38,7 @@ module IdInfo (
workerInfo, setWorkerInfo, ppWorkerInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
#ifdef OLD_STRICTNESS
-- Old DemandInfo and StrictnessInfo
......@@ -347,7 +347,11 @@ setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
#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:
......
......@@ -33,9 +33,6 @@ module TcEnv(
-- Global type variables
tcGetGlobalTyVars,
-- Random useful things
RecTcGblEnv, tcLookupRecId_maybe,
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
topIdLvl,
......@@ -73,7 +70,7 @@ import Name ( Name, NamedThing(..),
)
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 )
......@@ -180,24 +177,6 @@ data TyThingDetails = SynTyDetails Type
\end{code}
%************************************************************************
%* *
\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}
......@@ -255,9 +234,8 @@ tcExtendGlobalEnv things thing_inside
(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
......@@ -275,17 +253,22 @@ tcExtendGlobalTypeEnv extra_env thing_inside
\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.
......@@ -328,8 +311,15 @@ tcLookupTyCon name
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}
......@@ -551,15 +541,31 @@ tcGetGlobalTyVars
%* *
%************************************************************************
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
......@@ -568,9 +574,11 @@ tcExtendInstEnv dfuns thing_inside
= 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
......@@ -580,11 +588,11 @@ tcExtendInstEnv dfuns thing_inside
(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 }
......@@ -593,13 +601,15 @@ tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
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
......
......@@ -5,7 +5,6 @@
\begin{code}
module TcIfaceSig ( tcInterfaceSigs,
tcVar,
tcCoreExpr,
tcCoreLamBndrs,
tcCoreBinds ) where
......@@ -17,10 +16,7 @@ import TcHsSyn ( TypecheckedCoreBind )
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
......@@ -65,6 +61,14 @@ tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
-- 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
......@@ -104,69 +108,69 @@ tc_interface_sigs decls unf_env
\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
......@@ -185,19 +189,12 @@ tcPragExpr unf_env name in_scope_vars expr
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.
......
......@@ -746,6 +746,7 @@ tc_src_decls
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 {
......@@ -930,8 +931,8 @@ typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
-- 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 })
......
......@@ -116,7 +116,8 @@ initTc (HscEnv { hsc_mode = ghci_mode,
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,
......@@ -139,8 +140,7 @@ initTc (HscEnv { hsc_mode = ghci_mode,
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,
......@@ -476,6 +476,7 @@ forkM :: SDoc -> TcM a -> TcM (Maybe a)
-- 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
......@@ -487,7 +488,8 @@ forkM doc thing_inside
= 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 {
......
......@@ -235,6 +235,7 @@ data TopEnv -- Built once at top level then does not change
-- 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
......@@ -273,15 +274,15 @@ data TcGblEnv
-- (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.
......@@ -667,13 +668,19 @@ data Inst
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
......
......@@ -16,10 +16,10 @@ import TcRnMonad
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
......@@ -33,14 +33,14 @@ tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
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)
......
......@@ -155,6 +155,8 @@ tcTopSplice expr res_ty
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!
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment