Commit a5373c1f authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Fix bogus worker for newtypes

The "worker" for a newtype is actually a function
with a small (compulsory) unfolding, namely a cast.

But the construction of this function was plain wrong
for newtype /instances/; it cast the arguemnt to the
family type rather than the representation type.

This never actually bit us because, in the case of a
family instance, we immediately cast the result to
the family type.  So we get
   \x. (x |> co1) |> co2

where the compositio of co1 and co2 is ill-kinded.
However the optimiser (even the simple optimiser)
just collapsed those casts, ignoring the mis-match
in the middle, so we never saw the problem.

Trac #16191 is indeed a dup of #16141; but the resaon
these tickets produce Lint errors is not the unnecessary
forcing; it's because of the ill-typed casts.

This patch fixes the ill-typed casts, properly.  I can't
see a way to trigger an actual failure prior to this
patch, but it's still wrong wrong wrong to have ill-typed
casts, so better to get rid of them.
parent 64ce6afa
......@@ -425,26 +425,26 @@ dictSelRule val_index n_ty_args _ id_unf _ args
mkDataConWorkId :: Name -> DataCon -> Id
mkDataConWorkId wkr_name data_con
| isNewTyCon tycon
= mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info
= mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info
| otherwise
= mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info
= mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info
where
tycon = dataConTyCon data_con
tycon = dataConTyCon data_con -- The representation TyCon
wkr_ty = dataConRepType data_con
----------- Workers for data types --------------
alg_wkr_ty = dataConRepType data_con
alg_wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` wkr_ty
-- NB: unboxed tuples have workers, so we can't use
-- setNeverLevPoly
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
`setLevityInfoWithType` alg_wkr_ty
-- NB: unboxed tuples have workers, so we can't use
-- setNeverLevPoly
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
-- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker Id is strict
-- even if the data constructor is declared strict
......@@ -465,20 +465,21 @@ mkDataConWorkId wkr_name data_con
-- not from the worker Id.
----------- Workers for newtypes --------------
(nt_tvs, _, nt_arg_tys, _) = dataConSig data_con
res_ty_args = mkTyCoVarTys nt_tvs
nt_wrap_ty = dataConUserType data_con
univ_tvs = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
`setLevityInfoWithType` nt_wrap_ty
id_arg1 = mkTemplateLocal 1 (head nt_arg_tys)
`setLevityInfoWithType` wkr_ty
id_arg1 = mkTemplateLocal 1 (head arg_tys)
res_ty_args = mkTyCoVarTys univ_tvs
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
isSingleton nt_arg_tys, ppr data_con )
isSingleton arg_tys
, ppr data_con )
-- Note [Newtype datacons]
mkCompulsoryUnfolding $
mkLams nt_tvs $ Lam id_arg1 $
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
dataConCPR :: DataCon -> DmdResult
......
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