\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, bindInstsOfLocalFuns,
tcPragmaSigs, checkSigTyVars, tcBindWithSigs,
- sigCtxt, sigThetaCtxt, TcSigInfo(..) ) where
+ sigCtxt, TcSigInfo(..) ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
+import {-# SOURCE #-} TcExpr ( tcExpr )
-import HsSyn ( HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
- collectMonoBinders
- )
-import RnHsSyn ( RenamedHsBinds, RenamedSig(..),
- RenamedMonoBinds
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
+ collectMonoBinders, andMonoBinds
)
+import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds,
- TcExpr, TcIdOcc(..), TcIdBndr,
+ TcIdOcc(..), TcIdBndr,
tcIdType
)
newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy,
zonkInst, pprInsts
)
-import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId,
+import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK,
+ newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesFun )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcType, TcThetaType, TcTauType,
TcTyVarSet, TcTyVar,
- newTyVarTy, newTcTyVar, tcInstSigType, newTyVarTys,
+ newTyVarTy, newTcTyVar, tcInstSigType, tcInstSigTcType,
zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar
)
import Unify ( unifyTauTy, unifyTauTyLists )
import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
-import Id ( GenId, idType, mkUserId )
-import IdInfo ( noIdInfo )
-import Maybes ( maybeToBool, assocMaybe, catMaybes )
+import MkId ( mkUserId )
+import Id ( idType, idName, idInfo, replaceIdInfo )
+import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import Maybes ( maybeToBool, assocMaybe )
import Name ( getOccName, getSrcLoc, Name )
-import PragmaInfo ( PragmaInfo(..) )
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes,
- mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
- splitRhoTy, mkForAllTy, splitForAllTys )
-import TyVar ( GenTyVar, TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
- elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
-import Bag ( bagToList, foldrBag, isEmptyBag )
-import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc )
+ splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
+ splitRhoTy, mkForAllTy, splitForAllTys
+ )
+import TyVar ( TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
+ elementOfTyVarSet, unionTyVarSets, tyVarSetToList
+ )
+import Bag ( bagToList, foldrBag, )
+import Util ( isIn, hasNoDups, assoc )
import Unique ( Unique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import SrcLoc ( SrcLoc )
-- should be no black-hole problems here.
-- TYPECHECK THE SIGNATURES
- mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs ->
+ mapTc tcTySig ty_sigs `thenTc` \ tc_ty_sigs ->
tcBindWithSigs top_lvl binder_names bind
tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-> RenamedMonoBinds
-> [TcSigInfo s]
-> RecFlag
- -> (Name -> PragmaInfo)
+ -> (Name -> IdInfo)
-> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature
- Nothing -> mkUserId name forall_a_a NoPragmaInfo -- No signature
+ Nothing -> mkUserId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
- getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
+ getTyVarsToGen is_unrestricted mono_id_tys lie `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- DEAL WITH TYPE VARIABLE KINDS
-- **** This step can do unification => keep other zonking after this ****
- mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
-- It's important that the final list
--
-- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
-- real_tyvars_to_gen
- --
in
-- SIMPLIFY THE LIE
-- Check that the needed dicts can be expressed in
-- terms of the signature ones
tcAddErrCtxt (bindSigsCtxt tysig_names) $
- tcAddErrCtxtM (sigThetaCtxt dicts_sig) $
tcSimplifyAndCheck
- (text "tcBinds2" <+> ppr binder_names)
+ (ptext SLIT("type signature for") <+>
+ hsep (punctuate comma (map (quotes . ppr) binder_names)))
real_tyvars_to_gen givens lie `thenTc` \ (lie_free, dict_binds) ->
returnTc (lie_free, dict_binds, dict_ids)
dict_tys = map tcIdType dicts_bound
mk_export binder_name mono_id zonked_mono_id_ty
- | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
- | otherwise = (real_tyvars_to_gen_list, TcId poly_id, TcId mono_id)
+ = (tyvars, TcId (replaceIdInfo poly_id (prag_info_fn binder_name)), TcId mono_id)
where
- maybe_sig = maybeSig tc_ty_sigs binder_name
- Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
- poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
- poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
+ (tyvars, poly_id) = case maybeSig tc_ty_sigs binder_name of
+ Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) -> (sig_tyvars, sig_poly_id)
+ Nothing -> (real_tyvars_to_gen_list, new_poly_id)
+
+ new_poly_id = mkUserId binder_name poly_ty
+ poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-- It's important to build a fully-zonked poly_ty, because
-- we'll slurp out its free type variables when extending the
-- local environment (tcExtendLocalValEnv); if it's not zonked
in
if is_unrestricted
then
- returnTc (emptyTyVarSet, tyvars_to_gen)
+ returnNF_Tc (emptyTyVarSet, tyvars_to_gen)
else
+ -- This recover and discard-errs is to avoid duplicate error
+ -- messages; this, after all, is an "extra" call to tcSimplify
+ recoverNF_Tc (returnNF_Tc (emptyTyVarSet, tyvars_to_gen)) $
+ discardErrsTc $
+
tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
\begin{code}
-tcTySig :: (Name -> PragmaInfo)
- -> RenamedSig
+tcTySig :: RenamedSig
-> TcM s (TcSigInfo s)
-tcTySig prag_info_fn (Sig v ty src_loc)
+tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
tcHsType ty `thenTc` \ sigma_ty ->
- tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
+
+ -- Convert from Type to TcType
+ tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty ->
+ let
+ poly_id = mkUserId v sigma_tc_ty
+ in
+ -- Instantiate this type
+ -- It's important to do this even though in the error-free case
+ -- we could just split the sigma_tc_ty (since the tyvars don't
+ -- unified with anything). But in the case of an error, when
+ -- the tyvars *do* get unified with something, we want to carry on
+ -- typechecking the rest of the program with the function bound
+ -- to a pristine type, namely sigma_tc_ty
+ tcInstSigTcType sigma_tc_ty `thenNF_Tc` \ (tyvars, rho) ->
let
- poly_id = mkUserId v sigma_ty' (prag_info_fn v)
- (tyvars', theta', tau') = splitSigmaTy sigma_ty'
+ (theta, tau) = splitRhoTy rho
-- This splitSigmaTy tries hard to make sure that tau' is a type synonym
-- wherever possible, which can improve interface files.
in
- returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
+ returnTc (TySigInfo v poly_id tyvars theta tau src_loc)
\end{code}
@checkSigMatch@ does the next step in checking signature matching.
moving them into place as is done for type signatures.
\begin{code}
-tcPragmaSigs :: [RenamedSig] -- The pragma signatures
- -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
+tcPragmaSigs :: [RenamedSig] -- The pragma signatures
+ -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
TcMonoBinds s,
LIE s)
--- For now we just deal with INLINE pragmas
-tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
- where
- prag_fn name | any has_inline sigs = IWantToBeINLINEd
- | otherwise = NoPragmaInfo
- where
- has_inline (InlineSig n _) = (n == name)
- has_inline other = False
-
-
-{-
tcPragmaSigs sigs
- = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
+ = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
let
- name_to_info name = foldr ($) noIdInfo
- [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
+ prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
in
- returnTc (name_to_info,
- foldr ThenBinds EmptyBinds binds,
- foldr plusLIE emptyLIE lies)
-\end{code}
-
-Here are the easy cases for tcPragmaSigs
-
-\begin{code}
-tcPragmaSig (InlineSig name loc)
- = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
-tcPragmaSig (MagicUnfoldingSig name string loc)
- = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
+ returnTc (prag_fn, andMonoBinds binds, plusLIEs lies)
\end{code}
The interesting case is for SPECIALISE pragmas. There are two forms.
a bit of overkill.
\begin{code}
+tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
+tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
+
+tcPragmaSig (InlineSig name loc)
+ = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+
+tcPragmaSig (NoInlineSig name loc)
+ = returnTc (Just (name, setInlinePragInfo IDontWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+
tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
+ = -- SPECIALISE f :: forall b. theta => tau = g
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
tcHsType poly_ty `thenTc` \ sig_sigma ->
tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
- let
- (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
- origin = ValSpecOrigin name
- in
- -- Check that the SPECIALIZE pragma had an empty context
- checkTc (null sig_theta)
- (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
+ -- Check that f has a more general type, and build a RHS for
+ -- the spec-pragma-id at the same time
+ tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
- -- Get and instantiate the type of the id mentioned
- tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
- tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
- let
- (main_tyvars, main_rho) = splitForAllTys main_ty
- (main_theta,main_tau) = splitRhoTy main_rho
- main_arg_tys = mkTyVarTys main_tyvars
- in
+ case maybe_spec_name of
+ Nothing -> -- Just specialise "f" by building a SpecPragmaId binding
+ -- It is the thing that makes sure we don't prematurely
+ -- dead-code-eliminate the binding we are really interested in.
+ newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
+ returnTc (Nothing, VarMonoBind (TcId spec_id) spec_expr, spec_lie)
- -- Check that the specialised type is indeed an instance of
- -- the type of the main function.
- unifyTauTy sig_tau main_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau `thenTc_`
-
- -- Check that the type variables of the polymorphic function are
- -- either left polymorphic, or instantiate to ground type.
- -- Also check that the overloaded type variables are instantiated to
- -- ground type; or equivalently that all dictionaries have ground type
- zonkTcTypes main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
- zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
- tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
- (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
- tcAddErrCtxt (specContextGroundnessCtxt main_theta')
- (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
-
- -- Build the SpecPragmaId; it is the thing that makes sure we
- -- don't prematurely dead-code-eliminate the binding we are really interested in.
- newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
-
- -- Build a suitable binding; depending on whether we were given
- -- a value (Maybe Name) to be used as the specialisation.
- case using of
- Nothing -> -- No implementation function specified
-
- -- Make a Method inst for the occurrence of the overloaded function
- newMethodWithGivenTy (OccurrenceOf name)
- (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
+ Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
+
+ panic "Can't handle SPECIALISE with a '= g' part"
- let
- pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
- pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
- in
- returnTc (pseudo_bind, lie, \ info -> info)
+ {- Not yet. Because we're still in the TcType world we
+ can't really add to the SpecEnv of the Id. Instead we have to
+ record the information in a different sort of Sig, and add it to
+ the IdInfo after zonking.
- Just spec_name -> -- Use spec_name as the specialisation value ...
+ For now we just leave out this case
- -- Type check a simple occurrence of the specialised Id
- tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
+ -- Get the type of f, and find out what types
+ -- f has to be instantiated at to give the signature type
+ tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
+ tcInstSigTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
- -- Check that it has the correct type, and doesn't constrain the
- -- signature variables at all
- unifyTauTy sig_tau spec_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau `thenTc_`
+ let
+ (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
+ (f_theta, f_tau) = splitRhoTy f_rho
+ sig_tyvar_set = mkTyVarSet sig_tyvars
+ in
+ unifyTauTy sig_tau f_tau `thenTc_`
- -- Make a local SpecId to bind to applied spec_id
- newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
+ tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _,
+ -}
- let
- spec_rhs = mkHsTyLam sig_tyvars spec_body
- spec_binds = VarMonoBind local_spec_id spec_rhs
- `AndMonoBinds`
- VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
- spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
- in
- returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
--}
+tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $
+ returnTc (Nothing, EmptyMonoBinds, emptyLIE)
\end{code}
sigCtxt id
= sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)]
-sigThetaCtxt dicts_sig
- = mapNF_Tc zonkInst (bagToList dicts_sig) `thenNF_Tc` \ dicts' ->
- returnNF_Tc (ptext SLIT("Available context:") <+> pprInsts dicts')
-
bindSigsCtxt ids
= ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
projects / ghc-hetmet.git / blobdiff