X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=cf03e7116b838f1afacdef20d5b19e4d7be6052b;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hp=177a16f1a2d57a4d43d86364d14f0102eab61458;hpb=9b69d74f05582ccf140c007128a52274aa49bd65;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 177a16f..cf03e71 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -22,6 +22,7 @@ import FamInstEnv import TcDeriv import TcEnv import RnEnv ( lookupGlobalOccRn ) +import RnSource ( addTcgDUs ) import TcHsType import TcUnify import TcSimplify @@ -138,7 +139,7 @@ Running example: inline df_i in it, and that in turn means that (since it'll be a loop-breaker because df_i isn't), op1_i will ironically never be inlined. We need to fix this somehow -- perhaps allowing inlining - of INLINE funcitons inside other INLINE functions. + of INLINE functions inside other INLINE functions. Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -321,14 +322,15 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons - ; at_idx_tycon = concat at_tycons_s ++ idx_tycons + ; at_idx_tycons = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls - ; implicit_things = concatMap implicitTyThings at_idx_tycon + ; implicit_things = concatMap implicitTyThings at_idx_tycons + ; aux_binds = mkAuxBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do { + ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { -- (3) Instances from generic class declarations ; generic_inst_info <- getGenericInstances clas_decls @@ -338,9 +340,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- a) local instance decls -- b) generic instances -- c) local family instance decls - ; addInsts local_info $ do { - ; addInsts generic_inst_info $ do { - ; addFamInsts at_idx_tycon $ do { + ; addInsts local_info $ + addInsts generic_inst_info $ + addFamInsts at_idx_tycons $ do { -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance @@ -350,15 +352,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, becuase that may give -- more errors still - ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls - deriv_decls - ; addInsts deriv_inst_info $ do { - - ; gbl_env <- getGblEnv - ; return (gbl_env, + ; (deriv_inst_info, deriv_binds, deriv_dus) + <- tcDeriving tycl_decls inst_decls deriv_decls + ; gbl_env <- addInsts deriv_inst_info getGblEnv + ; return ( addTcgDUs gbl_env deriv_dus, generic_inst_info ++ deriv_inst_info ++ local_info, - deriv_binds) - }}}}}} + aux_binds `plusHsValBinds` deriv_binds) + }}} where -- Make sure that toplevel type instance are not for associated types. -- !!!TODO: Need to perform this check for the TyThing of type functions, @@ -611,22 +611,35 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) (class_tyvars, sc_theta, _, _) = classBigSig cls cls_tycon = classTyCon cls sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta - Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys - (nt_tycon, tc_args) = tcSplitTyConApp last_ty -- Can't fail - rep_ty = newTyConInstRhs nt_tycon tc_args - rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty]) - -- In our example, rep_pred is (Foo Int (Tree [a])) - the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args - -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a) + (rep_ty, wrapper) + = case coi of + IdCo -> (last_ty, idHsWrapper) + ACo co -> (snd (coercionKind co), WpCast (mk_full_coercion co)) + + ----------------------- + -- mk_full_coercion + -- The inst_head looks like (C s1 .. sm (T a1 .. ak)) + -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak))) + -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm ) + -- where rep_ty is the (eta-reduced) type rep of T + -- So we just replace T with CoT, and insert a 'sym' + -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced + + mk_full_coercion co = mkTyConApp cls_tycon + (initial_cls_inst_tys ++ [mkSymCoercion co]) + -- Full coercion : (Foo Int (Tree [a]) ~ Foo Int (N a) + + rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty]) + -- In our example, rep_pred is (Foo Int (Tree [a])) ; sc_loc <- getInstLoc InstScOrigin ; sc_dicts <- newDictBndrs sc_loc sc_theta' ; inst_loc <- getInstLoc origin ; dfun_dicts <- newDictBndrs inst_loc theta - ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) ; rep_dict <- newDictBndr inst_loc rep_pred + ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) -- Figure out bindings for the superclass context from dfun_dicts -- Don't include this_dict in the 'givens', else @@ -639,7 +652,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) -- in the envt with one of the clas_tyvars ; checkSigTyVars inst_tvs' - ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict) + ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) @@ -650,22 +663,6 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) (dict_bind `consBag` sc_binds)) } where ----------------------- - -- make_coercion - -- The inst_head looks like (C s1 .. sm (T a1 .. ak)) - -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak))) - -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm ) - -- where rep_ty is the (eta-reduced) type rep of T - -- So we just replace T with CoT, and insert a 'sym' - -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced - - make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args - | Just co_con <- newTyConCo_maybe nt_tycon - , let co = mkSymCoercion (mkTyConApp co_con tc_args) - = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co])) - | otherwise -- The newtype is transparent; no need for a cast - = idHsWrapper - - ----------------------- -- (make_body C tys scs coreced_rep_dict) -- returns -- (case coerced_rep_dict of { C _ ops -> C scs ops }) @@ -720,11 +717,12 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) origin = SigOrigin rigid_info -- Create dictionary Ids from the specified instance contexts. - ; sc_loc <- getInstLoc InstScOrigin - ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted - ; inst_loc <- getInstLoc origin - ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities - ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + ; sc_loc <- getInstLoc InstScOrigin + ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + ; inst_loc <- getInstLoc origin + ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities + ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. @@ -758,7 +756,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) -- Create the result bindings ; let dict_constr = classDataCon clas inline_prag | null dfun_dicts = [] - | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] + | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))] -- 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 @@ -862,7 +860,7 @@ tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys (Nothing, NoDefMeth) -> do -- No default method in the class { warn <- doptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods - && reportIfUnused (getOccName sel_id)) + && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods omitted_meth_warn ; return (error_rhs, emptyBag) }