[commit: ghc] master: Fix bogus worker for newtypes (a5373c1)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/a5373c1fe172dee31e07bcb7c7f6caff1035e6ba/ghc

>---------------------------------------------------------------

commit a5373c1fe172dee31e07bcb7c7f6caff1035e6ba
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jan 16 16:34:24 2019 +0000

    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.


>---------------------------------------------------------------

a5373c1fe172dee31e07bcb7c7f6caff1035e6ba
 compiler/basicTypes/MkId.hs | 43 ++++++++++++++++++++++---------------------
 1 file changed, 22 insertions(+), 21 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 17916cf..3e70fdb 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