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)

19 files changed, 515 insertions, 486 deletions

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index be6a78fdd1..a4fb5590a2 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -26,6 +26,8 @@ types that
 module BasicTypes(
 	Version, bumpVersion, initialVersion,
 
+        ConTag, fIRST_TAG,
+
 	Arity, RepArity,
 	
 	Alignment,
@@ -113,6 +115,21 @@ type RepArity = Int
 
 %************************************************************************
 %*									*
+              Constructor tags
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | Type of the tags associated with each constructor possibility
+type ConTag = Int
+
+fIRST_TAG :: ConTag
+-- ^ Tags are allocated from here for real constructors
+fIRST_TAG =  1
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[Alignment]{Alignment}
 %*									*
 %************************************************************************
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 47e37a9c0e..88b09f3d07 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -41,9 +41,6 @@ module DataCon (
 	isVanillaDataCon, classDataCon, dataConCannotMatch,
         isBanged, isMarkedStrict, eqHsBang,
 
-        -- * Splitting product types
-	splitProductType_maybe, splitProductType, 
-
         -- ** Promotion related functions
         isPromotableTyCon, promoteTyCon, 
         promoteDataCon, promoteDataCon_maybe
@@ -461,13 +458,6 @@ data HsBang
 -- StrictnessMark is internal only, used to indicate strictness 
 -- of the DataCon *worker* fields
 data StrictnessMark = MarkedStrict | NotMarkedStrict	
-
--- | Type of the tags associated with each constructor possibility
-type ConTag = Int
-
-fIRST_TAG :: ConTag
--- ^ Tags are allocated from here for real constructors
-fIRST_TAG =  1
 \end{code}
 
 Note [Data con representation]
@@ -994,56 +984,6 @@ dataConCannotMatch tys con
 \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@
-splitProductType_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.
-
-splitProductType_maybe ty
-  = case splitTyConApp_maybe ty of
-	Just (tycon,ty_args)
-	   | isProductTyCon tycon  	-- Includes check for non-existential,
-					-- and for constructors visible
-	   -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
-	   where
-	      data_con = ASSERT( not (null (tyConDataCons tycon)) ) 
-			 head (tyConDataCons tycon)
-	_other -> Nothing
-
--- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type
-splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-splitProductType str ty
-  = case splitProductType_maybe ty of
-	Just stuff -> stuff
-	Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
-\end{code}
-
-
-%************************************************************************
 %*                                                                      *
         Promoting of data types to the kind level
 %*                                                                      *
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index ad778d16ad..364adadc6b 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -22,9 +22,10 @@ module Demand (
 
         DmdResult, CPRResult, PureResult, 
         isBotRes, isTopRes, resTypeArgDmd, 
-        topRes, botRes, cprRes,
-        appIsBottom, isBottomingSig, pprIfaceStrictSig, returnsCPR, 
-        StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
+        topRes, botRes, cprProdRes, cprSumRes,
+        appIsBottom, isBottomingSig, pprIfaceStrictSig, 
+        returnsCPR, returnsCPRProd, returnsCPR_maybe,
+        StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
        
         seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList,
@@ -48,44 +49,24 @@ import UniqFM
 import Util
 import BasicTypes
 import Binary
-import Maybes                    ( expectJust )
+import Maybes                    ( isJust, expectJust )
 \end{code}
 
 %************************************************************************
 %*                                                                      *
-\subsection{Lattice-like structure for domains}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-
-class LatticeLike a where
-  bot    :: a
-  top    :: a
-  pre    :: a -> a -> Bool
-  lub    :: a -> a -> a 
-  both   :: a -> a -> a
-
--- False < True
-instance LatticeLike Bool where
-  bot     = False
-  top     = True
--- x `pre` y <==> (x => y)
-  pre x y = (not x) || y  
-  lub     = (||)
-  both    = (&&)
-
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
 \subsection{Strictness domain}
 %*                                                                      *
 %************************************************************************
 
-\begin{code}
+        Lazy
+         |
+        Str
+      /     \
+  SCall      SProd
+      \      /
+      HyperStr
 
+\begin{code}
 -- Vanilla strictness domain
 data StrDmd
   = HyperStr             -- Hyper-strict 
@@ -132,42 +113,43 @@ instance Outputable StrDmd where
   ppr Str           = char 'S'
   ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))
 
--- LatticeLike implementation for strictness demands
-instance LatticeLike StrDmd where
-  bot = HyperStr
-  top = Lazy
-  
-  pre _ Lazy                               = True
-  pre HyperStr _                           = True
-  pre (SCall s1) (SCall s2)                = pre s1 s2
-  pre (SCall _) Str                        = True
-  pre (SProd _) Str                        = True
-  pre (SProd sx1) (SProd sx2)    
-            | length sx1 == length sx2     = all (== True) $ zipWith pre sx1 sx2 
-  pre x y                                  = x == y
-
-  lub x y | x == y                         = x 
-  lub y x | x `pre` y                      = lub x y
-  lub HyperStr s                           = s
-  lub _ Lazy                               = strTop
-  lub (SProd _) Str                        = strStr
-  lub (SProd sx1) (SProd sx2) 
-           | length sx1 == length sx2      = strProd $ zipWith lub sx1 sx2
-           | otherwise                     = strStr
-  lub (SCall s1) (SCall s2)                = strCall (s1 `lub` s2)
-  lub (SCall _)  Str                       = strStr
-  lub _ _                                  = strTop
-
-  both x y | x == y                        = x 
-  both y x | x `pre` y                     = both x y
-  both HyperStr _                          = strBot
-  both s Lazy                              = s
-  both s@(SProd _) Str                     = s
-  both (SProd sx1) (SProd sx2) 
-           | length sx1 == length sx2      = strProd $ zipWith both sx1 sx2 
-  both (SCall s1) (SCall s2)               = strCall (s1 `both` s2)
-  both s@(SCall _)  Str                    = s
-  both _ _                                 = strBot
+lubStr :: StrDmd -> StrDmd -> StrDmd
+lubStr HyperStr s              = s
+lubStr (SCall s1) HyperStr     = SCall s1
+lubStr (SCall _)  Lazy         = Lazy
+lubStr (SCall _)  Str          = Str
+lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)
+lubStr (SCall _)  (SProd _)    = Str
+lubStr (SProd _)  HyperStr     = HyperStr
+lubStr (SProd _)  Lazy         = Lazy
+lubStr (SProd _)  Str          = Str
+lubStr (SProd s1) (SProd s2)
+    | length s1 == length s2   = SProd (zipWith lubStr s1 s2)
+    | otherwise                = Str
+lubStr (SProd _) (SCall _)     = Str
+lubStr Str Lazy                = Lazy
+lubStr Str _                   = Str
+lubStr Lazy _                  = Lazy
+
+bothStr :: StrDmd -> StrDmd -> StrDmd
+bothStr HyperStr _             = HyperStr
+bothStr Lazy s                 = s
+bothStr Str Lazy               = Str
+bothStr Str s                  = s
+bothStr (SCall _)  HyperStr    = HyperStr
+bothStr (SCall s1) Lazy        = SCall s1
+bothStr (SCall s1) Str         = SCall s1
+bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)
+bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird
+
+bothStr (SProd _)  HyperStr    = HyperStr
+bothStr (SProd s1) Lazy        = SProd s1
+bothStr (SProd s1)  Str        = SProd s1
+bothStr (SProd s1) (SProd s2) 
+    | length s1 == length s2   = SProd (zipWith bothStr s1 s2)
+    | otherwise                = HyperStr  -- Weird
+bothStr (SProd _) (SCall _)    = HyperStr
+
 
 -- utility functions to deal with memory leaks
 seqStrDmd :: StrDmd -> ()
@@ -179,6 +161,10 @@ seqStrDmdList :: [StrDmd] -> ()
 seqStrDmdList [] = ()
 seqStrDmdList (d:ds) = seqStrDmd d `seq` seqStrDmdList ds
 
+isStrict :: StrDmd -> Bool
+isStrict Lazy = False
+isStrict _    = True
+
 -- Splitting polymorphic demands
 splitStrProdDmd :: Int -> StrDmd -> [StrDmd]
 splitStrProdDmd n Lazy         = replicate n Lazy
@@ -196,7 +182,7 @@ splitStrProdDmd n (SCall d)    = ASSERT( n == 1 ) [d]
 
 Note [Don't optimise UProd(Used) to Used]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An AbsDmds
+These two AbsDmds:
    UProd [Used, Used]   and    Used
 are semantically equivalent, but we do not turn the former into
 the latter, for a regrettable-subtle reason.  Suppose we did.
@@ -214,14 +200,29 @@ This too would get <Str, Used>, but this time there really isn't any
 point in w/w since the components of the pair are not used at all.
 
 So the solution is: don't collapse UProd [Used,Used] to Used; intead
-leave it as-is.  
-    
+leave it as-is. In effect we are using the AbsDmd to do a little bit
+of boxity analysis.  Not very nice.
+
+
+      Used
+      /   \
+  UCall   UProd
+      \   /
+      UHead
+       |
+      Abs
 
 \begin{code}
 data AbsDmd
   = Abs                  -- Definitely unused
                          -- Bottom of the lattice
 
+  | UHead                -- May be used; but its sub-components are 
+                         -- definitely *not* used.  Roughly U(AAA)
+                         -- Eg the usage of x in x `seq` e
+                         -- A polymorphic demand: used for values of all types,
+                         --                       including a type variable
+
   | UCall AbsDmd         -- Call demand for absence
                          -- Used only for values of function type
 
@@ -231,12 +232,6 @@ data AbsDmd
                          -- [Invariant] Not all components are Abs
                          --             (in that case, use UHead)
 
-  | UHead                -- May be used; but its sub-components are 
-                         -- definitely *not* used.  
-                         -- Eg the usage of x in x `seq` e
-                         -- A polymorphic demand: used for values of all types,
-                         --                       including a type variable
-
   | Used                 -- May be used; and its sub-components may be used
                          -- Top of the lattice
   deriving ( Eq, Show )
@@ -267,32 +262,26 @@ absProd ux
   | all (== Abs) ux    = UHead
   | otherwise          = UProd ux
 
-instance LatticeLike AbsDmd where
-  bot                            = absBot
-  top                            = absTop
- 
-  pre Abs _                      = True
-  pre _ Used                     = True
-  pre UHead (UProd _)            = True
-  pre (UCall u1) (UCall u2)      = pre u1 u2
-  pre (UProd ux1) (UProd ux2)
-     | length ux1 == length ux2  = all (== True) $ zipWith pre ux1 ux2 
-  pre x y                        = x == y
-
-  lub x y | x == y               = x 
-  lub y x | x `pre` y            = lub x y
-  lub Abs a                      = a
-  lub a Abs                      = a
-  lub UHead u                    = u
-  lub u UHead                    = u
-  lub (UProd ux1) (UProd ux2)
-     | length ux1 == length ux2  = absProd $ zipWith lub ux1 ux2
-  lub (UCall u1) (UCall u2)      = absCall (u1 `lub` u2)
-  lub (UProd ds) Used            = UProd (map (`lub` Used) ds)
-  lub Used (UProd ds)            = UProd (map (`lub` Used) ds)
-  lub _ _                        = Used
-
-  both                           = lub
+lubAbs :: AbsDmd -> AbsDmd -> AbsDmd
+lubAbs Abs   x               = x
+lubAbs UHead Abs             = UHead
+lubAbs UHead x               = x         
+lubAbs (UCall u1) Abs        = UCall u1 
+lubAbs (UCall u1) UHead      = UCall u1 
+lubAbs (UCall u1) (UCall u2) = UCall (u1 `lubAbs` u2)
+lubAbs (UCall _)  _          = Used
+lubAbs (UProd u1) Abs        = UProd u1 
+lubAbs (UProd u1) UHead      = UProd u1 
+lubAbs (UProd u1) (UProd u2)
+   | length u1 == length u2  = UProd (zipWith lubAbs u1 u2)
+   | otherwise               = Used
+lubAbs (UProd _) (UCall _)   = Used
+lubAbs (UProd ds) Used       = UProd (map (`lubAbs` Used) ds)  -- Note [Don't optimise UProd(Used) to Used]
+lubAbs Used (UProd ds)       = UProd (map (`lubAbs` Used) ds)  -- Note [Don't optimise UProd(Used) to Used]
+lubAbs Used  _               = Used
+
+bothAbs :: AbsDmd -> AbsDmd -> AbsDmd
+bothAbs = lubAbs
 
 -- utility functions
 seqAbsDmd :: AbsDmd -> ()
@@ -345,33 +334,22 @@ mkProdDmd dx
     sp = strProd $ map strd dx
     up = absProd $ map absd dx   
      
-instance LatticeLike JointDmd where
-  bot  = botDmd
-  top  = topDmd
-  pre  = preDmd
-  lub  = lubDmd
-  both = bothDmd
-
 absDmd :: JointDmd
-absDmd = mkJointDmd top bot 
+absDmd = mkJointDmd strTop absBot
 
 topDmd :: JointDmd
-topDmd = mkJointDmd top top
+topDmd = mkJointDmd strTop absTop
 
 botDmd :: JointDmd
-botDmd = mkJointDmd bot bot
-
-preDmd :: JointDmd -> JointDmd -> Bool
-preDmd (JD {strd = s1, absd = a1}) 
-       (JD {strd = s2, absd = a2})  = pre s1 s2 && pre a1 a2
+botDmd = mkJointDmd strBot absBot
 
 lubDmd :: JointDmd -> JointDmd -> JointDmd
 lubDmd (JD {strd = s1, absd = a1}) 
-       (JD {strd = s2, absd = a2}) = mkJointDmd (lub s1 s2) (lub a1 a2)
+       (JD {strd = s2, absd = a2}) = mkJointDmd (lubStr s1 s2) (lubAbs a1 a2)
 
 bothDmd :: JointDmd -> JointDmd -> JointDmd
 bothDmd (JD {strd = s1, absd = a1}) 
-        (JD {strd = s2, absd = a2}) = mkJointDmd (both s1 s2) (both a1 a2)
+        (JD {strd = s2, absd = a2}) = mkJointDmd (bothStr s1 s2) (bothAbs a1 a2)
 
 isTopDmd :: JointDmd -> Bool
 isTopDmd (JD {strd = Lazy, absd = Used}) = True
@@ -398,13 +376,13 @@ seqDemandList [] = ()
 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
 
 isStrictDmd :: Demand -> Bool
-isStrictDmd (JD {strd = x}) = x /= top
+isStrictDmd (JD {strd = x}) = isStrict x
 
 isUsedDmd :: Demand -> Bool
-isUsedDmd (JD {absd = x}) = x /= bot
+isUsedDmd (JD {absd = x}) = isUsed x
 
 isUsed :: AbsDmd -> Bool
-isUsed x = x /= bot
+isUsed x = x /= absBot
 
 someCompUsed :: AbsDmd -> Bool
 someCompUsed Used      = True
@@ -416,7 +394,7 @@ evalDmd :: JointDmd
 evalDmd = mkJointDmd strStr absTop
 
 defer :: Demand -> Demand
-defer (JD {absd = a}) = mkJointDmd top a 
+defer (JD {absd = a}) = mkJointDmd strTop a 
 
 -- use :: Demand -> Demand
 -- use (JD {strd = d}) = mkJointDmd d top
@@ -424,7 +402,6 @@ defer (JD {absd = a}) = mkJointDmd top a
 
 Note [Dealing with call demands]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Call demands are constructed and deconstructed coherently for
 strictness and absence. For instance, the strictness signature for the
 following function
@@ -436,8 +413,7 @@ should be: <L,C(U(AU))>m
 
 \begin{code}
 mkCallDmd :: JointDmd -> JointDmd
-mkCallDmd (JD {strd = d, absd = a}) 
-          = mkJointDmd (strCall d) (absCall a)
+mkCallDmd (JD {strd = d, absd = a}) = mkJointDmd (strCall d) (absCall a)
 
 peelCallDmd :: JointDmd -> Maybe JointDmd
 -- Exploiting the fact that 
@@ -537,32 +513,39 @@ data PureResult = TopRes        -- Nothing known, assumed to be just lazy
                 | BotRes        -- Diverges or errors
                deriving( Eq, Show )
 
-instance LatticeLike PureResult where
-     bot = BotRes
-     top = TopRes
-     pre x y = (x == y) || (y == top)
-     lub x y | x == y = x 
-     lub _ _          = top
-     both x y | x == y = x 
-     both _ _          = bot
+lubPR :: PureResult -> PureResult -> PureResult
+lubPR BotRes pr = pr
+lubPR TopRes _  = TopRes
+
+bothPR :: PureResult -> PureResult -> PureResult
+bothPR BotRes _  = BotRes
+bothPR TopRes pr = pr
 
 
 ------------------------------------------------------------------------
 -- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
-data CPRResult = NoCPR
-               | RetCPR
+data CPRResult = NoCPR              -- Top of the lattice
+               | RetProd            -- Returns a constructor from a product type
+               | RetSum ConTag      -- Returns a constructor from a sum type with this tag
+               | BotCPR             -- Returns a constructor with any tag
+                                    -- Bottom of the domain
                deriving( Eq, Show )
 
-instance LatticeLike CPRResult where
-     bot = RetCPR
-     top = NoCPR
-     pre x y = (x == y) || (y == top)
-     lub x y | x == y  = x 
-     lub _ _           = top
-     both x y | x == y = x 
-     both _ _          = bot
+lubCPR :: CPRResult -> CPRResult -> CPRResult
+lubCPR BotCPR      r           = r
+lubCPR RetProd     BotCPR      = RetProd
+lubCPR (RetSum t)  BotCPR      = RetSum t
+lubCPR (RetSum t1) (RetSum t2) 
+  | t1 == t2                   = RetSum t1
+lubCPR RetProd     RetProd     = RetProd
+lubCPR _ _                     = NoCPR
+
+bothCPR :: CPRResult -> CPRResult -> CPRResult
+-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
+bothCPR r _ = r
+
 
 ------------------------------------------------------------------------
 -- Combined demand result                                             --
@@ -571,46 +554,39 @@ instance LatticeLike CPRResult where
 data DmdResult = DR { res :: PureResult, cpr :: CPRResult }
      deriving ( Eq )
 
--- TODO rework DmdResult to make it more clear
-instance LatticeLike DmdResult where
-  bot                        = botRes
-  top                        = topRes
-
-  pre x _ | x == bot         = True
-  pre _ x | x == top         = True
-  pre (DR s1 a1) (DR s2 a2)  = (pre s1 s2) && (pre a1 a2)
-
-  lub  r r' | isBotRes r                   = r'
-  lub  r r' | isBotRes r'                  = r
-  lub  r r' 
-        | returnsCPR r && returnsCPR r'    = r
-  lub  _ _                                 = top
+lubDmdResult :: DmdResult -> DmdResult -> DmdResult
+lubDmdResult (DR pr1 cpr1) (DR pr2 cpr2) = DR (pr1 `lubPR` pr2) (cpr1 `lubCPR` cpr2)
 
-  both _ r2 | isBotRes r2 = r2
-  both r1 _               = r1
+bothDmdResult :: DmdResult -> DmdResult -> DmdResult
+bothDmdResult (DR pr1 cpr1) (DR pr2 cpr2) = DR (pr1 `bothPR` pr2) (cpr1 `bothCPR` cpr2)
 
 -- Pretty-printing
 instance Outputable DmdResult where
-  ppr (DR {res=TopRes, cpr=RetCPR}) = char 'm'   --    DDDr without ambiguity
-  ppr (DR {res=BotRes}) = char 'b'   
+  ppr (DR {res=TopRes, cpr=RetProd})  = char 'm' 
+  ppr (DR {res=TopRes, cpr=RetSum n}) = char 'm' <> int n  
+  ppr (DR {res=BotRes})               = char 'b'   
   ppr _ = empty   -- Keep these distinct from Demand letters
 
 mkDmdResult :: PureResult -> CPRResult -> DmdResult
-mkDmdResult BotRes RetCPR = botRes
+-- mkDmdResult BotRes (RetCPR _) = botRes   -- SLPJ: commenting out; unnecessary?
 mkDmdResult x y = DR {res=x, cpr=y}
 
 seqDmdResult :: DmdResult -> ()
 seqDmdResult (DR {res=x, cpr=y}) = x `seq` y `seq` ()
 
 -- [cprRes] lets us switch off CPR analysis
--- by making sure that everything uses TopRes instead of RetCPR
--- Assuming, of course, that they don't mention RetCPR by name.
--- They should onlyu use retCPR
-topRes, botRes, cprRes :: DmdResult
+-- by making sure that everything uses TopRes
+topRes, botRes :: DmdResult
 topRes = mkDmdResult TopRes NoCPR
-botRes = mkDmdResult BotRes NoCPR
-cprRes | opt_CprOff = topRes
-       | otherwise  = mkDmdResult TopRes RetCPR
+botRes = mkDmdResult BotRes BotCPR
+
+cprSumRes :: ConTag -> DmdResult
+cprSumRes tag | opt_CprOff = topRes
+              | otherwise  = mkDmdResult TopRes (RetSum tag)
+cprProdRes :: DmdResult
+cprProdRes | opt_CprOff = topRes
+           | otherwise  = mkDmdResult TopRes RetProd
+
 
 isTopRes :: DmdResult -> Bool
 isTopRes (DR {res=TopRes, cpr=NoCPR})  = True
@@ -621,16 +597,24 @@ isBotRes (DR {res=BotRes})      = True
 isBotRes _                  = False
 
 returnsCPR :: DmdResult -> Bool
-returnsCPR (DR {res=TopRes, cpr=RetCPR}) = True
-returnsCPR _                  = False
+returnsCPR dr = isJust (returnsCPR_maybe dr)
+
+returnsCPRProd :: DmdResult -> Bool
+returnsCPRProd (DR {res=TopRes, cpr=RetProd}) = True
+returnsCPRProd _                              = False
+
+returnsCPR_maybe :: DmdResult -> Maybe ConTag
+returnsCPR_maybe (DR {res=TopRes, cpr=RetSum t}) = Just t
+returnsCPR_maybe (DR {res=TopRes, cpr=RetProd})  = Just fIRST_TAG
+returnsCPR_maybe _                               = Nothing
 
 resTypeArgDmd :: DmdResult -> Demand
 -- TopRes and BotRes are polymorphic, so that
 --      BotRes === Bot -> BotRes === ...
 --      TopRes === Top -> TopRes === ...
 -- This function makes that concrete
-resTypeArgDmd r | isBotRes r = bot
-resTypeArgDmd _              = top
+resTypeArgDmd r | isBotRes r = botDmd
+resTypeArgDmd _              = topDmd
 \end{code}
 
 %************************************************************************
@@ -647,10 +631,12 @@ worthSplittingFun ds res
         -- worthSplitting returns False for an empty list of demands,
         -- and hence do_strict_ww is False if arity is zero and there is no CPR
   where
+    worth_it (JD {absd=Abs})                  = True      -- Absent arg
+
     -- See Note [Worker-wrapper for bottoming functions]
-    worth_it (JD {strd=HyperStr, absd=a})     = isUsed a  -- A Hyper-strict argument, safe to do W/W
+    worth_it (JD {strd=HyperStr, absd=UProd _}) = True
+
     -- See Note [Worthy functions for Worker-Wrapper split]    
-    worth_it (JD {absd=Abs})                  = True      -- Absent arg
     worth_it (JD {strd=SProd _})              = True      -- Product arg to evaluate
     worth_it (JD {strd=Str, absd=UProd _})    = True      -- Strictly used product arg
     worth_it (JD {strd=Str, absd=UHead})      = True 
@@ -731,6 +717,19 @@ The re-boxing code won't go away unless error_fn gets a wrapper too.
 [We don't do reboxing now, but in general it's better to pass an
 unboxed thing to f, and have it reboxed in the error cases....]
 
+However we *don't* want to do this when the argument is not actually
+taken apart in the function at all.  Otherwise we risk decomposing a
+masssive tuple which is barely used.  Example:
+
+	f :: ((Int,Int) -> String) -> (Int,Int) -> a
+	f g pr = error (g pr)
+
+	main = print (f fst (1, error "no"))
+          
+Here, f does not take 'pr' apart, and it's stupid to do so.
+Imagine that it had millions of fields. This actually happened
+in GHC itself where the tuple was DynFlags
+
 
 %************************************************************************
 %*                                                                      *
@@ -781,7 +780,14 @@ Note [Asymmetry of 'both' for DmdType and DmdResult]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 'both' for DmdTypes is *assymetrical*, because there is only one
 result!  For example, given (e1 e2), we get a DmdType dt1 for e1, use
-its arg demand to analyse e2 giving dt2, and then do (dt1 `both` dt2).
+its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).
+Similarly with 
+  case e of { p -> rhs }
+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
+compute (dt_rhs `bothType` dt_scrut).
+
+We take the CPR info from FIRST argument, but combine both to get
+termination info.
 
 
 \begin{code}
@@ -791,25 +797,12 @@ instance Eq DmdType where
        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
                               && ds1 == ds2 && res1 == res2
 
-instance LatticeLike DmdType where
-  bot  = botDmdType
-  top  = topDmdType
-  pre  = preDmdType
-  lub  = lubDmdType
-  both = bothDmdType
-
-preDmdType :: DmdType -> DmdType -> Bool
-preDmdType (DmdType _ ds1 res1) (DmdType _ ds2 res2)
-  =  (res1 `pre` res2)
-  && (length ds1 == length ds2)
-  && all (\(x, y) -> x `pre` y) (zip ds1 ds2)
-
 lubDmdType :: DmdType -> DmdType -> DmdType
 lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
-  = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lub` r2)
+  = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubDmdResult` r2)
   where
-    absLub  = lub absDmd
-    lub_fv  = plusVarEnv_C lub fv1 fv2
+    absLub  = lubDmd absDmd
+    lub_fv  = plusVarEnv_C lubDmd fv1 fv2
     -- Consider (if x then y else []) with demand V
     -- Then the first branch gives {y->V} and the second
     -- *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
@@ -819,10 +812,10 @@ lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
       -- lub is the identity for Bot
 
       -- Extend the shorter argument list to match the longer
-    lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
+    lub_ds (d1:ds1) (d2:ds2) = lubDmd d1 d2 : lub_ds ds1 ds2
     lub_ds []     []       = []
-    lub_ds ds1    []       = map (`lub` resTypeArgDmd r2) ds1
-    lub_ds []     ds2      = map (resTypeArgDmd r1 `lub`) ds2
+    lub_ds ds1    []       = map (`lubDmd` resTypeArgDmd r2) ds1
+    lub_ds []     ds2      = map (resTypeArgDmd r1 `lubDmd`) ds2
  
 bothDmdType :: DmdType -> DmdType -> DmdType
 bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
@@ -831,11 +824,11 @@ bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
     -- using its second arg just for its free-var info.
     -- NB: Don't forget about r2!  It might be BotRes, which is
     -- a bottom demand on all the in-scope variables.
-  = DmdType both_fv2 ds1 (r1 `both` r2)
+  = DmdType both_fv2 ds1 (r1 `bothDmdResult` r2)
   where
-    both_fv  = plusVarEnv_C both fv1 fv2
-    both_fv1 = modifyEnv (isBotRes r1) (`both` bot) fv2 fv1 both_fv
-    both_fv2 = modifyEnv (isBotRes r2) (`both` bot) fv1 fv2 both_fv1
+    both_fv  = plusVarEnv_C bothDmd fv1 fv2
+    both_fv1 = modifyEnv (isBotRes r1) (`bothDmd` botDmd) fv2 fv1 both_fv
+    both_fv2 = modifyEnv (isBotRes r2) (`bothDmd` botDmd) fv1 fv2 both_fv1
 
 
 instance Outputable DmdType where
@@ -851,10 +844,12 @@ instance Outputable DmdType where
 emptyDmdEnv :: VarEnv Demand
 emptyDmdEnv = emptyVarEnv
 
-topDmdType, botDmdType, cprDmdType :: DmdType
+topDmdType, botDmdType :: DmdType
 topDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
-cprDmdType = DmdType emptyDmdEnv [] cprRes
+
+cprProdDmdType :: DmdType
+cprProdDmdType = DmdType emptyDmdEnv [] cprProdRes
 
 isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env [] res)
@@ -882,7 +877,7 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)
 
 deferType :: DmdType -> DmdType
-deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] top
+deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] topRes
 
 deferEnv :: DmdEnv -> DmdEnv
 deferEnv fv = mapVarEnv defer fv
@@ -956,7 +951,7 @@ splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
 -- Add extra arguments to a strictness signature
 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
-  = StrictSig (DmdType env (replicate arity_increase top ++ dmds) res)
+  = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
 
 isTopSig :: StrictSig -> Bool
 isTopSig (StrictSig ty) = isTopDmdType ty
@@ -964,10 +959,12 @@ isTopSig (StrictSig ty) = isTopDmdType ty
 isBottomingSig :: StrictSig -> Bool
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
 
-topSig, botSig, cprSig:: StrictSig
+topSig, botSig :: StrictSig
 topSig = StrictSig topDmdType
 botSig = StrictSig botDmdType
-cprSig = StrictSig cprDmdType
+
+cprProdSig :: StrictSig
+cprProdSig = StrictSig cprProdDmdType
 
 dmdTransformSig :: StrictSig -> Demand -> DmdType
 -- (dmdTransformSig fun_sig dmd) considers a call to a function whose
@@ -977,8 +974,8 @@ dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) dmd
   = go arg_ds dmd
   where
     go [] dmd 
-      | isBotDmd dmd = bot     -- Transform bottom demand to bottom type
-      | otherwise    = dmd_ty  -- Saturated
+      | isBotDmd dmd = botDmdType -- Transform bottom demand to bottom type
+      | otherwise    = dmd_ty     -- Saturated
     go (_:as) dmd    = case peelCallDmd dmd of
                         Just dmd' -> go as dmd'
                         Nothing   -> deferType dmd_ty
@@ -1096,8 +1093,8 @@ instance Binary PureResult where
     get  bh = do
             h <- getByte bh
             case h of 
-              0 -> return bot       
-              _ -> return top
+              0 -> return BotRes
+              _ -> return TopRes
 
 instance Binary StrictSig where
     put_ bh (StrictSig aa) = do
@@ -1117,14 +1114,18 @@ instance Binary DmdType where
            return (DmdType emptyDmdEnv ds dr)
 
 instance Binary CPRResult where
-    put_ bh RetCPR       = do putByte bh 0
-    put_ bh NoCPR        = do putByte bh 1
+    put_ bh (RetSum n)   = do { putByte bh 0; put_ bh n }
+    put_ bh RetProd      = putByte bh 1
+    put_ bh NoCPR        = putByte bh 2
+    put_ bh BotCPR       = putByte bh 3
 
     get  bh = do
             h <- getByte bh
             case h of 
-              0 -> return bot       
-              _ -> return top
+              0 -> do { n <- get bh; return (RetSum n) }
+              1 -> return RetProd
+              2 -> return NoCPR
+              _ -> return BotCPR
 
 instance Binary DmdResult where
     put_ bh (DR {res=x, cpr=y}) = do put_ bh x; put_ bh y
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 3fdf86dd02..8957924618 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -425,16 +425,17 @@ mkDataConWorkId wkr_name data_con
 
 dataConCPR :: DataCon -> DmdResult
 dataConCPR con
-  | isProductTyCon tycon
-  , isDataTyCon tycon
+  | isDataTyCon tycon     -- Real data types only; that is, 
+                          -- not unboxed tuples or newtypes
+  , isVanillaDataCon con  -- No existentials 
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
-  = cprRes
+  = if is_prod then cprProdRes 
+               else cprSumRes (dataConTag con)
   | otherwise
   = topRes
-        -- RetCPR is only true for products that are real data types;
-        -- that is, not unboxed tuples or [non-recursive] newtypes
   where
+    is_prod = isProductTyCon tycon
     tycon = dataConTyCon con
     wkr_arity = dataConRepArity con
 
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 259f31a1b8..ebc9e53c72 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -107,7 +107,6 @@ module CLabel (
 import IdInfo
 import BasicTypes
 import Packages
-import DataCon
 import Module
 import Name
 import Unique
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index ac3be95983..502de84a81 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -1303,12 +1303,12 @@ mkKindErrMsg tyvar arg_ty
 
 mkArityMsg :: Id -> MsgDoc
 mkArityMsg binder
-  = vcat [hsep [ptext (sLit "Demand type has "),
-                     ppr (dmdTypeDepth dmd_ty),
-                     ptext (sLit " arguments, rhs has "),
-                     ppr (idArity binder),
-                     ptext (sLit "arguments, "),
-		     ppr binder],
+  = vcat [hsep [ptext (sLit "Demand type has"),
+               	ppr (dmdTypeDepth dmd_ty),
+               	ptext (sLit "arguments, rhs has"),
+               	ppr (idArity binder),
+               	ptext (sLit "arguments,"),
+	       	ppr binder],
 	      hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
 
          ]
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 685975f982..9f34e4ac2e 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -31,7 +31,7 @@ module CoreSyn (
 	mkFloatLit, mkFloatLitFloat,
 	mkDoubleLit, mkDoubleLitDouble,
 	
-	mkConApp, mkTyBind, mkCoBind,
+	mkConApp, mkConApp2, mkTyBind, mkCoBind,
 	varToCoreExpr, varsToCoreExprs,
 
         isId, cmpAltCon, cmpAlt, ltAlt,
@@ -1133,6 +1133,11 @@ mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
+mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
+mkConApp2 con tys arg_ids = Var (dataConWorkId con) 
+                            `mkApps` map Type tys
+                            `mkApps` map varToCoreExpr arg_ids
+
 
 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
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)
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index b21d546ef7..2e55e497d7 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -31,7 +31,7 @@ import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
-import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
+import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF )
 import CoreUnfold  ( exprIsConApp_maybe )
 import Type
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f2ab037207..b736a1c27f 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -2037,7 +2037,7 @@ simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
                 -- Bind the case-binder to (con args)
         ; let inst_tys' = tyConAppArgs (idType case_bndr')
               con_app :: OutExpr
-              con_app   = mkConApp con (map Type inst_tys' ++ varsToCoreExprs vs')
+              con_app   = mkConApp2 con inst_tys' vs'
 
         ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
         ; rhs' <- simplExprC env'' rhs cont'
@@ -2384,8 +2384,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
                           where
                                  -- See Note [Case binders and join points]
                              unf = mkInlineUnfolding Nothing rhs
-                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
-                                                ++ varsToCoreExprs bndrs')
+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
 
                       LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
                                                 <+> ppr case_bndr <+> ppr con )
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 3dc527475f..afc70f9b9e 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1435,7 +1435,7 @@ calcSpecStrictness fn qvars pats
     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
     go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
     go_one env d e 
-           | Just ds <- splitProdDmd_maybe d
+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
            , (Var _, args) <- collectArgs e = go env ds args
     go_one env _         _ = env
 \end{code}
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 9e38bb7c0d..0eca72fa00 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -221,14 +221,14 @@ dmdAnal dflags env dmd (Lam var body)
 dmdAnal dflags env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
   -- Only one alternative with a product constructor
   | let tycon = dataConTyCon dc
-  , isProductTyCon tycon
+  , isProductTyCon tycon 
   , not (isRecursiveTyCon tycon)
   = let
 	env_alt	              = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
 	(alt_ty, alt')	      = dmdAnalAlt dflags env_alt dmd alt
 	(alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
 	(_, bndrs', _)	      = alt'
-	case_bndr_sig	      = cprSig
+	case_bndr_sig	      = cprProdSig
 		-- Inside the alternative, the case binder has the CPR property.
 		-- Meaning that a case on it will successfully cancel.
 		-- Example:
@@ -621,9 +621,11 @@ mkSigTy top_lvl rec_flag env id rhs (DmdType fv dmds res)
     strict_fv = filterUFM isStrictDmd         fv
 
     ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
-    res' = if returnsCPR res && ignore_cpr_info 
-	   then topRes
-           else res 
+    res' | returnsCPR res
+         , not (isTopLevel top_lvl || returnsCPRProd res) 
+                -- See Note [CPR for sum types ]
+           || ignore_cpr_info                             = topRes
+	 | otherwise                                      = res
 
     -- Is it okay or not to assign CPR 
     -- (not okay in the first pass)
@@ -637,6 +639,32 @@ mkSigTy top_lvl rec_flag env id rhs (DmdType fv dmds res)
 	| otherwise 		        = False	
 \end{code}
 
+Note [CPR for sum types]
+~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we do not do CPR for let-bindings that
+   * non-top level
+   * bind a sum type
+Reason: I found that in some benchmarks we were losing let-no-escapes,
+which messed it all up.  Example
+   let j = \x. ....
+   in case y of
+        True  -> j False
+        False -> j True
+If we w/w this we get
+   let j' = \x. ....
+   in case y of
+        True -> case j False of { (# a #) -> Just a }
+        True -> case j True of { (# a #) -> Just a }
+Notice that j' is not a let-no-escape any more.
+
+However this means in turn that the *enclosing* function
+may be CPR'd (via the returned Justs).  But in the case of
+sums, there may be Nothing alterantives; and that messes
+up the sum-type CPR.
+
+Conclusion: only do this for products.  It's still not
+guaranteed OK for products, but sums definitely lose sometimes.
+
 Note [CPR for thunks]
 ~~~~~~~~~~~~~~~~~~~~~
 If the rhs is a thunk, we usually forget the CPR info, because
@@ -867,13 +895,11 @@ nonVirgin sigs = AE { ae_sigs = sigs, ae_virgin = False }
 extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
 -- Extend the AnalEnv when we meet a lambda binder
 extendSigsWithLam env id
-  | ae_virgin env   -- See Note [Optimistic CPR in the "virgin" case]
-  = extendAnalEnv NotTopLevel env id cprSig
-
-  | isStrictDmd dmd_info  -- Might be bottom, first time round
-  , Just {} <- deepSplitProductType_maybe $ idType id
-  = extendAnalEnv NotTopLevel env id cprSig
+  | isStrictDmd dmd_info || ae_virgin env  
+       -- See Note [Optimistic CPR in the "virgin" case]
        -- See Note [Initial CPR for strict binders]
+  , Just {} <- deepSplitProductType_maybe $ idType id
+  = extendAnalEnv NotTopLevel env id cprProdSig 
 
   | otherwise = env
   where
@@ -882,7 +908,6 @@ extendSigsWithLam env id
 
 Note [Initial CPR for strict binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 CPR is initialized for a lambda binder in an optimistic manner, i.e,
 if the binder is used strictly and at least some of its components as
 a product are used, which is checked by the value of the absence
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 1cbebf8c23..ea2365555b 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -16,26 +16,26 @@ module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs, deepSplitProductType_maybe ) w
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( exprType )
+import CoreUtils	( exprType, mkCast )
 import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
 			  isOneShotLambda, setOneShotLambda, setIdUnfolding,
-                          setIdInfo, setIdType
+                          setIdInfo
 			)
 import IdInfo		( vanillaIdInfo )
 import DataCon
 import Demand        
 import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
-import MkId		( realWorldPrimId, voidArgId
-                        , wrapNewTypeBody, unwrapNewTypeBody )
+import MkId		( realWorldPrimId, voidArgId )
 import TysPrim		( realWorldStatePrimTy )
 import TysWiredIn	( tupleCon )
 import Type
-import Coercion         ( mkSymCo, instNewTyCon_maybe, splitNewTypeRepCo_maybe )
+import Coercion hiding  ( substTy, substTyVarBndr )
 import BasicTypes	( TupleSort(..) )
 import Literal		( absentLiteralOf )
 import TyCon
 import UniqSupply
 import Unique
+import Maybes
 import Util
 import Outputable
 import DynFlags
@@ -424,15 +424,16 @@ mkWWstr_one dflags arg
   	-- Unpack case, 
         -- see note [Unpacking arguments with product and polymorphic demands]
   | isStrictDmd dmd
-  , Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) 
+  , Just cs <- splitProdDmd_maybe dmd
+  , Just (data_con, inst_tys, inst_con_arg_tys, co) 
              <- deepSplitProductType_maybe (idType arg)
-  =  do { uniqs <- getUniquesM
-	; let   cs             = splitProdDmd (length inst_con_arg_tys) dmd
-	        unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
+  =  do { (uniq1:uniqs) <- getUniquesM
+	; let   unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
 	        unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
-	        unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
+	        unbox_fn       = mkUnpackCase (Var arg `mkCast` co) uniq1
+                                              data_con unpk_args
 	        rebox_fn       = Let (NonRec arg con_app) 
-	        con_app        = mkProductBox unpk_args (idType arg)
+	        con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
 	 ; (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds
 	 ; return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
 	  		   -- Don't pass the arg, rebox instead
@@ -456,57 +457,25 @@ nop_fn body = body
 \end{code}
 
 \begin{code}
-mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
--- (mkUnpackCase x e args Con body)
---      returns
--- case (e `cast` ...) of bndr { Con args -> body }
--- 
--- the type of the bndr passed in is irrelevent
-mkUnpackCase bndr arg unpk_args boxing_con body
-  = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
-  where
-  (cast_arg, bndr_ty) = go (idType bndr) arg
-  go ty arg 
-    | (tycon, tycon_args, _, _)  <- splitProductType "mkUnpackCase" ty
-    , isNewTyCon tycon && not (isRecursiveTyCon tycon)
-    = go (newTyConInstRhs tycon tycon_args) 
-         (unwrapNewTypeBody tycon tycon_args arg)
-    | otherwise = (arg, ty)
-
-mkProductBox :: [Id] -> Type -> CoreExpr
-mkProductBox arg_ids ty 
-  = result_expr
-  where 
-    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
-
-    result_expr
-      | isNewTyCon tycon && not (isRecursiveTyCon tycon) 
-      = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args))
-      | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids)
-
-    wrap expr = wrapNewTypeBody tycon tycon_args expr
-
--- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
--- and hence recursively tries to unpack it as far as it able to
-deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
+deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion)
+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
+-- then  dc @ tys (args::arg_tys)  |> co :: ty
 deepSplitProductType_maybe ty
-  = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
-       ; let {result 
-             | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
-	     , not (isRecursiveTyCon tycon)
-             = deepSplitProductType_maybe ty'	-- Ignore the coercion?
-             | isNewTyCon tycon = Nothing  -- cannot unbox through recursive
-					   -- newtypes nor through families
-             | otherwise = Just res}
-       ; result
-       }
-
--- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
-deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-deepSplitProductType str ty 
-  = case deepSplitProductType_maybe ty of
-      Just stuff -> stuff
-      Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+  | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , Just con <- isDataProductTyCon_maybe tc
+  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
+deepSplitProductType_maybe _ = Nothing
+
+deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
+deepSplitCprType_maybe con_tag ty
+  | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , isDataTyCon tc
+  , let cons = tyConDataCons tc
+        con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
+  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
+deepSplitCprType_maybe _ _ = Nothing
 \end{code}
 
 
@@ -534,72 +503,79 @@ mkWWcpr :: Type                              -- function body type
 		   Type)			-- Type of worker's body 
 
 mkWWcpr body_ty res
-    | not (returnsCPR res) -- No CPR info
-    = return (id, id, body_ty)
-
-    | not (isClosedAlgType body_ty)
-    = WARN( True, 
-            text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
-      return (id, id, body_ty)
-
-    | n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
+  = case returnsCPR_maybe res of
+       Nothing      -> return (id, id, body_ty)  -- No CPR info
+       Just con_tag | Just stuff <- deepSplitCprType_maybe con_tag body_ty
+                    -> mkWWcpr_help stuff
+                    |  otherwise
+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
+                       return (id, id, body_ty)
+          
+mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
+             -> UniqSM (CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
+
+mkWWcpr_help (data_con, inst_tys, arg_tys, co)
+  | [arg_ty1] <- arg_tys
+  , isUnLiftedType arg_ty1
 	-- Special case when there is a single result of unlifted type
 	--
 	-- Wrapper:	case (..call worker..) of x -> C x
 	-- Worker:	case (   ..body..    ) of C x -> x
-      (work_uniq : arg_uniq : _) <- getUniquesM
-      let
-	work_wild = mk_ww_local work_uniq body_ty
-	arg	  = mk_ww_local arg_uniq  con_arg_ty1
-	con_app   = mkProductBox [arg] body_ty
+  = do { (work_uniq : arg_uniq : _) <- getUniquesM
+       ; let arg       = mk_ww_local arg_uniq  arg_ty1
+	     con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` co
 
-      return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
-		\ body     -> workerCase (work_wild) body [arg] data_con (Var arg),
-		con_arg_ty1)
+       ; return ( \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
+                , \ body     -> mkUnpackCase body work_uniq data_con [arg] (Var arg)
+                , arg_ty1 ) }
 
-    | otherwise = do	-- The general case
+  | otherwise 	-- The general case
 	-- Wrapper: case (..call worker..) of (# a, b #) -> C a b
 	-- Worker:  case (   ...body...  ) of C a b -> (# a, b #)     
-      uniqs <- getUniquesM
-      let
-        (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
-	arg_vars		       = varsToCoreExprs args
-	ubx_tup_con		       = tupleCon UnboxedTuple n_con_args
-	ubx_tup_ty		       = exprType ubx_tup_app
-	ubx_tup_app		       = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)
-        con_app			       = mkProductBox args body_ty
-
-      return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)],
-		\ body     -> workerCase (work_wild) body args data_con ubx_tup_app,
-		ubx_tup_ty)
-    where
-      (_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty
-      n_con_args  = length con_arg_tys
-      con_arg_ty1 = head con_arg_tys
-
--- If the original function looked like
---	f = \ x -> _scc_ "foo" E
---
--- then we want the CPR'd worker to look like
---	\ x -> _scc_ "foo" (case E of I# x -> x)
--- and definitely not
---	\ x -> case (_scc_ "foo" E) of I# x -> x)
---
--- This transform doesn't move work or allocation
--- from one cost centre to another.
---
--- Later [SDM]: presumably this is because we want the simplifier to
--- eliminate the case, and the scc would get in the way?  I'm ok with
--- including the case itself in the cost centre, since it is morally
--- part of the function (post transformation) anyway.
-
-workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-workerCase bndr (Tick tickish e) args con body
-   = Tick tickish (mkUnpackCase bndr e args con body)
-workerCase bndr e args con body
-   = mkUnpackCase bndr e args con body
+  = do { (work_uniq : uniqs) <- getUniquesM
+       ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
+	     ubx_tup_con  = tupleCon UnboxedTuple (length arg_tys)
+	     ubx_tup_ty	  = exprType ubx_tup_app
+	     ubx_tup_app  = mkConApp2 ubx_tup_con arg_tys args
+             con_app	  = mkConApp2 data_con inst_tys args `mkCast` co
+
+       ; return ( \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)]
+		, \ body     -> mkUnpackCase body work_uniq data_con args ubx_tup_app
+		, ubx_tup_ty ) }
+
+mkUnpackCase ::  CoreExpr -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
+-- (mkUnpackCase e bndr Con args body)
+--      returns
+-- case e of bndr { Con args -> body }
+-- 
+-- the type of the bndr passed in is irrelevent
+
+mkUnpackCase (Tick tickish e) uniq con args body   -- See Note [Profiling and unpacking]
+  = Tick tickish (mkUnpackCase e uniq con args body)
+mkUnpackCase scrut uniq boxing_con unpk_args body
+  = Case scrut 
+         (mk_ww_local uniq (exprType scrut)) (exprType body) 
+         [(DataAlt boxing_con, unpk_args, body)]
 \end{code}
 
+Note [Profiling and unpacking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the original function looked like
+	f = \ x -> _scc_ "foo" E
+
+then we want the CPR'd worker to look like
+	\ x -> _scc_ "foo" (case E of I# x -> x)
+and definitely not
+	\ x -> case (_scc_ "foo" E) of I# x -> x)
+
+This transform doesn't move work or allocation
+from one cost centre to another.
+
+Later [SDM]: presumably this is because we want the simplifier to
+eliminate the case, and the scc would get in the way?  I'm ok with
+including the case itself in the cost centre, since it is morally
+part of the function (post transformation) anyway.
+
 
 %************************************************************************
 %*									*
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 83f31af3af..ecf4e3a9e3 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -36,9 +36,10 @@ module Coercion (
         mkNewTypeCo, 
 
         -- ** Decomposition
-        splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
-        getCoVar_maybe,
+        splitNewTypeRepCo_maybe, instNewTyCon_maybe, 
+        topNormaliseNewType, topNormaliseNewTypeX,
 
+        decomposeCo, getCoVar_maybe,
         splitTyConAppCo_maybe,
         splitAppCo_maybe,
         splitForAllCo_maybe,
@@ -88,6 +89,7 @@ import VarEnv
 import VarSet
 import Maybes   ( orElse )
 import Name	( Name, NamedThing(..), nameUnique, getSrcSpan )
+import NameSet
 import OccName 	( parenSymOcc )
 import Util
 import BasicTypes
@@ -745,34 +747,64 @@ instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
 -- ^ If @co :: T ts ~ rep_ty@ then:
 --
 -- > instNewTyCon_maybe T ts = Just (rep_ty, co)
+-- Checks for a newtype, and for being saturated
 instNewTyCon_maybe tc tys
-  | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc
-  = ASSERT( tys `lengthIs` tyConArity tc )
-    Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo co_tc tys)
+  | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc  -- Check for newtype
+  , tys `lengthIs` tyConArity tc                      -- Check saturated
+  = Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo co_tc tys)
   | otherwise
   = Nothing
 
--- this is here to avoid module loops
 splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion)  
 -- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.
 -- This function only strips *one layer* of @newtype@ off, so the caller will usually call
--- itself recursively. Furthermore, this function should only be applied to types of kind @*@,
--- hence the newtype is always saturated. If @co : ty ~ ty'@ then:
+-- itself recursively. If
 --
 -- > splitNewTypeRepCo_maybe ty = Just (ty', co)
 --
--- The function returns @Nothing@ for non-@newtypes@ or fully-transparent @newtype@s.
+-- then  @co : ty ~ ty'@.  The function returns @Nothing@ for non-@newtypes@, 
+-- or unsaturated applications
 splitNewTypeRepCo_maybe ty 
-  | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
+  | Just ty' <- coreView ty 
+  = splitNewTypeRepCo_maybe ty'
 splitNewTypeRepCo_maybe (TyConApp tc tys)
-  | Just (ty', co) <- instNewTyCon_maybe tc tys
-  = case co of
-	Refl _ -> panic "splitNewTypeRepCo_maybe"
-			-- This case handled by coreView
-	_      -> Just (ty', co)
+  = instNewTyCon_maybe tc tys
 splitNewTypeRepCo_maybe _
   = Nothing
 
+topNormaliseNewType :: Type -> Maybe (Type, Coercion)
+topNormaliseNewType ty
+  = case topNormaliseNewTypeX emptyNameSet ty of
+      Just (_, co, ty) -> Just (ty, co)
+      Nothing          -> Nothing
+
+topNormaliseNewTypeX :: NameSet -> Type -> Maybe (NameSet, Coercion, Type)
+topNormaliseNewTypeX rec_nts ty
+  | Just ty' <- coreView ty         -- Expand predicates and synonyms
+  = topNormaliseNewTypeX rec_nts ty'
+
+topNormaliseNewTypeX rec_nts (TyConApp tc tys)
+  | Just (rep_ty, co) <- instNewTyCon_maybe tc tys
+  , not (tc_name `elemNameSet` rec_nts)  -- See Note [Expanding newtypes] in Type
+  = case topNormaliseNewTypeX rec_nts' rep_ty of
+       Nothing                       -> Just (rec_nts', co,                 rep_ty)
+       Just (rec_nts', co', rep_ty') -> Just (rec_nts', co `mkTransCo` co', rep_ty')
+  where
+    tc_name = tyConName tc
+    rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
+             | otherwise	   = rec_nts
+
+topNormaliseNewTypeX _ _ = Nothing
+\end{code}
+
+
+%************************************************************************
+%*									*
+                   Equality of coercions
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
 -- | Determines syntactic equality of coercions
 coreEqCoercion :: Coercion -> Coercion -> Bool
 coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 617cfa0b3a..f657b5bff6 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -47,6 +47,7 @@ import CoAxiom
 import VarSet
 import VarEnv
 import Name
+import NameSet
 import UniqFM
 import Outputable
 import Maybes
@@ -908,32 +909,26 @@ topNormaliseType :: FamInstEnvs
 -- Its a bit like Type.repType, but handles type families too
 
 topNormaliseType env ty
-  = go [] ty
+  = go emptyNameSet ty
   where
-    go :: [TyCon] -> Type -> Maybe (Coercion, Type)
-    go rec_nts ty | Just ty' <- coreView ty     -- Expand synonyms
+    go :: NameSet -> Type -> Maybe (Coercion, Type)
+    go rec_nts ty 
+        | Just ty' <- coreView ty     -- Expand synonyms
         = go rec_nts ty'
 
-    go rec_nts (TyConApp tc tys)
-        | isNewTyCon tc         -- Expand newtypes
-        = if tc `elem` rec_nts  -- See Note [Expanding newtypes] in Type.lhs
-          then Nothing
-          else let 
-               in add_co nt_co rec_nts' nt_rhs
+        | Just (rec_nts', nt_co, nt_rhs) <- topNormaliseNewTypeX rec_nts ty
+        = add_co nt_co rec_nts' nt_rhs
 
+    go rec_nts (TyConApp tc tys) 
         | isFamilyTyCon tc              -- Expand open tycons
         , (co, ty) <- normaliseTcApp env tc tys
                 -- Note that normaliseType fully normalises 'tys',
+                -- wrt type functions but *not* newtypes
                 -- It has do to so to be sure that nested calls like
                 --    F (G Int)
                 -- are correctly top-normalised
         , not (isReflCo co)
         = add_co co rec_nts ty
-        where
-          nt_co  = mkUnbranchedAxInstCo (newTyConCo tc) tys
-          nt_rhs = newTyConInstRhs      tc              tys
-          rec_nts' | isRecursiveTyCon tc = tc:rec_nts
-                   | otherwise           = rec_nts
 
     go _ _ = Nothing
 
@@ -962,7 +957,7 @@ normaliseTcApp env tc tys
     (fix_coi, nty)
 
   | otherwise   -- No unique matching family instance exists;
-                -- we do not do anything
+                -- we do not do anything (including for newtypes)
   = (tycon_coi, TyConApp tc ntys)
 
   where
@@ -978,6 +973,7 @@ normaliseType :: FamInstEnvs            -- environment with family instances
                                         -- co :: old-type ~ new_type
 -- Normalise the input type, by eliminating *all* type-function redexes
 -- Returns with Refl if nothing happens
+-- Does nothing to newtypes
 
 normaliseType env ty
   | Just ty' <- coreView ty = normaliseType env ty'
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 0bce4db43e..ce14944011 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -41,7 +41,8 @@ module TyCon(
         isPromotedDataCon_maybe, isPromotedTyCon_maybe,
 
         isInjectiveTyCon,
-        isDataTyCon, isProductTyCon, isEnumerationTyCon,
+        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
+        isEnumerationTyCon,
         isNewTyCon, isAbstractTyCon,
         isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon,
         isUnLiftedTyCon,
@@ -1058,14 +1059,8 @@ unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
 unwrapNewTyCon_maybe _     = Nothing
 
 isProductTyCon :: TyCon -> Bool
--- | A /product/ 'TyCon' must both:
---
--- 1. Have /one/ constructor
---
--- 2. /Not/ be existential
---
--- However other than this there are few restrictions: they may be @data@ or @newtype@
--- 'TyCon's of any boxity and may even be recursive.
+-- True of datatypes or newtypes that have
+--   one, vanilla, data constructor
 isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
                                     DataTyCon{ data_cons = [data_con] }
                                                 -> isVanillaDataCon data_con
@@ -1074,6 +1069,18 @@ isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
 isProductTyCon (TupleTyCon {})  = True
 isProductTyCon _                = False
 
+
+isDataProductTyCon_maybe :: TyCon -> Maybe DataCon
+-- True of datatypes (not newtypes) with 
+--   one, vanilla, data constructor
+isDataProductTyCon_maybe (AlgTyCon { algTcRhs = DataTyCon { data_cons = cons } })
+  | [con] <- cons         -- Singleton
+  , isVanillaDataCon con  -- Vanilla
+  = Just con
+isDataProductTyCon_maybe (TupleTyCon { dataCon = con })
+  = Just con
+isDataProductTyCon_maybe _ = Nothing
+
 -- | Is this a 'TyCon' representing a type synonym (@type@)?
 isSynTyCon :: TyCon -> Bool
 isSynTyCon (SynTyCon {}) = True
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index efe8a3bde3..3cab277dc4 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -49,7 +49,7 @@ module Type (
         coAxNthLHS,
 	
 	-- (Newtypes)
-	newTyConInstRhs, carefullySplitNewType_maybe,
+	newTyConInstRhs, 
 	
 	-- Pred types
         mkFamilyTyConApp,
@@ -657,8 +657,13 @@ repType ty
 	= go rec_nts ty
 
     go rec_nts (TyConApp tc tys)	-- Expand newtypes
-      | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
-      = go rec_nts' ty'
+      | isNewTyCon tc
+      , tys `lengthAtLeast` tyConArity tc
+      , let tc_name = tyConName tc
+            rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
+	             | otherwise	   = rec_nts
+      , not (tc_name `elemNameSet` rec_nts)  -- See Note [Expanding newtypes]
+      = go rec_nts' (newTyConInstRhs tc tys)
 
       | isUnboxedTupleTyCon tc
       = if null tys
@@ -667,21 +672,6 @@ repType ty
 
     go _ ty = UnaryRep ty
 
-carefullySplitNewType_maybe :: NameSet -> TyCon -> [Type] -> Maybe (NameSet,Type)
--- Return the representation of a newtype, unless 
--- we've seen it already: see Note [Expanding newtypes]
--- Assumes the newtype is saturated
-carefullySplitNewType_maybe rec_nts tc tys
-  | isNewTyCon tc
-  , tys `lengthAtLeast` tyConArity tc
-  , not (tc_name `elemNameSet` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys)
-  | otherwise	   	                = Nothing
-  where
-    tc_name = tyConName tc
-    rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name
-	     | otherwise	   = rec_nts
-
-
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 20fade521b..0ae4fbf05f 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -661,11 +661,11 @@ unVectDict ty e
        ; return $ mkCoreConApps dataCon (map Type tys ++ scOps)
        }
   where
-    (tycon, tys, dataCon, methTys) = splitProductType "unVectDict: original type" ty
-    cls                            = case tyConClass_maybe tycon of
-                                       Just cls -> cls
-                                       Nothing  -> panic "Vectorise.Exp.unVectDict: no class"
-    selIds                         = classAllSelIds cls
+    (tycon, tys) = splitTyConApp ty
+    Just dataCon = isDataProductTyCon_maybe tycon
+    Just cls     = tyConClass_maybe tycon
+    methTys      = dataConInstArgTys dataCon tys
+    selIds       = classAllSelIds cls
 
 -- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
 --