[commit: ghc] master: Fix accidental breakage in T7050 (72b5f64)

[git at git.haskell.org]

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

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

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

commit 72b5f649ede82ab3bb429aa72ee1c572f415b0eb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 3 09:06:49 2018 +0100

    Fix accidental breakage in T7050
    
    I introduced a silly bug in
    
      commit 9187d5fb1d3d38a4e607b0d61784c21447c8195b
      Date:   Mon Apr 2 14:55:43 2018 +0100
    
      Allow unpacking of single-data-con GADTs
    
    that made test T7050 diverge.  This patch fixes it.


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

72b5f649ede82ab3bb429aa72ee1c572f415b0eb
 compiler/basicTypes/MkId.hs | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 27e9f2b..7e55520 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -880,26 +880,32 @@ isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
 -- end up relying on ourselves!
 isUnpackableType dflags fam_envs ty
   | Just data_con <- unpackable_type ty
-  = ok_con_args (unitNameSet (getName data_con)) data_con
+  = ok_con_args emptyNameSet data_con
   | otherwise
   = False
   where
     ok_con_args dcs con
-       = all (ok_arg dcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
-         -- NB: dataConSrcBangs gives the *user* request;
-         -- We'd get a black hole if we used dataConImplBangs
-
-    ok_arg dcs (ty, bang) = not (attempt_unpack bang) || ok_ty dcs norm_ty
-        where
-          norm_ty = topNormaliseType fam_envs ty
+       | dc_name `elemNameSet` dcs
+       = False
+       | otherwise
+       = all (ok_arg dcs')
+             (dataConOrigArgTys con `zip` dataConSrcBangs con)
+          -- NB: dataConSrcBangs gives the *user* request;
+          -- We'd get a black hole if we used dataConImplBangs
+       where
+         dc_name = getName con
+         dcs' = dcs `extendNameSet` dc_name
+
+    ok_arg dcs (ty, bang)
+      = not (attempt_unpack bang) || ok_ty dcs norm_ty
+      where
+        norm_ty = topNormaliseType fam_envs ty
 
     ok_ty dcs ty
       | Just data_con <- unpackable_type ty
-      , let dc_name = getName data_con
-      , not (dc_name `elemNameSet` dcs)
-      = ok_con_args (dcs `extendNameSet` dc_name) data_con
+      = ok_con_args dcs data_con
       | otherwise
-      = True        -- NB True here, in constrast to False at top level
+      = True        -- NB True here, in contrast to False at top level
 
     attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
       = xopt LangExt.StrictData dflags