X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=ec5a59280f6905e7f57de20db0d96d8e8ddf907e;hb=266fadd93461d4317967df08cd641e965cd8769a;hp=ba0fa38e7adf2b385d8ca0b9e5e3b14c60ecc04f;hpb=937b23b94b458172442ac583f8d5b6f5a093a24b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ba0fa38..ec5a592 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -5,7 +5,7 @@ \begin{code} module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, - tcPragmaSigs, tcBindWithSigs ) where + tcSpecSigs, tcBindWithSigs ) where #include "HsVersions.h" @@ -16,22 +16,24 @@ import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), Stmt collectMonoBinders, andMonoBindList, andMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId ) +import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) import TcMonad import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), newDicts, tyVarsOfInst, instToId, + getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps ) import TcEnv ( tcExtendLocalValEnv, - newSpecPragmaId, + newSpecPragmaId, newLocalId, tcLookupTyCon, tcGetGlobalTyVars, tcExtendGlobalTyVars ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) +import TcImprove ( tcImprove ) import TcMonoType ( tcHsType, checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) -import TcPat ( tcVarPat, tcPat ) +import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) import TcType ( TcType, TcThetaType, TcTyVar, @@ -42,21 +44,24 @@ import TcUnify ( unifyTauTy, unifyTauTyLists ) import PrelInfo ( main_NAME, ioTyCon_NAME ) -import Id ( mkUserId ) -import Var ( idType, idName, setIdInfo ) -import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) ) -import Name ( Name, getName ) +import Id ( Id, mkVanillaId, setInlinePragma ) +import Var ( idType, idName ) +import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) +import Name ( Name, getName, getOccName, getSrcLoc ) +import NameSet import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, - mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, + mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, isUnboxedType, unboxedTypeKind, boxedTypeKind ) +import FunDeps ( tyVarFunDep, oclose ) import Var ( TyVar, tyVarKind ) import VarSet import Bag import Util ( isIn ) import Maybes ( maybeToBool ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) +import FiniteMap ( listToFM, lookupFM ) import SrcLoc ( SrcLoc ) import Outputable \end{code} @@ -114,22 +119,17 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next do_next tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next - = fixTc (\ ~(prag_info_fn, _, _) -> - -- This is the usual prag_info fix; the PragmaInfo field of an Id - -- is not inspected till ages later in the compiler, so there - -- should be no black-hole problems here. - - -- TYPECHECK THE SIGNATURES + = -- TYPECHECK THE SIGNATURES mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs -> - tcBindWithSigs top_lvl bind - tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) -> + tcBindWithSigs top_lvl bind tc_ty_sigs + sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) -> -- Extend the environment to bind the new polymorphic Ids tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $ -- Build bindings and IdInfos corresponding to user pragmas - tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> + tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) -> -- Now do whatever happens next, in the augmented envt do_next `thenTc` \ (thing, thing_lie) -> @@ -143,8 +143,7 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- All the top level things are rec'd together anyway, so it's fine to -- leave them to the tcSimplifyTop, and quite a bit faster too (TopLevel, _) - -> returnTc (prag_info_fn, - combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing, + -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing, thing_lie `plusLIE` prag_lie `plusLIE` poly_lie) (NotTopLevel, NonRecursive) @@ -153,7 +152,6 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next poly_ids `thenTc` \ (thing_lie', lie_binds) -> returnTc ( - prag_info_fn, combiner NonRecursive poly_binds $ combiner NonRecursive prag_binds $ combiner Recursive lie_binds $ @@ -171,15 +169,12 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next poly_ids `thenTc` \ (final_lie, lie_binds) -> returnTc ( - prag_info_fn, combiner Recursive ( poly_binds `andMonoBinds` lie_binds `andMonoBinds` prag_binds) thing, final_lie - ) - ) `thenTc` \ (_, thing, lie) -> - returnTc (thing, lie) + ) \end{code} An aside. The original version of @tcBindsAndThen@ which lacks a @@ -230,11 +225,11 @@ tcBindWithSigs :: TopLevelFlag -> RenamedMonoBinds -> [TcSigInfo] + -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs -> RecFlag - -> (Name -> IdInfo) -> TcM s (TcMonoBinds, LIE, [TcId]) -tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn +tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec = recoverTc ( -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise subsequent @@ -246,18 +241,26 @@ tcBindWithSigs top_lvl 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 -- No signature + Nothing -> mkVanillaId name forall_a_a -- No signature in returnTc (EmptyMonoBinds, emptyLIE, poly_ids) ) $ -- TYPECHECK THE BINDINGS - tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> + tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> -- CHECK THAT THE SIGNATURES MATCH -- (must do this before getTyVarsToGen) checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta -> + -- IMPROVE the LIE + -- Force any unifications dictated by functional dependencies. + -- Because unification may happen, it's important that this step + -- come before: + -- - computing vars over which to quantify + -- - zonking the generalized type vars + tcImprove lie_req `thenTc_` + -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen -- The tyvars_not_to_gen are free in the environment, and hence -- candidates for generalisation, but sometimes the monomorphism @@ -287,8 +290,9 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn -- SIMPLIFY THE LIE tcExtendGlobalTyVars tyvars_not_to_gen ( - if null real_tyvars_to_gen_list then - -- No polymorphism, so no need to simplify context + let ips = getIPsOfLIE lie_req in + if null real_tyvars_to_gen_list && null ips then + -- No polymorphism, and no IPs, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) else case maybe_sig_theta of @@ -297,7 +301,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn -- NB: no signatures => no polymorphic recursion, so no -- need to use lie_avail (which will be empty anyway) tcSimplify (text "tcBinds1" <+> ppr binder_names) - top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> + real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) Just (sig_theta, lie_avail) -> @@ -338,7 +342,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn (if any isUnLiftedType zonked_mono_id_types then -- Unlifted bindings must be non-recursive, -- not top level, and non-polymorphic - checkTc (case top_lvl of {TopLevel -> False; NotTopLevel -> True}) + checkTc (isNotTopLevel top_lvl) (unliftedBindErr "Top-level" mbind) `thenTc_` checkTc (case is_rec of {Recursive -> False; NonRecursive -> True}) (unliftedBindErr "Recursive" mbind) `thenTc_` @@ -363,9 +367,18 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn exports = zipWith mk_export binder_names zonked_mono_ids dict_tys = map idType dicts_bound + inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs] + no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++ + [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase]) + -- "INLINE n foo" means inline foo, but not until at least phase n + -- "NOINLINE n foo" means don't inline foo until at least phase n, and even + -- then only if it is small enough etc. + -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing) + -- See comments in CoreUnfold.blackListed for the Authorised Version + mk_export binder_name zonked_mono_id = (tyvars, - setIdInfo poly_id (prag_info_fn binder_name), + attachNoInlinePrag no_inlines poly_id, zonked_mono_id) where (tyvars, poly_id) = @@ -374,7 +387,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn (sig_tyvars, sig_poly_id) Nothing -> (real_tyvars_to_gen_list, new_poly_id) - new_poly_id = mkUserId binder_name poly_ty + new_poly_id = mkVanillaId binder_name poly_ty poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ idType (zonked_mono_id) @@ -396,9 +409,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn -- BUILD RESULTS returnTc ( + -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $ AbsBinds real_tyvars_to_gen_list dicts_bound exports + inlines (dict_binds `andMonoBinds` mbind'), lie_free, [poly_id | (_, poly_id, _) <- exports] @@ -411,6 +426,11 @@ justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds justPatBindings (AndMonoBinds b1 b2) binds = justPatBindings b1 (justPatBindings b2 binds) justPatBindings other_bind binds = binds + +attachNoInlinePrag no_inlines bndr + = case lookupFM no_inlines (idName bndr) of + Just prag -> bndr `setInlinePragma` prag + Nothing -> bndr \end{code} Polymorphic recursion @@ -475,7 +495,7 @@ is doing. %* * %************************************************************************ -@getTyVarsToGen@ decides what type variables generalise over. +@getTyVarsToGen@ decides what type variables to generalise over. For a "restricted group" -- see the monomorphism restriction for a definition -- we bind no dictionaries, and @@ -517,22 +537,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> let - tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars + body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars in if is_unrestricted then - returnNF_Tc (emptyVarSet, tyvars_to_gen) + let fds = getAllFunDepsOfLIE lie in + zonkFunDeps fds `thenNF_Tc` \ fds' -> + let tvFundep = tyVarFunDep fds' + extended_tyvars = oclose tvFundep body_tyvars in + -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $ + returnNF_Tc (emptyVarSet, extended_tyvars) 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 (emptyVarSet, tyvars_to_gen)) $ + recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $ discardErrsTc $ - tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> + tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) -> let -- ASSERT: dicts_sig is already zonked! constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts - reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars + reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars in returnTc (constrained_tyvars, reduced_tyvars_to_gen) \end{code} @@ -609,9 +634,18 @@ tcMonoBinds mbinds tc_ty_sigs is_rec returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids) where - sig_fn name = case maybeSig tc_ty_sigs name of - Nothing -> Nothing - Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id + + -- This function is used when dealing with a LHS binder; we make a monomorphic + -- version of the Id. We check for type signatures + tc_pat_bndr name pat_ty + = case maybeSig tc_ty_sigs name of + Nothing + -> newLocalId (getOccName name) pat_ty (getSrcLoc name) + + Just (TySigInfo _ _ _ _ _ mono_id _ _) + -> tcAddSrcLoc (getSrcLoc name) $ + unifyTauTy (idType mono_id) pat_ty `thenTc_` + returnTc mono_id mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of Nothing -> (name, mono_id) @@ -636,7 +670,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec tc_mb_pats (FunMonoBind name inf matches locn) = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty -> - tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id -> + tc_pat_bndr name bndr_ty `thenTc` \ bndr_id -> let complete_it xve = tcAddSrcLoc locn $ tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) -> @@ -664,7 +698,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- We don't check explicitly for this problem. Instead, we simply -- type check the pattern with tcPat. If the pattern mentions any -- fresh tyvars we simply get an out-of-scope type variable error - tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> + tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) -> let complete_it xve = tcAddSrcLoc locn $ tcAddErrCtxt (patMonoBindsCtxt bind) $ @@ -692,17 +726,24 @@ now (ToDo). \begin{code} checkSigMatch top_lvl binder_names mono_ids sigs | main_bound_here - = mapTc check_one_sig sigs `thenTc_` - mapTc check_main_ctxt sigs `thenTc_` - - -- Now unify the main_id with IO t, for any old t + = -- First unify the main_id with IO t, for any old t tcSetErrCtxt mainTyCheckCtxt ( tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> unifyTauTy ((mkTyConApp ioTyCon [t_tv])) (idType main_mono_id) ) `thenTc_` - returnTc (Just ([], emptyLIE)) + + -- Now check the signatures + -- Must do this after the unification with IO t, + -- in case of a silly signature like + -- main :: forall a. a + -- The unification to IO t will bind the type variable 'a', + -- which is just waht check_one_sig looks for + mapTc check_one_sig sigs `thenTc_` + mapTc check_main_ctxt sigs `thenTc_` + + returnTc (Just ([], emptyLIE)) | not (null sigs) = mapTc check_one_sig sigs `thenTc_` @@ -753,7 +794,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs = tcAddSrcLoc src_loc $ checkTc (null theta) (mainContextsErr id) - mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta] + mk_dict_tys theta = map mkPredTy theta sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"), nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)] @@ -773,28 +814,13 @@ checkSigMatch top_lvl binder_names mono_ids sigs %* * %************************************************************************ - -@tcPragmaSigs@ munches up the "signatures" that arise through *user* +@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user* pragmas. It is convenient for them to appear in the @[RenamedSig]@ part of a binding because then the same machinery can be used for moving them into place as is done for type signatures. -\begin{code} -tcPragmaSigs :: [RenamedSig] -- The pragma signatures - -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo - TcMonoBinds, - LIE) +They look like this: -tcPragmaSigs sigs - = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) -> - let - prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name] - in - returnTc (prag_fn, andMonoBindList binds, plusLIEs lies) -\end{code} - -The interesting case is for SPECIALISE pragmas. There are two forms. -Here's the first form: \begin{verbatim} f :: Ord a => [a] -> b -> b {-# SPECIALIZE f :: [Int] -> b -> b #-} @@ -817,42 +843,15 @@ specialiser will subsequently discover that there's a call of @f@ at Int, and will create a specialisation for @f@. After that, the binding for @f*@ can be discarded. -The second form is this: -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b = g #-} -\end{verbatim} - -Here @g@ is specified as a function that implements the specialised -version of @f@. Suppose that g has type (a->b->b); that is, g's type -is more general than that required. For this we generate -\begin{verbatim} - f@Int = /\b -> g Int b - f* = f@Int -\end{verbatim} - -Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits -f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves -to prevent @f@@Int@ from being discarded prematurely. After specialisation, -if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can -discard the f* binding. - -Actually, there is really only point in giving a SPECIALISE pragma on exported things, -and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is -a bit of overkill. +We used to have a form + {-# SPECIALISE f :: = g #-} +which promised that g implemented f at , but we do that with +a RULE now: + {-# SPECIALISE (f:: TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds, LIE) -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 IMustNotBeINLINEd), EmptyMonoBinds, emptyLIE) - -tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) +tcSpecSigs :: [RenamedSig] -> TcM s (TcMonoBinds, LIE) +tcSpecSigs (SpecSig name poly_ty src_loc : sigs) = -- SPECIALISE f :: forall b. theta => tau = g tcAddSrcLoc src_loc $ tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ @@ -864,41 +863,21 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- the spec-pragma-id at the same time tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) -> - 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 spec_id spec_expr, spec_lie) - - Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo - - panic "Can't handle SPECIALISE with a '= g' part" - - {- 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. - - For now we just leave out this case - - -- Get the type of f, and find out what types - -- f has to be instantiated at to give the signature type - tcLookupValue name `thenNF_Tc` \ f_id -> - tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) -> - - let - (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty - (f_theta, f_tau) = splitRhoTy f_rho - sig_tyvar_set = mkVarSet sig_tyvars - in - unifyTauTy sig_tau f_tau `thenTc_` - - tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _, - -} - -tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $ - returnTc (Nothing, EmptyMonoBinds, emptyLIE) + -- Squeeze out any Methods (see comments with tcSimplifyToDicts) + tcSimplifyToDicts spec_lie `thenTc` \ (spec_lie1, spec_binds) -> + + -- 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 -> + + -- Do the rest and combine + tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) -> + returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr), + lie_rest `plusLIE` spec_lie1) + +tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs +tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE) \end{code} @@ -954,10 +933,12 @@ sigContextsCtxt s1 s2 mainContextsErr id | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded") | otherwise - = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main") + = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal + ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings. mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")] + = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME), + ptext SLIT("has the required type")] ----------------------------------------------- unliftedBindErr flavour mbind