summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2019-01-16 16:34:24 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-01-22 03:02:20 -0500
commita5373c1fe172dee31e07bcb7c7f6caff1035e6ba (patch)
tree35974465290337a66fd6124066e1c1cfe6401ffa
parent64ce6afa21fadd751e1700af145ab77059abadc6 (diff)
downloadhaskell-a5373c1fe172dee31e07bcb7c7f6caff1035e6ba.tar.gz
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.
-rw-r--r--compiler/basicTypes/MkId.hs43
1 files changed, 22 insertions, 21 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 17916cf068..3e70fdb592 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -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