Introduce CPR for sum types (Trac #5075)

The main payload of this patch is to extend CPR so that it
detects when a function always returns a result constructed
with the *same* constructor, even if the constructor comes from
a sum type.  This doesn't matter very often, but it does improve
some things (results below).

Binary sizes increase a little bit, I think because there are more
wrappers.  This with -split-objs.  Without split-ojbs binary sizes
increased by 6% even for HelloWorld.hs.  It's hard to see exactly why,
but I think it was because System.Posix.Types.o got included in the
linked binary, whereas it didn't before.

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
          fluid          +1.8%     -0.3%      0.01      0.01     +0.0%
            tak          +2.2%     -0.2%      0.02      0.02     +0.0%
           ansi          +1.7%     -0.3%      0.00      0.00     +0.0%
      cacheprof          +1.6%     -0.3%     +0.6%     +0.5%     +1.4%
        parstof          +1.4%     -4.4%      0.00      0.00     +0.0%
        reptile          +2.0%     +0.3%      0.02      0.02     +0.0%
----------------------------------------------------------------------
            Min          +1.1%     -4.4%     -4.7%     -4.7%    -15.0%
            Max          +2.3%     +0.3%     +8.3%     +9.4%    +50.0%
 Geometric Mean          +1.9%     -0.1%     +0.6%     +0.7%     +0.3%

Other things in this commit
~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Got rid of the Lattice class in Demand

* Refactored the way that products and newtypes are
  decomposed (no change in functionality)

2 files changed, 44 insertions, 3 deletions

diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index b5e38c8af2..c0f5019457 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -19,6 +19,7 @@ module DsCCall
 	, unboxArg
 	, boxResult
 	, resultWrapper
+        , splitDataProductType_maybe
 	) where
 
 #include "HsVersions.h"
@@ -191,7 +192,7 @@ unboxArg arg
        pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
     arg_ty					= exprType arg
-    maybe_product_type 			   	= splitProductType_maybe arg_ty
+    maybe_product_type 			   	= splitDataProductType_maybe arg_ty
     is_product_type			   	= maybeToBool maybe_product_type
     Just (_, _, data_con, data_con_arg_tys)	= maybe_product_type
     data_con_arity				= dataConSourceArity data_con
@@ -357,7 +358,7 @@ resultWrapper result_ty
 
   -- Data types with a single constructor, which has a single arg
   -- This includes types like Ptr and ForeignPtr
-  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
+  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
     dataConSourceArity data_con == 1
   = do dflags <- getDynFlags
        let
@@ -391,3 +392,43 @@ maybeNarrow dflags tycon
 	 && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
   | otherwise			  = id
 \end{code}
+
+%************************************************************************
+%*									*
+\subsection{Splitting products}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | Extract the type constructor, type argument, data constructor and it's
+-- /representation/ argument types from a type if it is a product type.
+--
+-- Precisely, we return @Just@ for any type that is all of:
+--
+--  * Concrete (i.e. constructors visible)
+--
+--  * Single-constructor
+--
+--  * Not existentially quantified
+--
+-- Whether the type is a @data@ type or a @newtype@
+splitDataProductType_maybe
+	:: Type 			-- ^ A product type, perhaps
+	-> Maybe (TyCon, 		-- The type constructor
+		  [Type],		-- Type args of the tycon
+		  DataCon,		-- The data constructor
+		  [Type])		-- Its /representation/ arg types
+
+	-- Rejecing existentials is conservative.  Maybe some things
+	-- could be made to work with them, but I'm not going to sweat
+	-- it through till someone finds it's important.
+
+splitDataProductType_maybe ty
+  | Just (tycon, ty_args) <- splitTyConApp_maybe ty
+  , Just con <- isDataProductTyCon_maybe tycon
+  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
+  | otherwise
+  = Nothing
+\end{code}
+
+
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index bf06be109f..9be8e96615 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -766,7 +766,7 @@ getPrimTyOf ty
   -- Except for Bool, the types we are interested in have a single constructor
   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
   | otherwise =
-  case splitProductType_maybe rep_ty of
+  case splitDataProductType_maybe rep_ty of
      Just (_, _, data_con, [prim_ty]) ->
         ASSERT(dataConSourceArity data_con == 1)
         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)