import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
- MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
- andMonoBindList, collectMonoBinders, isClassDecl
+ MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..),
+ andMonoBindList, collectMonoBinders, isClassDecl, toHsType
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
-import TcType ( tcInstType )
+import TcMType ( tcInstType, tcInstTyVars )
+import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe,
+ tyVarsOfTypes, mkClassPred, mkTyVarTy,
+ isTyVarClassPred, inheritablePred
+ )
import Inst ( InstOrigin(..),
newDicts, instToId,
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
- simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
+ simpleInstInfoTy, newDFunName,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
-import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
+import TcMonoType ( tcHsTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
)
+import Subst ( substTy, substTheta )
import DataCon ( classDataCon )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
import Generics ( validGenericInstanceType )
import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
-import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
+import NameSet ( unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
import PprType ( pprClassPred, pprPred )
import TyCon ( TyCon, isSynTyCon )
-import Type ( splitDFunTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy,
- splitForAllTys,
- tyVarsOfTypes, mkClassPred, mkTyVarTy,
- isTyVarClassPred, inheritablePred
- )
import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
+import ForeignCall ( Safety(..) )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
-addInstDFuns dfuns infos
+addInstDFuns inst_env dfuns
= getDOptsTc `thenTc` \ dflags ->
let
- (inst_env', errs) = extendInstEnv dflags dfuns infos
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
in
addErrsTc errs `thenNF_Tc_`
+ traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) `thenTc_`
returnTc inst_env'
+ where
+ pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
\end{code}
\begin{code}
tcAddSrcLoc src_loc $
-- Type-check all the stuff before the "where"
+ traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_`
tcAddErrCtxt (instDeclCtxt poly_ty) (
tcHsSigType poly_ty
) `thenTc` \ poly_ty' ->
let
- (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
+ (tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty'
in
+ traceTc (text "Check validity") `thenTc_`
(case maybe_dfun_name of
Nothing -> -- A source-file instance declaration
checkInstValidity dflags theta clas inst_tys `thenTc_`
-- Make the dfun id and return it
+ traceTc (text "new name") `thenTc_`
newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
returnNF_Tc (True, dfun_name)
returnNF_Tc (False, dfun_name)
) `thenNF_Tc` \ (is_local, dfun_name) ->
+ traceTc (text "Name" <+> ppr dfun_name) `thenTc_`
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
-- For example: instance (C a, C b) => C (a+b) where { binds }
= -- Extract the universally quantified type variables
- tcTyVars (nameSetToList (extractHsTyVars hs_ty))
- (kcHsSigType hs_ty) `thenTc` \ tyvars ->
- tcExtendTyVarEnv tyvars $
+ let
+ sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
+ in
+ tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars ->
-- Type-check the instance type, and check its form
tcHsSigType hs_ty `thenTc` \ inst_ty ->
tcInstDecl2 (InstInfo { iDFunId = dfun_id,
iBinds = monobinds, iPrags = uprags })
= -- Prime error recovery
- recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
- tcAddSrcLoc (getSrcLoc dfun_id) $
+ recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
+ tcAddSrcLoc (getSrcLoc dfun_id) $
+ tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
-- Instantiate the instance decl with tc-style type variables
- tcInstType (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
let
- (clas, inst_tys') = splitDictTy dict_ty'
- origin = InstanceDeclOrigin
+ (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
+ in
+ tcInstTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
+ let
+ inst_tys' = map (substTy tenv) inst_tys
+ dfun_theta' = substTheta tenv dfun_theta
+ origin = InstanceDeclOrigin
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
-- Find any definitions in monobinds that aren't from the class
bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
-
- -- The type variable from the dict fun actually scope
- -- over the bindings. They were gotten from
- -- the original instance declaration
- (inst_tyvars, _) = splitForAllTys (idType dfun_id)
in
-- Check that all the method bindings come from this class
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
+ -- The type variable from the dict fun actually scope
+ -- over the bindings. They were gotten from
+ -- the original instance declaration
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
scs_and_meths = map instToId (sc_dicts ++ meth_insts)
this_dict_id = instToId this_dict
inlines = unitNameSet (idName dfun_id)
+ -- Always inline the dfun; this is an experimental decision
+ -- because it makes a big performance difference sometimes.
+ -- Often it means we can do the method selection, and then
+ -- inline the method as well. Marcin's idea; see comments below.
dict_rhs
| null scs_and_meths
main_bind `AndMonoBinds` prag_binds)
\end{code}
+ ------------------------------
+ Inlining dfuns unconditionally
+ ------------------------------
+
+The code above unconditionally inlines dict funs. Here's why.
+Consider this program:
+
+ test :: Int -> Int -> Bool
+ test x y = (x,y) == (y,x) || test y x
+ -- Recursive to avoid making it inline.
+
+This needs the (Eq (Int,Int)) instance. If we inline that dfun
+the code we end up with is good:
+
+ Test.$wtest =
+ \r -> case ==# [ww ww1] of wild {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True ->
+ case ==# [ww1 ww] of wild1 {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True -> PrelBase.True [];
+ };
+ };
+ Test.test = \r [w w1]
+ case w of w2 {
+ PrelBase.I# ww ->
+ case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+ };
+
+If we don't inline the dfun, the code is not nearly as good:
+
+ (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
+ PrelBase.:DEq tpl1 tpl2 -> tpl2;
+ };
+
+ Test.$wtest =
+ \r [ww ww1]
+ let { y = PrelBase.I#! [ww1]; } in
+ let { x = PrelBase.I#! [ww]; } in
+ let { sat_slx = PrelTup.(,)! [y x]; } in
+ let { sat_sly = PrelTup.(,)! [x y];
+ } in
+ case == sat_sly sat_slx of wild {
+ PrelBase.False -> Test.$wtest ww1 ww;
+ PrelBase.True -> PrelBase.True [];
+ };
+
+ Test.test =
+ \r [w w1]
+ case w of w2 {
+ PrelBase.I# ww ->
+ case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+ };
+
+Why doesn't GHC inline $fEq? Because it looks big:
+
+ PrelTup.zdfEqZ1T{-rcX-}
+ = \ @ a{-reT-} :: * @ b{-reS-} :: *
+ zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
+ zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
+ let {
+ zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
+ zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
+ let {
+ zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
+ zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
+ let {
+ zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+ zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
+ ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
+ case ds{-rf5-}
+ of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
+ case ds1{-rf4-}
+ of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
+ PrelBase.zaza{-r4e-}
+ (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
+ (zeze{-rf0-} a2{-reZ-} b2{-reY-})
+ }
+ } } in
+ let {
+ a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+ a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
+ b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
+ PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
+ } in
+ PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
+
+and it's not as bad as it seems, because it's further dramatically
+simplified: only zeze2 is extracted and its body is simplified.
+
%************************************************************************
%* *
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
| not (length inst_taus == 1 &&
- maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
+ maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor
not (isSynTyCon tycon) && -- ...but not a synonym
- all isTyVarTy arg_tys && -- Applied to type variables
+ all tcIsTyVarTy arg_tys && -- Applied to type variables
length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
-- This last condition checks that all the type variables are distinct
)
(first_inst_tau : _) = inst_taus
-- Stuff for algebraic or -> type
- maybe_tycon_app = splitTyConApp_maybe first_inst_tau
+ maybe_tycon_app = tcSplitTyConApp_maybe first_inst_tau
Just (tycon, arg_tys) = maybe_tycon_app
- ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+ ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty
creturnable_type ty = isFFIImportResultTy dflags ty
check_tyvars dflags clas inst_taus
-- Check that at least one isn't a type variable
-- unless -fallow-undecideable-instances
| dopt Opt_AllowUndecidableInstances dflags = []
- | not (all isTyVarTy inst_taus) = []
+ | not (all tcIsTyVarTy inst_taus) = []
| otherwise = [the_err]
where
the_err = instTypeErr clas inst_taus msg
projects / ghc-hetmet.git / blobdiff