Commit 9a4c93a5 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Undo the fix for Trac #3772 and do it a new way

The main idea is that I'm now treating a single-method dictionary very
much like a multi-method dictionary.  In particular, it respond to
exprIsConApp_maybe, even though newtypes aren't *really* proper
constructors.

See long comments with Note [Single-method classes] for why
this slight hack is justified.
parent 8ae8c865
...@@ -467,15 +467,11 @@ mkDictSelId no_unf name clas ...@@ -467,15 +467,11 @@ mkDictSelId no_unf name clas
-- becuase we use that to generate a top-level binding -- becuase we use that to generate a top-level binding
-- for the ClassOp -- for the ClassOp
info | new_tycon = base_info info = base_info `setSpecInfo` mkSpecInfo [rule]
-- For newtype dictionaries, just inline the class op
-- See Note [Single-method classes] in TcInstDcls
| otherwise = base_info
`setSpecInfo` mkSpecInfo [rule]
`setInlinePragInfo` neverInlinePragma `setInlinePragInfo` neverInlinePragma
-- Otherwise add a magic BuiltinRule, and never inline it -- Add a magic BuiltinRule, and never inline it
-- so that the rule is always available to fire. -- so that the rule is always available to fire.
-- See Note [ClassOp/DFun selection] in TcInstDcls -- See Note [ClassOp/DFun selection] in TcInstDcls
n_ty_args = length tyvars n_ty_args = length tyvars
......
...@@ -33,7 +33,7 @@ import DataCon ...@@ -33,7 +33,7 @@ import DataCon
import Class import Class
import Var import Var
import CoreUnfold ( mkDFunUnfolding ) import CoreUnfold ( mkDFunUnfolding )
import CoreUtils ( mkPiTypes ) -- import CoreUtils ( mkPiTypes )
import PrelNames ( inlineIdName ) import PrelNames ( inlineIdName )
import Id import Id
import MkId import MkId
...@@ -180,8 +180,8 @@ Instead we use a cunning trick. ...@@ -180,8 +180,8 @@ Instead we use a cunning trick.
Note [Single-method classes] Note [Single-method classes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the class has just one method (or, more accurately, just one elemen If the class has just one method (or, more accurately, just one element
of {superclasses + methods}), then we want a different strategy. of {superclasses + methods}), then we still use the *same* strategy
class C a where op :: a -> a class C a where op :: a -> a
instance C a => C [a] where op = <blah> instance C a => C [a] where op = <blah>
...@@ -194,34 +194,39 @@ a top-level axiom: ...@@ -194,34 +194,39 @@ a top-level axiom:
op :: forall a. C a -> (a -> a) op :: forall a. C a -> (a -> a)
op a d = d |> (Co:C a) op a d = d |> (Co:C a)
MkC :: forall a. (a->a) -> C a
MkC = /\a.\op. op |> (sym Co:C a)
df :: forall a. C a => C [a] df :: forall a. C a => C [a]
{-# INLINE df #-} {-# NOINLINE df DFun[ $cop_list ] #-}
df = $cop_list |> (forall a. C a -> (sym (Co:C a)) df = /\a. \d. MkD ($cop_list a d)
$cop_list :: forall a. C a => a -> a $cop_list :: forall a. C a => a -> a
$cop_list = <blah> $cop_list = <blah>
So the ClassOp is just a cast; and so is the dictionary function. The "constructor" MkD expands to a cast, as does the class-op selector.
(The latter doesn't even have any lambdas.) We can inline both freely. The RULE works just like for multi-field dictionaries:
No need for fancy BuiltIn rules. Indeed the BuiltinRule stuff does * (df a d) returns (Just (MkD,..,[$cop_list a d]))
not work well for newtypes because it uses exprIsConApp_maybe. to exprIsConApp_Maybe
The INLINE on df is vital, else $cop_list occurs just once and is inlined, * The RULE for op picks the right result
which is a disaster if $cop_list *itself* has an INLINE pragma.
This is a bit of a hack, because (df a d) isn't *really* a constructor
Notice, also, that we go to the trouble of generating a complicated cast, application. But it works just fine in this case, exprIsConApp_maybe
rather than do this: is otherwise used only when we hit a case expression which will have
df = /\a. \d. MkD ($cop_list a d) a real data constructor in it.
where the MkD "constructor" willl expand to a suitable cast:
df = /\a. \d. ($cop_list a d) |> (...) The biggest reason for doing it this way, apart form uniformity, is
Reason: suppose $cop_list has an INLINE pragma. We want to avoid the that we want to be very careful when we have
nasty possibility that we eta-expand df, to get instance C a => C [a] where
df = (/\a \d \x. $cop_list a d x) |> (...) {-# INLINE op #-}
and now $cop_list may get inlined into the df, rather than at op = ...
the actual call site. Of course, eta reduction may get there first, then we'll get an INLINE pragma on $cop_list. The danger is that
but it seems less fragile to generate the Right Thing in the first place. we'll get something like
See Trac #3772. foo = /\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.
Look at the test for Trac #3772.
Note [Subtle interaction of recursion and overlap] Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -768,6 +773,44 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) ...@@ -768,6 +773,44 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
-- something in the envt with one of the inst_tyvars' -- something in the envt with one of the inst_tyvars'
; checkSigTyVars inst_tyvars' ; checkSigTyVars inst_tyvars'
-- Create the result bindings
; 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)
inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- it means that the special cases (e.g. dictionary with only one
-- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
mk_app :: LHsExpr Id -> Id -> LHsExpr Id
mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
-- Do not inline the dfun; instead give it a magic DFunFunfolding
-- 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)
`setInlinePragma` dfunInlinePragma
main_bind = AbsBinds
inst_tyvars'
dfun_lam_vars
[(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)]
(unitBag dict_bind)
; showLIE (text "instance")
; return (unitBag (L loc main_bind) `unionBags`
listToBag meth_binds `unionBags`
listToBag sc_binds)
}
{-
-- Create the result bindings -- Create the result bindings
; let this_dict_id = instToId this_dict ; let this_dict_id = instToId this_dict
arg_ids = sc_ids ++ meth_ids arg_ids = sc_ids ++ meth_ids
...@@ -819,8 +862,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) ...@@ -819,8 +862,7 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
the_meth_id = ASSERT( length arg_ids == 1 ) head arg_ids the_meth_id = ASSERT( length arg_ids == 1 ) head arg_ids
nt_cast = WpCast $ mkPiTypes (inst_tyvars' ++ dfun_lam_vars) $ nt_cast = WpCast $ mkPiTypes (inst_tyvars' ++ dfun_lam_vars) $
mkSymCoercion (mkTyConApp the_nt_co inst_tys') mkSymCoercion (mkTyConApp the_nt_co inst_tys')
} -}
------------------------------ ------------------------------
tcSuperClass :: InstLoc -> [TyVar] -> [Inst] tcSuperClass :: InstLoc -> [TyVar] -> [Inst]
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment