\section[TcIfaceSig]{Type checking of type signatures in interface files}
\begin{code}
-module TcIfaceSig ( tcInterfaceSigs ) where
+module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
#include "HsVersions.h"
import TcEnv ( ValueEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetValueEnv,
tcLookupTyConByKey, tcLookupValueMaybe,
- explicitLookupValue, badCon, badPrimOp
+ explicitLookupValue, badCon, badPrimOp, valueEnvIds
)
import TcType ( TcKind, kindToTcKind )
import RnHsSyn ( RenamedHsDecl )
import HsCore
-import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import CallConv ( cCallConv )
import Const ( Con(..), Literal(..) )
import CoreSyn
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
-import Id ( Id, mkImportedId, mkUserId,
+import Id ( Id, mkId, mkVanillaId,
isPrimitiveId_maybe, isDataConId_maybe
)
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
-import SpecEnv ( addToSpecEnv )
-import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
+import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, unUsgTy )
import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
-import Name ( Name, NamedThing(..) )
+import Name ( Name, NamedThing(..), isLocallyDefined )
import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
+import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Maybes ( maybeToBool, MaybeErr(..) )
import Outputable
-> TcM s [Id]
-tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest)
- = tcAddSrcLoc src_loc (
- tcAddErrCtxt (ifaceSigCtxt name) (
- tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info ->
- returnTc (mkImportedId name sigma_ty id_info)
- )) `thenTc` \ sig_id ->
- tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
- returnTc (sig_id : sig_ids)
-
-tcInterfaceSigs unf_env (other_decl : rest) = tcInterfaceSigs unf_env rest
-
-tcInterfaceSigs unf_env [] = returnTc []
+tcInterfaceSigs unf_env decls
+ = listTc [ do_one name ty id_infos src_loc
+ | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+ where
+ in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+
+ do_one name ty id_infos src_loc
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (ifaceSigCtxt name) $
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo unf_env in_scope_vars name
+ sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info ->
+ returnTc (mkId name sigma_ty id_info)
\end{code}
\begin{code}
-tcIdInfo unf_env name ty info info_ins
- = foldlTc tcPrag noIdInfo info_ins
+tcIdInfo unf_env in_scope_vars name ty info info_ins
+ = foldlTc tcPrag vanillaIdInfo info_ins
where
- tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
- tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
- tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info)
+ tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
+ tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd)
+ tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsCprInfo cpr_info) = returnTc (info `setCprInfo` cpr_info)
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
- Just expr -> tcPragExpr unf_env name [] expr
+ Just expr -> tcPragExpr unf_env name in_scope_vars expr
Nothing -> returnNF_Tc Nothing
) `thenNF_Tc` \ maybe_expr' ->
let
-- 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
+ Nothing -> noUnfolding
Just expr' -> mkUnfolding expr'
- info1 = unfold_info `setUnfoldingInfo` info
-
- info2 = inline_prag `setInlinePragInfo` info1
+ info1 = info `setUnfoldingInfo` unfold_info
+ info2 = info1 `setInlinePragInfo` inline_prag
in
returnTc info2
- tcPrag info (HsStrictness strict)
- = tcStrictness unf_env ty info strict
-
- tcPrag info (HsSpecialise tyvars tys rhs)
- = tcExtendTyVarScope tyvars $ \ tyvars' ->
- mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (kinds, tys') ->
- -- Assume that the kinds match the kinds of the
- -- type variables of the function; this is, after all, an
- -- interface file generated by the compiler!
+ tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
+ = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
- tcPragExpr unf_env name tyvars' rhs `thenNF_Tc` \ maybe_rhs' ->
- let
- -- If spec_env isn't looked at, none of this
- -- actually takes place
- spec_env = specInfo info
- spec_env' = case maybe_rhs' of
- Nothing -> spec_env
- Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
- Succeeded spec_env' -> spec_env'
- Failed err -> pprTrace "tcIdInfo: bad specialisation"
- (ppr name <+> ppr err) $
- spec_env
- in
- returnTc (spec_env' `setSpecInfo` info)
+ tcPrag info (HsWorker nm)
+ = tcWorkerInfo unf_env ty info nm
\end{code}
\begin{code}
-tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker)
- = tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
- uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
+tcWorkerInfo unf_env ty info worker_name
+ | not (hasArity arity_info)
+ = pprPanic "Worker with no arity info" (ppr worker_name)
+
+ | otherwise
+ = uniqSMToTcM (mkWrapper ty arity demands cpr_info) `thenNF_Tc` \ wrap_fn ->
let
- -- Watch out! We can't pull on maybe_worker_id too eagerly!
- info' = case maybe_worker_id of
- Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
- setInlinePragInfo IWantToBeINLINEd info
+ -- Watch out! We can't pull on unf_env too eagerly!
+ info' = case explicitLookupValue unf_env worker_name of
+ Just worker_id -> info `setUnfoldingInfo` mkUnfolding (wrap_fn worker_id)
+ `setWorkerInfo` Just worker_id
- Nothing -> info
-
- has_worker = maybeToBool maybe_worker_id
+ Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
in
- returnTc (StrictnessInfo demands bot_result has_worker `setStrictnessInfo` info')
-\end{code}
-
-\begin{code}
-tcWorker unf_env Nothing = returnNF_Tc Nothing
-
-tcWorker unf_env (Just (worker_name,_))
- = returnNF_Tc (trace_maybe maybe_worker_id)
+ returnTc info'
where
- maybe_worker_id = explicitLookupValue unf_env worker_name
-
- -- The trace is so we can see what's getting dropped
- trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
- trace_maybe (Just x) = Just x
+ -- We are relying here on arity, cpr and strictness info always appearing
+ -- before worker info, fingers crossed ....
+ arity_info = arityInfo info
+ arity = arityLowerBound arity_info
+ cpr_info = cprInfo info
+ demands = case strictnessInfo info of
+ StrictnessInfo d _ -> d
+ _ -> repeat wwLazy -- Noncommittal
\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 :: ValueEnv -> Name -> [IdOrTyVar] -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
-tcPragExpr unf_env name in_scope_vars core_expr
- = forkNF_Tc (
- recoverNF_Tc no_unfolding (
- tcSetValueEnv unf_env $
- tcCoreExpr core_expr `thenTc` \ core_expr' ->
+tcPragExpr unf_env name in_scope_vars expr
+ = tcDelay unf_env doc $
+ tcCoreExpr expr `thenTc` \ core_expr' ->
-- Check for type consistency in the unfolding
- tcGetSrcLoc `thenNF_Tc` \ src_loc ->
- returnTc (lintUnfolding src_loc in_scope_vars core_expr')
+ tcGetSrcLoc `thenNF_Tc` \ src_loc ->
+ case lintUnfolding src_loc in_scope_vars core_expr' of
+ Nothing -> returnTc core_expr'
+ Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
+ where
+ doc = text "unfolding of" <+> ppr name
+
+tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
+tcDelay unf_env doc thing_inside
+ = forkNF_Tc (
+ recoverNF_Tc bad_value (
+ tcSetValueEnv unf_env thing_inside `thenTc` \ r ->
+ returnTc (Just r)
))
where
-- The trace tells what wasn't available, for the benefit of
-- compiler hackers who want to improve it!
- no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
- returnNF_Tc (pprTrace "tcUnfolding failed with:"
- (hang (ppr name) 4 (pprBagOfErrors errs))
+ bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
+ returnNF_Tc (pprTrace "Failed:"
+ (hang doc 4 (pprBagOfErrors errs))
Nothing)
\end{code}
mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- Put the missing type arguments back in
- con_args = map (Type . coreExprType) args' ++ args'
+ con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
in
returnTc (Con con con_args)
= tcCoreExpr scrut `thenTc` \ scrut' ->
let
scrut_ty = coreExprType scrut'
- case_bndr' = mkUserId case_bndr scrut_ty
+ case_bndr' = mkVanillaId case_bndr scrut_ty
in
tcExtendGlobalValEnv [case_bndr'] $
mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
= tcCoreExpr expr `thenTc` \ expr' ->
case note of
UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
- returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
+ returnTc (Note (Coerce (unUsgTy to_ty')
+ (unUsgTy (coreExprType expr'))) expr')
UfInlineCall -> returnTc (Note InlineCall expr')
- UfSCC cc -> returnTc (Note (SCC cc) expr')
+ UfInlineMe -> returnTc (Note InlineMe expr')
+ UfSCC cc -> returnTc (Note (SCC cc) expr')
tcCoreNote (UfSCC cc) = returnTc (SCC cc)
tcCoreNote UfInlineCall = returnTc InlineCall
tcCoreLamBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
let
- id = mkUserId name ty'
+ id = mkVanillaId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
in
tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
+tcCoreLamBndrs [] thing_inside = thing_inside []
+tcCoreLamBndrs (b:bs) thing_inside
+ = tcCoreLamBndr b $ \ b' ->
+ tcCoreLamBndrs bs $ \ bs' ->
+ thing_inside (b':bs')
+
tcCoreValBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
let
- id = mkUserId name ty'
+ id = mkVanillaId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
= mapTc tcHsType tys `thenTc` \ tys' ->
let
- ids = zipWithEqual "tcCoreValBndr" mkUserId names tys'
+ ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
in
tcExtendGlobalValEnv ids $
thing_inside ids
ppr arg_tys)
| otherwise
#endif
- = zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys
+ = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
in
ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
tcExtendTyVarEnv ex_tyvars' $
projects / ghc-hetmet.git / blobdiff