import FamInstEnv
import TcDeriv
import TcEnv
-import RnEnv ( lookupGlobalOccRn )
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
--- import CoreUtils ( mkPiTypes )
-import PrelNames ( inlineIdName )
+import CoreSyn ( Expr(Var) )
import Id
import MkId
import Name
df :: forall a. C a => C [a]
{-# NOINLINE df DFun[ $cop_list ] #-}
- df = /\a. \d. MkD ($cop_list a d)
+ df = /\a. \d. MkC ($cop_list a d)
- $cop_list :: forall a. C a => a -> a
+ $cop_list :: forall a. C a => [a] -> [a]
$cop_list = <blah>
-The "constructor" MkD expands to a cast, as does the class-op selector.
+The "constructor" MkC expands to a cast, as does the class-op selector.
The RULE works just like for multi-field dictionaries:
- * (df a d) returns (Just (MkD,..,[$cop_list a d]))
+
+ * (df a d) returns (Just (MkC,..,[$cop_list a d]))
to exprIsConApp_Maybe
* The RULE for op picks the right result
is otherwise used only when we hit a case expression which will have
a real data constructor in it.
-The biggest reason for doing it this way, apart form uniformity, is
+The biggest reason for doing it this way, apart from uniformity, is
that we want to be very careful when we have
instance C a => C [a] where
{-# INLINE op #-}
op = ...
-then we'll get an INLINE pragma on $cop_list. The danger is that
-we'll get something like
- foo = /\a.\d. $cop_list a d
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument
+
+The danger is that we'll get something like
+ op_list :: C a => [a] -> [a]
+ op_list = /\a.\d. $cop_list a d
and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
-Trac #3772 and I spent far too long fiddling arond trying to fix it.
+Trac #3772 and I spent far too long fiddling around trying to fix it.
Look at the test for Trac #3772.
+ (Note: re-reading the above, I can't see how using the
+ uniform story solves the problem.)
+
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
-- round)
-- (1) Do class and family instance declarations
- ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
+ ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+ filter (isFamInstDecl . unLoc) tycl_decls
; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
- ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
- ; aux_binds = mkAuxBinds at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons
}
-- (2) Add the tycons of indexed types and their implicit
-- Next, construct the instance environment so far, consisting
-- of
- -- a) local instance decls
- -- b) generic instances
- -- c) local family instance decls
+ -- (a) local instance decls
+ -- (b) generic instances
+ -- (c) local family instance decls
; addInsts local_info $
addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
generic_inst_info ++ deriv_inst_info ++ local_info,
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,
- -- too.
- tcIdxTyInstDeclTL ldecl@(L loc decl) =
- do { tything <- tcFamInstDecl ldecl
- ; setSrcSpan loc $
- when (isAssocFamily tything) $
- addErr $ assocInClassErr (tcdName decl)
- ; return tything
- }
- isAssocFamily (ATyCon tycon) =
- case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
- isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name =
- ptext (sLit "Associated type") <+> quotes (ppr name) <+>
- ptext (sLit "must be inside a class instance")
addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-- Now, check the validity of the instance.
- ; (clas, inst_tys) <- checkValidInstHead tau
- ; checkValidInstance tyvars theta clas inst_tys
+ ; (clas, inst_tys) <- checkValidInstance poly_ty tyvars theta tau
-- Next, process any associated types.
; idx_tycons <- recoverM (return []) $
- do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
+ do { idx_tycons <- checkNoErrs $
+ mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
; checkValidAndMissingATs clas (tyvars, inst_tys)
(zip ats idx_tycons)
; return idx_tycons }
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
- -> TcM (LHsBinds Id, TcLclEnv)
+ -> TcM (LHsBinds Id)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
tcInstDecls2 tycl_decls inst_decls
= do { -- (a) Default methods from class decls
let class_decls = filter (isClassDecl . unLoc) tycl_decls
- ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls
+ ; dm_binds_s <- mapM tcClassDecl2 class_decls
+ ; let dm_binds = unionManyBags dm_binds_s
- ; tcExtendIdEnv (concat dm_ids_s) $ do
-
-- (b) instance declarations
- { inst_binds_s <- mapM tcInstDecl2 inst_decls
+ ; let dm_ids = collectHsBindsBinders dm_binds
+ -- Add the default method Ids (again)
+ -- See Note [Default methods and instances]
+ ; inst_binds_s <- tcExtendIdEnv dm_ids $
+ mapM tcInstDecl2 inst_decls
-- Done
- ; let binds = unionManyBags dm_binds_s `unionBags`
- unionManyBags inst_binds_s
- ; tcl_env <- getLclEnv -- Default method Ids in here
- ; return (binds, tcl_env) } }
+ ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
loc = getSrcSpan dfun_id
\end{code}
+See Note [Default methods and instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
+don't have their InlinePragmas yet. Usually that would not matter,
+because the simplifier propagates information from binding site to
+use. But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
+
+So right here in tcInstDecl2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas. Urk.
\begin{code}
tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
-- If there are no superclasses, matters are simpler, because we don't need the case
-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-tc_inst_decl2 dfun_id (NewTypeDerived coi)
+tc_inst_decl2 dfun_id (NewTypeDerived coi _)
= do { let rigid_info = InstSkol
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
; return (unitBag $ noLoc $
AbsBinds inst_tvs' (map instToVar dfun_dicts)
- [(inst_tvs', dfun_id, instToId this_dict, [])]
+ [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)]
(dict_bind `consBag` sc_binds)) }
where
-----------------------
-- Ordinary instances
tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
- = do { let rigid_info = InstSkol
- inst_ty = idType dfun_id
- loc = getSrcSpan dfun_id
+ = do { let rigid_info = InstSkol
+ inst_ty = idType dfun_id
+ loc = getSrcSpan dfun_id
-- Instantiate the instance decl with skolem constants
; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
-- Typecheck the methods
- ; let prag_fn = mkPragFun uprags
+ ; let prag_fn = mkPragFun uprags monobinds
tc_meth = tcInstanceMethod loc standalone_deriv
clas inst_tyvars'
dfun_dicts inst_tys'
; let dict_constr = classDataCon clas
this_dict_id = instToId this_dict
dict_bind = mkVarBind this_dict_id dict_rhs
- dict_rhs = foldl mk_app inst_constr (sc_ids ++ meth_ids)
+ dict_rhs = foldl mk_app inst_constr sc_meth_ids
+ sc_meth_ids = sc_ids ++ meth_ids
inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun = dfun_id
- `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+ `setIdUnfolding` mkDFunUnfolding inst_ty (map Var sc_meth_ids)
`setInlinePragma` dfunInlinePragma
main_bind = AbsBinds
inst_tyvars'
dfun_lam_vars
- [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
+ [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)]
(unitBag dict_bind)
; showLIE (text "instance")
sc_id = instToVar sc_dict
sc_op_bind = AbsBinds tyvars
(map instToVar dicts)
- [(tyvars, sc_op_id, sc_id, [])]
+ [(tyvars, sc_op_id, sc_id, noSpecPrags)]
(this_bind `unionBags` sc_binds)
; return (sc_op_id, noLoc sc_op_bind) }
The "it turns out" bit is delicate, but it works fine!
\begin{code}
-tcSpecInst :: Id -> Sig Name -> TcM SpecPrag
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
= addErrCtxt (spec_ctxt prag) $
do { let name = idName dfun_id
-> [TcType]
-> (Inst, LHsBinds Id) -- "This" and its binding
-> TcPragFun -- Local prags
- -> [LSpecPrag] -- Arising from 'SPECLALISE instance'
+ -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance'
-> LHsBinds Name
-> (Id, DefMeth)
-> TcM (Id, LHsBind Id)
tc_body rn_bind
= add_meth_ctxt rn_bind $
do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True
- meth_id (prag_fn sel_name)
- ; tcInstanceMethodBody (instLoc this_dict)
+ meth_id (prag_fn sel_name)
+ ; bind <- tcInstanceMethodBody (instLoc this_dict)
tyvars dfun_dicts
([this_dict], this_dict_bind)
meth_id1 local_meth_id
meth_sig_fn
- (spec_inst_prags ++ spec_prags)
- rn_bind }
+ (SpecPrags (spec_inst_prags ++ spec_prags))
+ rn_bind
+ ; return (meth_id1, bind) }
--------------
tc_default :: DefMeth -> TcM (Id, LHsBind Id)
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
; tc_body meth_bind }
- tc_default DefMeth -- An polymorphic default method
+ tc_default (DefMeth dm_name) -- An polymorphic default method
= do { -- Build the typechecked version directly,
-- without calling typecheck_method;
-- see Note [Default methods in instances]
-- in $dm inst_tys this
-- The 'let' is necessary only because HsSyn doesn't allow
-- you to apply a function to a dictionary *expression*.
- dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
- -- Might not be imported, but will be an OrigName
+
; dm_id <- tcLookupId dm_name
- ; inline_id <- tcLookupId inlineIdName
; let dm_inline_prag = idInlinePragma dm_id
- dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
- HsVar dm_id
- rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods]
- = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id)))
- (L loc dm_app)
- | otherwise = dm_app
+ rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
+ HsVar dm_id
meth_bind = L loc $ VarBind { var_id = local_meth_id
, var_rhs = L loc rhs
-- method to this version. Note [INLINE and default methods]
bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars
- , abs_exports = [( tyvars, meth_id1
- , local_meth_id, spec_inst_prags)]
+ , abs_exports = [( tyvars, meth_id1, local_meth_id
+ , SpecPrags spec_inst_prags)]
, abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
-- Default methods in an instance declaration can't have their own
-- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
$dmfoo :: forall v x. Baz v x => x -> x
$dmfoo y = <blah>
-Notice that the type is ambiguous. That's fine, though. The instance decl generates
+Notice that the type is ambiguous. That's fine, though. The instance
+decl generates
$dBazIntInt = MkBaz fooIntInt
fooIntInt = $dmfoo Int Int $dBazIntInt
Note [INLINE and default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We *copy* any INLINE pragma from the default method to the instance.
-Example:
+Default methods need special case. They are supposed to behave rather like
+macros. For exmample
+
class Foo a where
op1, op2 :: Bool -> a -> a
op1 b x = op2 (not b) x
instance Foo Int where
+ -- op1 via default method
op2 b x = <blah>
+
+The instance declaration should behave
+
+ just as if 'op1' had been defined with the
+ code, and INLINE pragma, from its original
+ definition.
+
+That is, just as if you'd written
+
+ instance Foo Int where
+ op2 b x = <blah>
+
+ {-# INLINE op1 #-}
+ op1 b x = op2 (not b) x
+
+So for the above example we generate:
-Then we generate:
{-# INLINE $dmop1 #-}
+ -- $dmop1 has an InlineCompulsory unfolding
$dmop1 d b x = op2 d (not b) x
$fFooInt = MkD $cop1 $cop2
{-# INLINE $cop1 #-}
- $cop1 = inline $dmop1 $fFooInt
+ $cop1 = $dmop1 $fFooInt
$cop2 = <blah>
-Note carefully:
- a) We copy $dmop1's inline pragma to $cop1. Otherwise
- we'll just inline the former in the latter and stop, which
- isn't what the user expected
-
- b) We use the magic 'inline' Id to ensure that $dmop1 really is
- inlined in $cop1, even though
- (i) the latter itself has an INLINE pragma
- (ii) $dmop1 is not saturated
- That is important to allow the mutual recursion between $fooInt and
- $cop1 to be broken
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+ instance $cop1. Otherwise we'll just inline the former in the
+ latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an
+ unfolding with an InlineCompulsory source. That means
+ that it'll be inlined at every use site, notably in
+ each instance declaration, such as $cop1. This inlining
+ must happen even though
+ a) $dmop1 is not saturated in $cop1
+ b) $cop1 itself has an INLINE pragma
+
+ It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+ recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+ (which makes the Unfoldings), we use the IsDefaultMethod constructor
+ in TcSpecPrags.
%************************************************************************
projects / ghc-hetmet.git / blobdiff