\begin{code}
module TcIfaceSig ( tcInterfaceSigs,
- tcVar,
tcCoreExpr,
tcCoreLamBndrs,
tcCoreBinds ) where
import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) )
import TcHsSyn ( TypecheckedCoreBind )
+import TcRnTypes
import TcRnMonad
-import TcMonoType ( tcIfaceType )
-import TcEnv ( RecTcGblEnv, tcExtendTyVarEnv,
- tcExtendGlobalValEnv,
- tcLookupGlobal_maybe, tcLookupRecId_maybe
- )
+import TcMonoType ( tcIfaceType, kcHsSigType )
+import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId,
+ tcLookupDataCon )
import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl )
import HsCore
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe )
+import Id ( Id, mkVanillaGlobal, mkLocalId )
import MkId ( mkFCallId )
import IdInfo
import TyCon ( tyConDataCons, tyConTyVars )
import UniqSupply ( initUs_ )
import Outputable
import Util ( zipWithEqual, dropList, equalLength )
-import HscTypes ( TyThing(..) )
+import HscTypes ( typeEnvIds )
+import CmdLineOpts ( DynFlag(..) )
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
signatures.
\begin{code}
-tcInterfaceSigs :: RecTcGblEnv -- Envt to use when checking unfoldings
- -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
- -> TcM [Id]
+tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
+ -> TcM TcGblEnv
-
-tcInterfaceSigs unf_env decls
- = sequenceM [ do_one name ty id_infos src_loc
- | IfaceSig {tcdName = name, tcdType = ty,
- tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
+-- May 2003:
+-- NOTE 1: careful about the side-effected EPS
+-- in the two tcExtendGlobalValueEnv calls
+-- NOTE 2: no point in tying the knot with fixM; all
+-- the important knot-tying comes via the PCS global variable
+
+tcInterfaceSigs decls =
+ zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) ->
+ -- The zapEnv dramatically trims the environment, solely
+ -- to plug the space leak that would otherwise be caused
+ -- by a rich environment bound into lots of lazy thunks
+ -- The thunks are the lazily-typechecked IdInfo of the
+ -- imported things.
+
+ tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env ->
+ returnM gbl_env
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- 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
+ -- (a) the knot is tiresomely big, and
+ -- (b) it black-holes when we have Template Haskell
+ --
+ -- For (b) consider: f = $(...h....)
+ -- where h is imported, and calls f via an hi-boot file.
+ -- This is bad! But it is not seen as a staging error, because h
+ -- is indeed imported. We don't want the type-checker to black-hole
+ -- when simplifying and compiling the splice!
+ --
+ -- Simple solution: discard any unfolding that mentions a variable
+ -- bound in this module (and hence not yet processed).
+ -- The discarding happens when forkM finds a type error.
+
+tc_interface_sigs decls ~(unf_env, _)
+ = sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env ->
+ returnM (gbl_env, sig_ids)
where
- in_scope_vars = []
--- in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
- -- Oops: using isLocalId instead can give a black hole
- -- because it looks at the idinfo
-
+ in_scope_vars = typeEnvIds (tcg_type_env unf_env)
-- When we have hi-boot files, an unfolding might refer to
-- something defined in this module, so we must build a
-- suitable in-scope set. This thunk will only be poked
-- if -dcore-lint is on.
- do_one name ty id_infos src_loc
- = addSrcLoc src_loc $
+ do_one IfaceSig {tcdName = name, tcdType = ty,
+ tcdIdInfo = id_infos, tcdLoc = src_loc}
+ = addSrcLoc src_loc $
addErrCtxt (ifaceSigCtxt name) $
- tcIfaceType ty `thenM` \ sigma_ty ->
+ tcIfaceType ty `thenM` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
- sigma_ty id_infos `thenM` \ id_info ->
+ sigma_ty id_infos `thenM` \ id_info ->
returnM (mkVanillaGlobal name sigma_ty id_info)
\end{code}
\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)
+ init_info = vanillaIdInfo
- 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
- getSrcLocM `thenM` \ src_loc ->
- getDOpts `thenM` \ dflags ->
- case lintUnfolding dflags src_loc in_scope_vars core_expr' of
- (Nothing,_) -> returnM core_expr' -- ignore warnings
- (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
+ ifOptM Opt_DoCoreLinting (
+ getSrcLocM `thenM` \ src_loc ->
+ case lintUnfolding src_loc in_scope_vars core_expr' of
+ Nothing -> returnM ()
+ Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg)
+ ) `thenM_`
+
+ returnM core_expr'
where
doc = text "unfolding of" <+> ppr name
\end{code}
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.
tcConAlt (UfTupleAlt (HsTupCon boxity arity))
= returnM (tupleCon boxity arity)
-tcConAlt (UfDataAlt con_name)
- = tcVar con_name `thenM` \ con_id ->
- returnM (case isDataConWrapId_maybe con_id of
- Just con -> con
- Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
+tcConAlt (UfDataAlt con_name) -- When reading interface files
+ -- the con_name will be the real name of
+ -- the data con
+ = tcLookupDataCon con_name
\end{code}
%************************************************************************
-- So first build the environment, then check the RHSs
tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs ->
tcExtendGlobalValEnv bndrs $
- mappM tcCoreBind ls
+ mappM (tcCoreBind bndrs) ls
tcCoreBinder (CoreDecl nm ty _ _)
- = tcIfaceType ty `thenM` \ ty' ->
+ = kcHsSigType ty `thenM_`
+ tcIfaceType ty `thenM` \ ty' ->
returnM (mkLocalId nm ty')
-tcCoreBind (CoreDecl nm _ rhs _)
+tcCoreBind bndrs (CoreDecl nm _ rhs loc)
= tcVar nm `thenM` \ id ->
tcCoreExpr rhs `thenM` \ rhs' ->
+ let
+ mb_err = lintUnfolding loc bndrs rhs'
+ in
+ (case mb_err of
+ Just err -> addErr err
+ Nothing -> returnM ()) `thenM_`
+
returnM (id, rhs')
\end{code}
projects / ghc-hetmet.git / blobdiff