import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
- newDicts, tyVarsOfInst, instToId,
+ newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
+ zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
+import TcImprove ( tcImprove )
import TcMonoType ( tcHsType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
mkDictTy, 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}
-- (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
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,
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
%* *
%************************************************************************
-@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
= 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 = concatMap snd (getFunDepsOfLIE 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") NotTopLevel 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}