X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=5295fec764f734372e3daabd66614cfa6ad124ce;hb=37ad132b596204ce913a4c72905d6d06e32c0970;hp=004d7b5784db60a19166a8d6525ac79800065443;hpb=b7cc3d012a98cc49abb3441e6637d5148f57f1d1;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 004d7b5..5295fec 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -5,7 +5,6 @@ \begin{code} module TcIfaceSig ( tcInterfaceSigs, - tcVar, tcCoreExpr, tcCoreLamBndrs, tcCoreBinds ) where @@ -14,12 +13,11 @@ module TcIfaceSig ( tcInterfaceSigs, import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) 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, + tcLookupDataCon ) import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) import HsCore @@ -30,7 +28,7 @@ import CoreUnfold 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 ) @@ -42,7 +40,7 @@ import Name ( Name ) import UniqSupply ( initUs_ ) import Outputable import Util ( zipWithEqual, dropList, equalLength ) -import HscTypes ( TyThing(..) ) +import HscTypes ( typeEnvIds ) import CmdLineOpts ( DynFlag(..) ) \end{code} @@ -54,100 +52,141 @@ As always, we do not have to worry about user-pragmas in interface 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 @@ -166,19 +205,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. @@ -358,11 +390,10 @@ tcConAlt :: UfConAlt Name -> TcM DataCon 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} %************************************************************************