X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=b52ef1ff22e5f6a0ccf9f00a295f9cb5669861b7;hb=6c872fff42025a842e8500ddbb13fdcca60eaf75;hp=a3177a29bda27a9662eb1b875c8b53ce800ff6f1;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a3177a2..b52ef1f 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -16,19 +16,21 @@ 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, newLocalId, tcLookupTyCon, tcGetGlobalTyVars, tcExtendGlobalTyVars ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) -import TcMonoType ( tcHsType, checkSigTyVars, +import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) +import TcImprove ( tcImprove ) +import TcMonoType ( tcHsSigType, checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) import TcPat ( tcPat ) @@ -44,20 +46,22 @@ import PrelInfo ( main_NAME, ioTyCon_NAME ) import Id ( Id, mkVanillaId, setInlinePragma ) import Var ( idType, idName ) -import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) ) +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(..), isNotTopLevel ) +import FiniteMap ( listToFM, lookupFM ) import SrcLoc ( SrcLoc ) import Outputable \end{code} @@ -249,6 +253,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- (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 @@ -278,8 +290,9 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- 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 || not is_unrestricted) then + -- No polymorphism, and no IPs, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) else case maybe_sig_theta of @@ -288,7 +301,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- 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) -> @@ -354,8 +367,14 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec 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 = mkNameSet [name | NoInlineSig name loc <- inline_sigs] + 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, @@ -390,6 +409,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- 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 @@ -408,8 +428,9 @@ justPatBindings (AndMonoBinds b1 b2) binds = justPatBindings other_bind binds = binds attachNoInlinePrag no_inlines bndr - | idName bndr `elemNameSet` no_inlines = bndr `setInlinePragma` IMustNotBeINLINEd - | otherwise = bndr + = case lookupFM no_inlines (idName bndr) of + Just prag -> bndr `setInlinePragma` prag + Nothing -> bndr \end{code} Polymorphic recursion @@ -474,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 @@ -516,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} @@ -768,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)] @@ -831,12 +857,15 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type - tcHsType poly_ty `thenTc` \ sig_ty -> + tcHsSigType poly_ty `thenTc` \ sig_ty -> -- 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) -> + -- 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. @@ -844,8 +873,8 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) -- Do the rest and combine tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) -> - returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id spec_expr, - lie_rest `plusLIE` spec_lie) + 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)