[commit: ghc] master: When doing UNPACK pragmas, be careful to only unpack *data* types not newtypes (152e703)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/152e70329b359eb1451c063f84a85243cc4e4a26

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

commit 152e70329b359eb1451c063f84a85243cc4e4a26
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Jan 15 14:52:24 2013 +0000

    When doing UNPACK pragmas, be careful to only unpack *data* types not newtypes
    
    This was breaking tc226, following UNPACK-pragma reorg

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

 compiler/basicTypes/MkId.lhs |   15 +++++++++------
 compiler/types/TyCon.lhs     |   10 +++++++++-
 2 files changed, 18 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 375e731..e599503 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -599,10 +599,10 @@ dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
 dataConArgRep dflags fam_envs arg_ty 
     (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-          -- Don't unpack if we aren't optimising; 
-          -- rather arbitrarily, we use -fomit-iface-pragmas
-          -- as the indication
+          -- Don't unpack if we aren't optimising; rather arbitrarily, 
+          -- we use -fomit-iface-pragmas as the indication
   , let mb_co   = topNormaliseType fam_envs arg_ty
+                     -- Unwrap type families and newtypes
         arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
   , isUnpackableType fam_envs arg_ty'
   , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
@@ -670,7 +670,10 @@ dataConArgUnpack
 
 dataConArgUnpack arg_ty
   | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
-  , Just con <- tyConSingleDataCon_maybe tc
+  , Just con <- tyConSingleAlgDataCon_maybe tc
+      -- NB: check for an *algebraic* data type
+      -- A recursive newtype might mean that 
+      -- 'arg_ty' is a newtype
   , let rep_tys = dataConInstArgTys con tc_args
   = ASSERT( isVanillaDataCon con )
     ( rep_tys `zip` dataConRepStrictness con
@@ -698,7 +701,7 @@ isUnpackableType :: FamInstEnvs -> Type -> Bool
 -- end up relying on ourselves!
 isUnpackableType fam_envs ty
   | Just (tc, _) <- splitTyConApp_maybe ty
-  , Just con <- tyConSingleDataCon_maybe tc
+  , Just con <- tyConSingleAlgDataCon_maybe tc
   , isVanillaDataCon con
   = ok_con_args (unitNameSet (getName tc)) con
   | otherwise
@@ -713,7 +716,7 @@ isUnpackableType fam_envs ty
       | Just (tc, _) <- splitTyConApp_maybe ty
       , let tc_name = getName tc
       =  not (tc_name `elemNameSet` tcs)
-      && case tyConSingleDataCon_maybe tc of
+      && case tyConSingleAlgDataCon_maybe tc of
             Just con | isVanillaDataCon con
                     -> ok_con_args (tcs `addOneToNameSet` getName tc) con
             _ -> True
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 5286617..0bce4db 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -56,7 +56,8 @@ module TyCon(
         tyConUnique,
         tyConTyVars,
         tyConCType, tyConCType_maybe,
-        tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe,
+        tyConDataCons, tyConDataCons_maybe, 
+        tyConSingleDataCon_maybe, tyConSingleAlgDataCon_maybe,
         tyConFamilySize,
         tyConStupidTheta,
         tyConArity,
@@ -1380,6 +1381,13 @@ tyConSingleDataCon_maybe (TupleTyCon {dataCon = c})                            =
 tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c
 tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }})     = Just c
 tyConSingleDataCon_maybe _                                                     = Nothing
+
+tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon
+-- Returns (Just con) for single-constructor *algebraic* data types
+-- *not* newtypes
+tyConSingleAlgDataCon_maybe (TupleTyCon {dataCon = c})                            = Just c
+tyConSingleAlgDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c
+tyConSingleAlgDataCon_maybe _                                                     = Nothing
 \end{code}
 
 \begin{code}