Major refactoring of the way that UNPACK pragmas are handled

The situation was pretty dire.  The way in which data constructors
were handled, notably the mapping between their *source* argument types
and their *representation* argument types (after seq'ing and unpacking)
was scattered in three different places, and hard to keep in sync.

Now it is all in one place:

 * The dcRep field of a DataCon gives its representation,
   specified by a DataConRep

 * As well as having the wrapper, the DataConRep has a "boxer"
   of type DataConBoxer (defined in MkId for loopy reasons).
   The boxer used at a pattern match to reconstruct the source-level
   arguments from the rep-level bindings in the pattern match.

 * The unboxing in the wrapper and the boxing in the boxer are dual,
   and are now constructed together, by MkId.mkDataConRep. This is
   the key function of this change.

 * All the computeBoxingStrategy code in TcTyClsDcls disappears.

Much nicer.

There is a little bit of refactoring left to do; the strange
deepSplitProductType functions are now called only in WwLib, so
I moved them there, and I think they could be tidied up further.

18 files changed, 637 insertions, 707 deletions

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 616316c7ff..efef9faf57 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -62,7 +62,7 @@ module BasicTypes(
 
         EP(..),
 
-	HsBang(..), isBanged, isMarkedUnboxed, 
+	HsBang(..), isBanged, 
         StrictnessMark(..), isMarkedStrict,
 
 	DefMethSpec(..),
@@ -585,33 +585,26 @@ e.g. 	data T = MkT !Int !(Bool,Bool)
 -------------------------
 -- HsBang describes what the *programmer* wrote
 -- This info is retained in the DataCon.dcStrictMarks field
-data HsBang = HsNoBang	
+data HsBang = HsNoBang	       -- Lazy field
 
-	    | HsStrict	
+	    | HsBang Bool      -- Source-language '!' bang
+                               --  True <=> also an {-# UNPACK #-} pragma
 
-	    | HsUnpack	       -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-	    | HsUnpackFailed   -- An UNPACK pragma that we could not make 
-	      		       -- use of, because the type isn't unboxable; 
-                               -- equivalant to HsStrict except for checkValidDataCon
-            | HsNoUnpack       -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
+	    | HsUnpack	       -- Definite commitment: this field is strict and unboxed
+            | HsStrict         -- Definite commitment: this field is strict but not unboxec
   deriving (Eq, Data, Typeable)
 
 instance Outputable HsBang where
     ppr HsNoBang       = empty
-    ppr HsStrict       = char '!'
-    ppr HsUnpack       = ptext (sLit "{-# UNPACK #-} !")
-    ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
-    ppr HsNoUnpack     = ptext (sLit "{-# NOUNPACK #-} !")
+    ppr (HsBang True)  = ptext (sLit "{-# UNPACK #-} !")
+    ppr (HsBang False) = char '!'
+    ppr HsUnpack       = ptext (sLit "Unpacked")
+    ppr HsStrict       = ptext (sLit "SrictNotUnpacked")
 
 isBanged :: HsBang -> Bool
 isBanged HsNoBang = False
 isBanged _        = True
 
-isMarkedUnboxed :: HsBang -> Bool
-isMarkedUnboxed HsUnpack = True
-isMarkedUnboxed _        = False
-
 -------------------------
 -- StrictnessMark is internal only, used to indicate strictness 
 -- of the DataCon *worker* fields
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 9516e4ef24..d04eac588a 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -14,7 +14,7 @@
 
 module DataCon (
         -- * Main data types
-	DataCon, DataConIds(..),
+	DataCon, DataConRep(..),
 	ConTag,
 	
 	-- ** Type construction
@@ -30,19 +30,18 @@ module DataCon (
 	dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
 	dataConInstOrigArgTys, dataConRepArgTys, 
 	dataConFieldLabels, dataConFieldType,
-	dataConStrictMarks, dataConExStricts,
+	dataConStrictMarks, 
 	dataConSourceArity, dataConRepArity, dataConRepRepArity,
 	dataConIsInfix,
 	dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
-	dataConRepStrictness,
+	dataConRepStrictness, dataConRepBangs, dataConBoxer,
 	
 	-- ** Predicates on DataCons
 	isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
 	isVanillaDataCon, classDataCon, dataConCannotMatch,
 
         -- * Splitting product types
-	splitProductType_maybe, splitProductType, deepSplitProductType,
-        deepSplitProductType_maybe,
+	splitProductType_maybe, splitProductType, 
 
         -- ** Promotion related functions
         isPromotableTyCon, promoteTyCon, 
@@ -51,12 +50,12 @@ module DataCon (
 
 #include "HsVersions.h"
 
+import {-# SOURCE #-} MkId( DataConBoxer )
 import Type
 import TypeRep( Type(..) )  -- Used in promoteType
 import PrelNames( liftedTypeKindTyConKey )
 import Kind
 import Unify
-import Coercion
 import TyCon
 import Class
 import Name
@@ -342,24 +341,27 @@ data DataCon
 		-- The OrigResTy is T [a], but the dcRepTyCon might be :T123
 
 	-- Now the strictness annotations and field labels of the constructor
-	dcStrictMarks :: [HsBang],
+	dcArgBangs :: [HsBang],
 		-- Strictness annotations as decided by the compiler.  
-		-- Does *not* include the existential dictionaries
-		-- length = dataConSourceArity dataCon
+		-- Matches 1-1 with dcOrigArgTys
+		-- Hence length = dataConSourceArity dataCon
 
 	dcFields  :: [FieldLabel],
 		-- Field labels for this constructor, in the
 		-- same order as the dcOrigArgTys; 
 		-- length = 0 (if not a record) or dataConSourceArity.
 
+	-- The curried worker function that corresponds to the constructor:
+	-- It doesn't have an unfolding; the code generator saturates these Ids
+	-- and allocates a real constructor when it finds one.
+	dcWorkId :: Id,
+
 	-- Constructor representation
-	dcRepArgTys :: [Type],	-- Final, representation argument types, 
-				-- after unboxing and flattening,
-				-- and *including* all existential evidence args
+        dcRep      :: DataConRep,
 
-	dcRepStrictness :: [StrictnessMark],
-                -- One for each *representation* *value* argument
-		-- See also Note [Data-con worker strictness] in MkId.lhs
+        -- Cached
+        dcRepArity    :: Arity,  -- == length dataConRepArgTys
+        dcSourceArity :: Arity,  -- == length dcOrigArgTys
 
 	-- Result type of constructor is T t1..tn
 	dcRepTyCon  :: TyCon,		-- Result tycon, T
@@ -379,13 +381,6 @@ data DataCon
 	-- used in CoreLint.
 
 
-	-- The curried worker function that corresponds to the constructor:
-	-- It doesn't have an unfolding; the code generator saturates these Ids
-	-- and allocates a real constructor when it finds one.
-	--
-	-- An entirely separate wrapper function is built in TcTyDecls
-	dcIds :: DataConIds,
-
 	dcInfix :: Bool,	-- True <=> declared infix
 				-- Used for Template Haskell and 'deriving' only
 				-- The actual fixity is stored elsewhere
@@ -395,29 +390,49 @@ data DataCon
   }
   deriving Data.Typeable.Typeable
 
--- | Contains the Ids of the data constructor functions
-data DataConIds
-  = DCIds (Maybe Id) Id 	-- Algebraic data types always have a worker, and
-				-- may or may not have a wrapper, depending on whether
-				-- the wrapper does anything.  Newtypes just have a worker
-
-	-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-
-	-- The wrapper takes dcOrigArgTys as its arguments
-	-- The worker takes dcRepArgTys as its arguments
-	-- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys
-
-	-- The 'Nothing' case of DCIds is important
-	-- Not only is this efficient,
-	-- but it also ensures that the wrapper is replaced
-	-- by the worker (because it *is* the worker)
-	-- even when there are no args. E.g. in
-	-- 		f (:) x
-	-- the (:) *is* the worker.
-	-- This is really important in rule matching,
-	-- (We could match on the wrappers,
-	-- but that makes it less likely that rules will match
-	-- when we bring bits of unfoldings together.)
+data DataConRep 
+  = NoDataConRep              -- No wrapper
+
+  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens, 
+                              -- and constructs the representation
+
+        , dcr_boxer   :: DataConBoxer
+
+        , dcr_arg_tys :: [Type]  -- Final, representation argument types, 
+                                 -- after unboxing and flattening,
+                                 -- and *including* all evidence args
+
+        , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys
+		-- See also Note [Data-con worker strictness] in MkId.lhs
+
+        , dcr_bangs :: [HsBang]  -- The actual decisions made (including failures)
+                                 -- 1-1 with orig_arg_tys
+    }
+-- Algebraic data types always have a worker, and
+-- may or may not have a wrapper, depending on whether
+-- the wrapper does anything.  
+--
+-- Data types have a worker with no unfolding
+-- Newtypes just have a worker, which has a compulsory unfolding (just a cast)
+
+-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
+
+-- The wrapper (if it exists) takes dcOrigArgTys as its arguments
+-- The worker takes dataConRepArgTys as its arguments
+-- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys
+
+-- The 'NoDataConRep' case is important
+-- Not only is this efficient,
+-- but it also ensures that the wrapper is replaced
+-- by the worker (because it *is* the worker)
+-- even when there are no args. E.g. in
+-- 		f (:) x
+-- the (:) *is* the worker.
+-- This is really important in rule matching,
+-- (We could match on the wrappers,
+-- but that makes it less likely that rules will match
+-- when we bring bits of unfoldings together.)
+
 
 -- | Type of the tags associated with each constructor possibility
 type ConTag = Int
@@ -503,7 +518,8 @@ mkDataCon :: Name
 	  -> TyCon              -- ^ Representation type constructor
 	  -> ThetaType          -- ^ The "stupid theta", context of the data declaration 
 				--   e.g. @data Eq a => T a ...@
-	  -> DataConIds         -- ^ The Ids of the actual builder functions
+          -> Id                 -- ^ Worker Id
+	  -> DataConRep         -- ^ Representation
 	  -> DataCon
   -- Can get the tag from the TyCon
 
@@ -513,7 +529,7 @@ mkDataCon name declared_infix
 	  univ_tvs ex_tvs 
 	  eq_spec theta
 	  orig_arg_tys orig_res_ty rep_tycon
-	  stupid_theta ids
+	  stupid_theta work_id rep
 -- Warning: mkDataCon is not a good place to check invariants. 
 -- If the programmer writes the wrong result type in the decl, thus:
 --	data T a where { MkT :: S }
@@ -533,37 +549,30 @@ mkDataCon name declared_infix
 		  dcStupidTheta = stupid_theta, 
 		  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
 		  dcRepTyCon = rep_tycon, 
-		  dcRepArgTys = rep_arg_tys,
-		  dcStrictMarks = arg_stricts, 
-		  dcRepStrictness = rep_arg_stricts,
-		  dcFields = fields, dcTag = tag, dcRepType = ty,
-		  dcIds = ids,
+		  dcArgBangs = arg_stricts, 
+		  dcFields = fields, dcTag = tag, dcRepType = rep_ty,
+		  dcWorkId = work_id,
+                  dcRep = rep, 
+                  dcSourceArity = length orig_arg_tys,
+                  dcRepArity = length rep_arg_tys,
                   dcPromoted = mb_promoted }
 
-	-- Strictness marks for source-args
-	--	*after unboxing choices*, 
-	-- but  *including existential dictionaries*
 	-- 
 	-- The 'arg_stricts' passed to mkDataCon are simply those for the
 	-- source-language arguments.  We add extra ones for the
 	-- dictionary arguments right here.
-    full_theta   = eqSpecPreds eq_spec ++ theta
-    real_arg_tys = full_theta                         ++ orig_arg_tys
-    real_stricts = map mk_pred_strict_mark full_theta ++ arg_stricts
-
-	-- Representation arguments and demands
-	-- To do: eliminate duplication with MkId
-    (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
-    ty  = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
-	  mkFunTys rep_arg_tys $
-	  mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
+    rep_arg_tys = dataConRepArgTys con
+    rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
+	     mkFunTys rep_arg_tys $
+	     mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
     mb_promoted   -- See Note [Promoted data constructors] in TyCon
       | all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
                           -- No kind polymorphism, and all of kind *
-      , null full_theta   -- No constraints
+      , null eq_spec   -- No constraints
+      , null theta
       , all isPromotableType orig_arg_tys
       = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
       | otherwise 
@@ -573,11 +582,6 @@ mkDataCon name declared_infix
 
 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
-
-mk_pred_strict_mark :: PredType -> HsBang
-mk_pred_strict_mark pred 
-  | isEqPred pred = HsUnpack	-- Note [Unpack equality predicates]
-  | otherwise     = HsNoBang
 \end{code}
 
 Note [Unpack equality predicates]
@@ -647,31 +651,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
 -- be different from the obvious one written in the source program. Panics
 -- if there is no such 'Id' for this 'DataCon'
 dataConWorkId :: DataCon -> Id
-dataConWorkId dc = case dcIds dc of
-			DCIds _ wrk_id -> wrk_id
+dataConWorkId dc = dcWorkId dc
 
 -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"
 -- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.
 -- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor 
 -- and also for a newtype (whose constructor is inlined compulsorily)
 dataConWrapId_maybe :: DataCon -> Maybe Id
-dataConWrapId_maybe dc = case dcIds dc of
-				DCIds mb_wrap _ -> mb_wrap
+dataConWrapId_maybe dc = case dcRep dc of
+                           NoDataConRep -> Nothing
+                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
 
 -- | Returns an Id which looks like the Haskell-source constructor by using
 -- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to
 -- the worker (see 'dataConWorkId')
 dataConWrapId :: DataCon -> Id
-dataConWrapId dc = case dcIds dc of
-			DCIds (Just wrap) _   -> wrap
-			DCIds Nothing     wrk -> wrk	    -- worker=wrapper
+dataConWrapId dc = case dcRep dc of
+                     NoDataConRep-> dcWorkId dc    -- worker=wrapper
+                     DCR { dcr_wrap_id = wrap_id } -> wrap_id
 
 -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
 -- the union of the 'dataConWorkId' and the 'dataConWrapId'
 dataConImplicitIds :: DataCon -> [Id]
-dataConImplicitIds dc = case dcIds dc of
-			  DCIds (Just wrap) work -> [wrap,work]
-			  DCIds Nothing     work -> [work]
+dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
+  = case rep of
+       NoDataConRep               -> [work]
+       DCR { dcr_wrap_id = wrap } -> [wrap,work]
 
 -- | The labels for the fields of this particular 'DataCon'
 dataConFieldLabels :: DataCon -> [FieldLabel]
@@ -687,22 +692,18 @@ dataConFieldType con label
 -- | The strictness markings decided on by the compiler.  Does not include those for
 -- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
 dataConStrictMarks :: DataCon -> [HsBang]
-dataConStrictMarks = dcStrictMarks
-
--- | Strictness of evidence arguments to the wrapper function
-dataConExStricts :: DataCon -> [HsBang]
--- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_pred_strict_mark (dataConTheta dc)
+dataConStrictMarks = dcArgBangs
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
-dataConSourceArity dc = length (dcOrigArgTys dc)
+dataConSourceArity (MkData { dcSourceArity = arity }) = arity
 
 -- | Gives the number of actual fields in the /representation/ of the 
 -- data constructor. This may be more than appear in the source code;
 -- the extra ones are the existentially quantified dictionaries
 dataConRepArity :: DataCon -> Arity
-dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
+dataConRepArity (MkData { dcRepArity = arity }) = arity
+
 
 -- | The number of fields in the /representation/ of the constructor
 -- AFTER taking into account the unpacking of any unboxed tuple fields
@@ -715,12 +716,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc)
 
 -- | Return whether there are any argument types for this 'DataCon's runtime representation type
 isNullaryRepDataCon :: DataCon -> Bool
-isNullaryRepDataCon dc = null (dcRepArgTys dc)
+isNullaryRepDataCon dc = dataConRepArity dc == 0
 
 dataConRepStrictness :: DataCon -> [StrictnessMark]
 -- ^ Give the demands on the arguments of a
 -- Core constructor application (Con dc args)
-dataConRepStrictness dc = dcRepStrictness dc
+dataConRepStrictness dc = case dcRep dc of
+                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
+                            DCR { dcr_stricts = strs } -> strs
+
+dataConRepBangs :: DataCon -> [HsBang]
+dataConRepBangs dc = case dcRep dc of
+                       NoDataConRep -> dcArgBangs dc
+                       DCR { dcr_bangs = bangs } -> bangs
+
+dataConBoxer :: DataCon -> Maybe DataConBoxer
+dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
+dataConBoxer _ = Nothing 
 
 -- | The \"signature\" of the 'DataCon' returns, in order:
 --
@@ -798,13 +810,12 @@ dataConInstArgTys :: DataCon	-- ^ A datacon with no existentials or equality con
 				-- class dictionary, with superclasses)
 	      	  -> [Type] 	-- ^ Instantiated at these types
 	      	  -> [Type]
-dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, 
-			      dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
+dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
 			      dcExTyVars = ex_tvs}) inst_tys
  = ASSERT2 ( length univ_tvs == length inst_tys 
            , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
    ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )        
-   map (substTyWith univ_tvs inst_tys) rep_arg_tys
+   map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
 
 -- | Returns just the instantiated /value/ argument types of a 'DataCon',
 -- (excluding dictionary args)
@@ -831,10 +842,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
 dataConOrigArgTys :: DataCon -> [Type]
 dataConOrigArgTys dc = dcOrigArgTys dc
 
--- | Returns the arg types of the worker, including all dictionaries, after any 
+-- | Returns the arg types of the worker, including *all* evidence, after any 
 -- flattening has been done and without substituting for any type variables
 dataConRepArgTys :: DataCon -> [Type]
-dataConRepArgTys dc = dcRepArgTys dc
+dataConRepArgTys (MkData { dcRep = rep 
+                         , dcEqSpec = eq_spec
+                         , dcOtherTheta = theta
+		         , dcOrigArgTys = orig_arg_tys })
+  = case rep of
+      NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
+      DCR { dcr_arg_tys = arg_tys } -> arg_tys
 \end{code}
 
 \begin{code}
@@ -940,47 +957,6 @@ splitProductType str ty
   = case splitProductType_maybe ty of
 	Just stuff -> stuff
 	Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
-
-
--- | 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 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)
-
--- | Compute the representation type strictness and type suitable for a 'DataCon'
-computeRep :: [HsBang]			-- ^ Original argument strictness
-	   -> [Type]			-- ^ Original argument types
-	   -> ([StrictnessMark],	-- Representation arg strictness
-	       [Type])			-- And type
-
-computeRep stricts tys
-  = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
-  where
-    unbox HsNoBang       ty = [(NotMarkedStrict, ty)]
-    unbox HsStrict       ty = [(MarkedStrict,    ty)]
-    unbox HsNoUnpack     ty = [(MarkedStrict,    ty)]
-    unbox HsUnpackFailed ty = [(MarkedStrict,    ty)]
-    unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
-                      where
-                        (_tycon, _tycon_args, arg_dc, arg_tys) 
-                           = deepSplitProductType "unbox_strict_arg_ty" ty
 \end{code}
 
 
diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot
index 716dc7e547..6f9a3858f9 100644
--- a/compiler/basicTypes/DataCon.lhs-boot
+++ b/compiler/basicTypes/DataCon.lhs-boot
@@ -2,11 +2,10 @@
 module DataCon where
 import Name( Name )
 import {-# SOURCE #-} TyCon( TyCon )
-import {-# SOURCE #-} TypeRep (Type)
 
 data DataCon
+data DataConRep
 dataConName      :: DataCon -> Name
-dataConRepArgTys :: DataCon -> [Type]
 dataConTyCon     :: DataCon -> TyCon
 isVanillaDataCon :: DataCon -> Bool
 instance Eq DataCon
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 345d8a649f..ce81100607 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -22,12 +22,13 @@ have a standard form, namely:
 module MkId (
         mkDictFunId, mkDictFunTy, mkDictSelId,
 
-        mkDataConIds, mkPrimOpId, mkFCallId,
+        mkPrimOpId, mkFCallId,
 
-        mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+        wrapNewTypeBody, unwrapNewTypeBody,
         wrapFamInstBody, unwrapFamInstScrut,
         wrapTypeFamInstBody, unwrapTypeFamInstScrut,
-        mkUnpackCase, mkProductBox,
+
+        DataConBoxer(..), mkDataConRep, mkDataConWorkId,
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
@@ -46,7 +47,7 @@ import TysPrim
 import TysWiredIn
 import PrelRules
 import Type
-import Coercion
+import Coercion	        ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo )
 import TcType
 import MkCore
 import CoreUtils	( exprType, mkCast )
@@ -65,6 +66,7 @@ import IdInfo
 import Demand
 import CoreSyn
 import Unique
+import UniqSupply
 import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
@@ -74,6 +76,7 @@ import Outputable
 import FastString
 import ListSetOps
 
+import Data.List        ( unzip4 )
 import Data.Maybe       ( maybeToList )
 \end{code}
 
@@ -224,173 +227,6 @@ Hence we translate to
         -- Coercion from family type to representation type
   Co7T a :: T [a] ~ :R7T a
 
-\begin{code}
-mkDataConIds :: Name -> Name -> DataCon -> DataConIds
-mkDataConIds wrap_name wkr_name data_con
-  | isNewTyCon tycon                    -- Newtype, only has a worker
-  = DCIds Nothing nt_work_id                 
-
-  | any isBanged all_strict_marks      -- Algebraic, needs wrapper
-    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclImplicitBndrs
-    || isFamInstTyCon tycon            --     depends on this test
-  = DCIds (Just alg_wrap_id) wrk_id
-
-  | otherwise                                -- Algebraic, no wrapper
-  = DCIds Nothing wrk_id
-  where
-    (univ_tvs, ex_tvs, eq_spec, 
-     other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
-    tycon = dataConTyCon data_con       -- The representation TyCon (not family)
-
-        ----------- Worker (algebraic data types only) --------------
-        -- The *worker* for the data constructor is the function that
-        -- takes the representation arguments and builds the constructor.
-    wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
-                        (dataConRepType data_con) wkr_info
-
-    wkr_arity = dataConRepArity data_con
-    wkr_info  = noCafIdInfo
-                `setArityInfo`       wkr_arity
-                `setStrictnessInfo`  Just wkr_sig
-                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
-                                                        -- even if arity = 0
-
-    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
-        --      Note [Data-con worker strictness]
-        -- Notice that we do *not* say the worker is strict
-        -- even if the data constructor is declared strict
-        --      e.g.    data T = MkT !(Int,Int)
-        -- Why?  Because the *wrapper* is strict (and its unfolding has case
-        -- expresssions that do the evals) but the *worker* itself is not.
-        -- If we pretend it is strict then when we see
-        --      case x of y -> $wMkT y
-        -- the simplifier thinks that y is "sure to be evaluated" (because
-        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
-        --
-        -- When the simplifer sees a pattern 
-        --      case e of MkT x -> ...
-        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
-        -- but that's fine... dataConRepStrictness comes from the data con
-        -- not from the worker Id.
-
-    cpr_info | isProductTyCon tycon && 
-               isDataTyCon tycon    &&
-               wkr_arity > 0        &&
-               wkr_arity <= mAX_CPR_SIZE        = retCPR
-             | otherwise                        = TopRes
-        -- RetCPR is only true for products that are real data types;
-        -- that is, not unboxed tuples or [non-recursive] newtypes
-
-        ----------- Workers for newtypes --------------
-    nt_work_id   = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
-    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
-                  `setArityInfo` 1      -- Arity 1
-                  `setInlinePragInfo`    alwaysInlinePragma
-                  `setUnfoldingInfo`     newtype_unf
-    id_arg1      = mkTemplateLocal 1 (head orig_arg_tys)
-    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
-                            isSingleton orig_arg_tys, ppr data_con  )
-			      -- Note [Newtype datacons]
-                   mkCompulsoryUnfolding $ 
-                   mkLams wrap_tvs $ Lam id_arg1 $ 
-                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
-
-
-        ----------- Wrapper --------------
-        -- We used to include the stupid theta in the wrapper's args
-        -- but now we don't.  Instead the type checker just injects these
-        -- extra constraints where necessary.
-    wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
-    res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
-    ev_tys      = other_theta
-    wrap_ty     = mkForAllTys wrap_tvs $ 
-                  mkFunTys ev_tys $
-                  mkFunTys orig_arg_tys $ res_ty
-
-        ----------- Wrappers for algebraic data types -------------- 
-    alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
-    alg_wrap_info = noCafIdInfo
-                    `setArityInfo`         wrap_arity
-                        -- It's important to specify the arity, so that partial
-                        -- applications are treated as values
-		    `setInlinePragInfo`    alwaysInlinePragma
-                    `setUnfoldingInfo`     wrap_unf
-                    `setStrictnessInfo` Just wrap_sig
-                        -- We need to get the CAF info right here because TidyPgm
-                        -- does not tidy the IdInfo of implicit bindings (like the wrapper)
-                        -- so it not make sure that the CAF info is sane
-
-    all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
-    wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
-    wrap_stricts = dropList eq_spec all_strict_marks
-    wrap_arg_dmds = map mk_dmd wrap_stricts
-    mk_dmd str | isBanged str = evalDmd
-               | otherwise    = lazyDmd
-        -- The Cpr info can be important inside INLINE rhss, where the
-        -- wrapper constructor isn't inlined.
-        -- And the argument strictness can be important too; we
-        -- may not inline a contructor when it is partially applied.
-        -- For example:
-        --      data W = C !Int !Int !Int
-        --      ...(let w = C x in ...(w p q)...)...
-        -- we want to see that w is strict in its two arguments
-
-    wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
-    wrap_rhs = mkLams wrap_tvs $ 
-               mkLams ev_args $
-               mkLams id_args $
-               foldr mk_case con_app 
-                     (zip (ev_args ++ id_args) wrap_stricts)
-                     i3 []
-	     -- The ev_args is the evidence arguments *other than* the eq_spec
-	     -- Because we are going to apply the eq_spec args manually in the
-	     -- wrapper
-
-    con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
-                          Var wrk_id `mkTyApps`  res_ty_args
-                                     `mkVarApps` ex_tvs                 
-                                     `mkCoApps`  map (mkReflCo . snd) eq_spec
-                                     `mkVarApps` reverse rep_ids
-                            -- Dont box the eq_spec coercions since they are
-                            -- marked as HsUnpack by mk_dict_strict_mark
-
-    (ev_args,i2) = mkLocals 1  ev_tys
-    (id_args,i3) = mkLocals i2 orig_arg_tys
-    wrap_arity   = i3-1
-
-    mk_case 
-           :: (Id, HsBang)      -- Arg, strictness
-           -> (Int -> [Id] -> CoreExpr) -- Body
-           -> Int                       -- Next rep arg id
-           -> [Id]                      -- Rep args so far, reversed
-           -> CoreExpr
-    mk_case (arg,strict) body i rep_args
-          = case strict of
-                HsNoBang -> body i (arg:rep_args)
-                HsUnpack -> unboxProduct i (Var arg) (idType arg) the_body 
-                      where
-                        the_body i con_args = body i (reverse con_args ++ rep_args)
-                _other  -- HsUnpackFailed and HsStrict
-                   | isUnLiftedType (idType arg) -> body i (arg:rep_args)
-                   | otherwise -> Case (Var arg) arg res_ty 
-                                       [(DEFAULT,[], body i (arg:rep_args))]
-
-mAX_CPR_SIZE :: Arity
-mAX_CPR_SIZE = 10
--- We do not treat very big tuples as CPR-ish:
---      a) for a start we get into trouble because there aren't 
---         "enough" unboxed tuple types (a tiresome restriction, 
---         but hard to fix), 
---      b) more importantly, big unboxed tuples get returned mainly
---         on the stack, and are often then allocated in the heap
---         by the caller.  So doing CPR for them may in fact make
---         things worse.
-
-mkLocals :: Int -> [Type] -> ([Id], Int)
-mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
-               where
-                 n = length tys
-\end{code}
 
 Note [Newtype datacons]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -528,136 +364,378 @@ dictSelRule val_index n_ty_args _ _ id_unf args
 %*                                                                      *
 %************************************************************************
 
+
 \begin{code}
--- unbox a product type...
--- we will recurse into newtypes, casting along the way, and unbox at the
--- first product data constructor we find. e.g.
---  
---   data PairInt = PairInt Int Int
---   newtype S = MkS PairInt
---   newtype T = MkT S
---
--- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
--- ids, we get (modulo int passing)
---
---   case (e `cast` CoT) `cast` CoS of
---     PairInt a b -> body [a,b]
---
--- The Ints passed around are just for creating fresh locals
-unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
-unboxProduct i arg arg_ty body
-  = result
-  where 
-    result = mkUnpackCase the_id arg con_args boxing_con rhs
-    (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
-    ([the_id], i') = mkLocals i [arg_ty]
-    (con_args, i'') = mkLocals i' tys
-    rhs = body i'' con_args
-
-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)]
+type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr)
+  -- Unbox: bind rep vars by decomposing src var
+
+data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr))
+  -- Box:   build src arg using these rep vars
+
+newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
+                       -- Bind these src-level vars, returning the
+                       -- rep-level vars to bind in the pattern
+\end{code}
+
+\begin{code}
+mkDataConWorkId :: Name -> DataCon -> Id
+mkDataConWorkId wkr_name data_con
+  | isNewTyCon tycon
+  = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info
+  | otherwise
+  = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info
+
   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)
-
--- ...and the dual
-reboxProduct :: [Unique]     -- uniques to create new local binders
-             -> Type         -- type of product to box
-             -> ([Unique],   -- remaining uniques
-                 CoreExpr,   -- boxed product
-                 [Id])       -- Ids being boxed into product
-reboxProduct us ty
-  = let 
-        (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
- 
-        us' = dropList con_arg_tys us
-
-        arg_ids  = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys
-
-        bind_rhs = mkProductBox arg_ids ty
-
-    in
-      (us', bind_rhs, arg_ids)
-
-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
-
-
--- (mkReboxingAlt us con xs rhs) basically constructs the case
--- alternative (con, xs, rhs)
--- but it does the reboxing necessary to construct the *source* 
--- arguments, xs, from the representation arguments ys.
--- For example:
---      data T = MkT !(Int,Int) Bool
---
--- mkReboxingAlt MkT [x,b] r 
---      = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
---
--- mkDataAlt should really be in DataCon, but it can't because
--- it manipulates CoreSyn.
+    tycon = dataConTyCon data_con
 
-mkReboxingAlt
-  :: [Unique] -- Uniques for the new Ids
-  -> DataCon
-  -> [Var]    -- Source-level args, *including* all evidence vars 
-  -> CoreExpr -- RHS
-  -> CoreAlt
+        ----------- Workers for data types --------------
+    alg_wkr_ty = dataConRepType data_con
+    wkr_arity = dataConRepArity data_con
+    wkr_info  = noCafIdInfo
+                `setArityInfo`       wkr_arity
+                `setStrictnessInfo`  Just wkr_sig
+                `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
+                                                     -- even if arity = 0
 
-mkReboxingAlt us con args rhs
-  | not (any isMarkedUnboxed stricts)
-  = (DataAlt con, args, rhs)
+    wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) (dataConCPR data_con))
+        --      Note [Data-con worker strictness]
+        -- Notice that we do *not* say the worker is strict
+        -- even if the data constructor is declared strict
+        --      e.g.    data T = MkT !(Int,Int)
+        -- Why?  Because the *wrapper* is strict (and its unfolding has case
+        -- expresssions that do the evals) but the *worker* itself is not.
+        -- If we pretend it is strict then when we see
+        --      case x of y -> $wMkT y
+        -- the simplifier thinks that y is "sure to be evaluated" (because
+        --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
+        --
+        -- When the simplifer sees a pattern 
+        --      case e of MkT x -> ...
+        -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+        -- but that's fine... dataConRepStrictness comes from the data con
+        -- not from the worker Id.
+
+        ----------- Workers for newtypes --------------
+    (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con
+    res_ty_args  = mkTyVarTys nt_tvs
+    nt_wrap_ty   = dataConUserType data_con
+    nt_work_info = noCafIdInfo          -- The NoCaf-ness is set by noCafIdInfo
+                  `setArityInfo` 1      -- Arity 1
+                  `setInlinePragInfo`    alwaysInlinePragma
+                  `setUnfoldingInfo`     newtype_unf
+    id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
+    newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
+                            isSingleton nt_arg_tys, ppr data_con  )
+			      -- Note [Newtype datacons]
+                   mkCompulsoryUnfolding $ 
+                   mkLams nt_tvs $ Lam id_arg1 $ 
+                   wrapNewTypeBody tycon res_ty_args (Var id_arg1)
+
+dataConCPR :: DataCon -> DmdResult
+dataConCPR con
+  | isProductTyCon tycon
+  , isDataTyCon tycon
+  , wkr_arity > 0
+  , wkr_arity <= mAX_CPR_SIZE
+  = retCPR
+  | otherwise
+  = TopRes
+        -- RetCPR is only true for products that are real data types;
+        -- that is, not unboxed tuples or [non-recursive] newtypes
+  where
+    tycon = dataConTyCon con
+    wkr_arity = dataConRepArity con
+
+    mAX_CPR_SIZE :: Arity
+    mAX_CPR_SIZE = 10
+    -- We do not treat very big tuples as CPR-ish:
+    --      a) for a start we get into trouble because there aren't 
+    --         "enough" unboxed tuple types (a tiresome restriction, 
+    --         but hard to fix), 
+    --      b) more importantly, big unboxed tuples get returned mainly
+    --         on the stack, and are often then allocated in the heap
+    --         by the caller.  So doing CPR for them may in fact make
+    --         things worse.
+\end{code}
+
+\begin{code}
+mkDataConRep :: DynFlags -> Name -> DataCon -> UniqSM DataConRep
+mkDataConRep dflags wrap_name data_con
+  | not wrapper_reqd
+  = return NoDataConRep
 
   | otherwise
-  = let
-        (binds, args') = go args stricts us
-    in
-    (DataAlt con, args', mkLets binds rhs)
+  = do { wrap_args <- mapM newLocal wrap_arg_tys
+       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) 
+                                 initial_wrap_app
+
+       ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
+             wrap_info = noCafIdInfo
+                    	 `setArityInfo`         wrap_arity
+                    	     -- It's important to specify the arity, so that partial
+                    	     -- applications are treated as values
+		    	 `setInlinePragInfo`    alwaysInlinePragma
+                    	 `setUnfoldingInfo`     wrap_unf
+                    	 `setStrictnessInfo`    Just wrap_sig
+                    	     -- We need to get the CAF info right here because TidyPgm
+                    	     -- does not tidy the IdInfo of implicit bindings (like the wrapper)
+                    	     -- so it not make sure that the CAF info is sane
+
+    	     wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con))
+    	     wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
+    	     mk_dmd str | isBanged str = evalDmd
+    	                | otherwise    = lazyDmd
+    	         -- The Cpr info can be important inside INLINE rhss, where the
+    	         -- wrapper constructor isn't inlined.
+    	         -- And the argument strictness can be important too; we
+    	         -- may not inline a contructor when it is partially applied.
+    	         -- For example:
+    	         --      data W = C !Int !Int !Int
+    	         --      ...(let w = C x in ...(w p q)...)...
+    	         -- we want to see that w is strict in its two arguments
+
+    	     wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+             wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+    	     wrap_rhs = mkLams wrap_tvs $ 
+    	                mkLams wrap_args $
+    	                wrapFamInstBody tycon res_ty_args $
+                        wrap_body
+
+       ; return (DCR { dcr_wrap_id = wrap_id
+                     , dcr_boxer   = mk_boxer boxers
+                     , dcr_arg_tys = rep_tys
+                     , dcr_stricts = rep_strs
+                     , dcr_bangs   = dropList ev_tys wrap_bangs }) }
 
   where
-    stricts = dataConExStricts con ++ dataConStrictMarks con
-
-    go [] _stricts _us = ([], [])
-
-    -- Type variable case
-    go (arg:args) stricts us 
-      | isTyVar arg
-      = let (binds, args') = go args stricts us
-        in  (binds, arg:args')
-
-        -- Term variable case
-    go (arg:args) (str:stricts) us
-      | isMarkedUnboxed str
-      = let (binds, unpacked_args')        = go args stricts us'
-            (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
-        in
-            (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
+    (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
+    res_ty_args  = substTyVars (mkTopTvSubst eq_spec) univ_tvs
+    tycon        = dataConTyCon data_con       -- The representation TyCon (not family)
+    wrap_ty      = dataConUserType data_con
+    ev_tys       = eqSpecPreds eq_spec ++ theta
+    all_arg_tys  = ev_tys                         ++ orig_arg_tys
+    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con
+
+    wrap_arg_tys = theta ++ orig_arg_tys
+    wrap_arity   = length wrap_arg_tys
+    	     -- The wrap_args are the arguments *other than* the eq_spec
+    	     -- Because we are going to apply the eq_spec args manually in the
+    	     -- wrapper
+
+    (wrap_bangs, rep_tys_w_strs, unboxers, boxers)
+       = unzip4 (zipWith (dataConArgRep dflags) all_arg_tys orig_bangs)
+    (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
+
+    wrapper_reqd = not (isNewTyCon tycon)  -- Newtypes have only a worker
+                && (any isBanged orig_bangs   -- Some forcing/unboxing
+                                              -- (includes eq_spec)
+                    || isFamInstTyCon tycon)  -- Cast result
+
+    initial_wrap_app = Var (dataConWorkId data_con)
+                      `mkTyApps`  res_ty_args
+    	              `mkVarApps` ex_tvs                 
+    	              `mkCoApps`  map (mkReflCo . snd) eq_spec
+    	                -- Dont box the eq_spec coercions since they are
+    	                -- marked as HsUnpack by mk_dict_strict_mark
+
+    mk_boxer :: [Boxer] -> DataConBoxer
+    mk_boxer boxers = DCB (\ ty_args src_vars -> 
+                      do { let ex_vars = takeList ex_tvs src_vars
+                               subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
+                               subst2 = extendTvSubstList subst1 ex_tvs 
+                                                          (mkTyVarTys ex_vars)
+                         ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
+                         ; return (ex_vars ++ rep_ids, binds) } )
+
+    go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], [])
+    go subst (UnitBox : boxers) (src_var : src_vars)
+      = do { (rep_ids2, binds) <- go subst boxers src_vars
+           ; return (src_var : rep_ids2, binds) }
+    go subst (Boxer boxer : boxers) (src_var : src_vars)
+      = do { (rep_ids1, arg)  <- boxer subst
+           ; (rep_ids2, binds) <- go subst boxers src_vars
+           ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) }
+    go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)
+
+    mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
+    mk_rep_app [] con_app 
+      = return con_app
+    mk_rep_app ((wrap_arg, unboxer) : prs) con_app 
+      = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
+           ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
+           ; return (unbox_fn expr) }
+
+-------------------------
+newLocal :: Type -> UniqSM Var
+newLocal ty = do { uniq <- getUniqueUs 
+                 ; return (mkSysLocal (fsLit "dt") uniq ty) }
+
+-------------------------
+dataConArgRep
+   :: DynFlags 
+   -> Type -> HsBang
+   -> ( HsBang   -- Like input but with HsUnpackFailed if necy
+      , [(Type, StrictnessMark)]   -- Rep types
+      , Unboxer, Boxer)
+
+dataConArgRep _ arg_ty HsNoBang
+  = (HsNoBang, [(arg_ty, NotMarkedStrict)], unitUnboxer, unitBoxer)
+
+dataConArgRep dflags arg_ty (HsBang False)   -- No {-# UNPACK #-} pragma
+  | gopt Opt_OmitInterfacePragmas dflags
+  = strict_but_not_unpacked arg_ty   -- Don't unpack if -fomit-iface-pragmas
+
+  | (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
+  ,  gopt Opt_UnboxStrictFields dflags
+  || (gopt Opt_UnboxSmallStrictFields dflags 
+      && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+  = (HsUnpack, rep_tys, unbox, box)
+
+  | otherwise  -- Record the strict-but-no-unpack decision
+  = strict_but_not_unpacked arg_ty
+
+dataConArgRep dflags arg_ty (HsBang True)   -- {-# UNPACK #-} pragma
+  | gopt Opt_OmitInterfacePragmas dflags
+  = strict_but_not_unpacked arg_ty   -- Don't unpack if -fomit-iface-pragmas
+
+  | (something_happened, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
+  = (if something_happened then HsUnpack else HsStrict
+    , rep_tys, unbox, box)
+
+dataConArgRep _ arg_ty HsStrict
+  = strict_but_not_unpacked arg_ty
+
+dataConArgRep _ arg_ty HsUnpack
+  | (True, rep_tys, unbox, box) <- dataConArgUnpack arg_ty
+  = (HsUnpack, rep_tys, unbox, box)
+  | otherwise -- An interface file specified Unpacked, but we couldn't unpack it
+  = pprPanic "dataConArgRep" (ppr arg_ty) 
+
+strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], Unboxer, Boxer)
+strict_but_not_unpacked arg_ty
+  = (HsStrict, [(arg_ty, MarkedStrict)], seqUnboxer, unitBoxer)
+
+-------------------------
+seqUnboxer :: Unboxer
+seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)])
+
+unitUnboxer :: Unboxer
+unitUnboxer v = return ([v], \e -> e)
+
+unitBoxer :: Boxer
+unitBoxer = UnitBox
+
+-------------------------
+dataConArgUnpack
+   :: Type
+   -> (Bool   -- True <=> some unboxing actually happened
+      , [(Type, StrictnessMark)]   -- Rep types
+      , Unboxer, Boxer)
+
+dataConArgUnpack arg_ty
+  = case splitTyConApp_maybe arg_ty of
+      Just (tc, tc_args) 
+        | not (isRecursiveTyCon tc) 	-- Note [Recusive unboxing]
+	, Just con <- tyConSingleDataCon_maybe tc
+        , isVanillaDataCon con
+        -> unbox_tc_app tc tc_args con
+
+      _otherwise -> ( False, [(arg_ty, MarkedStrict)]
+                    , unitUnboxer, unitBoxer )
+  where
+    unbox_tc_app tc tc_args con
+      | isNewTyCon tc
+      , let rep_ty = newTyConInstRhs tc tc_args
+            co     = mkAxInstCo (newTyConCo tc) tc_args  -- arg_ty ~ rep_ty
+      , (yes, rep_tys, unbox_rep, box_rep) <- dataConArgUnpack rep_ty
+      = ( yes, rep_tys
+        , \ arg_id ->
+          do { rep_id <- newLocal rep_ty
+             ; (rep_ids, rep_fn) <- unbox_rep rep_id
+             ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
+             ; return (rep_ids, Let co_bind . rep_fn) }
+        , Boxer $ \ subst -> 
+          do { (rep_ids, rep_expr) 
+                  <- case box_rep of
+                       UnitBox -> do { rep_id <- newLocal (substTy subst rep_ty)
+                                     ; return ([rep_id], Var rep_id) }
+                       Boxer boxer -> boxer subst
+             ; let sco = mkAxInstCo (newTyConCo tc) (substTys subst tc_args)
+             ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } )
+        
       | otherwise
-      = let (binds, args') = go args stricts us
-        in  (binds, arg:args')
-    go (_ : _) [] _ = panic "mkReboxingAlt"
+      = ( True, rep_tys `zip` dataConRepStrictness con
+        , \ arg_id ->
+          do { rep_ids <- mapM newLocal rep_tys
+             ; let unbox_fn body
+                     = Case (Var arg_id) arg_id (exprType body)
+                            [(DataAlt con, rep_ids, body)]
+             ; return (rep_ids, unbox_fn) }
+        , Boxer $ \ subst ->
+          do { rep_ids <- mapM (newLocal . substTy subst) rep_tys
+             ; return (rep_ids, Var (dataConWorkId con)
+                       		`mkTyApps` (substTys subst tc_args)
+                       		`mkVarApps` rep_ids ) } )
+      where
+        rep_tys = dataConInstArgTys con tc_args
 \end{code}
 
+Note [Unpack one-wide fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The flag UnboxSmallStrictFields ensures that any field that can
+(safely) be unboxed to a word-sized unboxed field, should be so unboxed.
+For example:
+
+    data A = A Int#
+    newtype B = B A
+    data C = C !B
+    data D = D !C
+    data E = E !()
+    data F = F !D
+    data G = G !F !F
+
+All of these should have an Int# as their representation, except
+G which should have two Int#s.  
+
+However 
+
+    data T = T !(S Int)
+    data S = S !a
+
+Here we can represent T with an Int#.
+
+Note [Recursive unboxing]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Be careful not to try to unbox this!
+	data T = MkT {-# UNPACK #-} !T Int
+Reason: consider
+  data R = MkR {-# UNPACK #-} !S Int
+  data S = MkS {-# UNPACK #-} !Int
+The representation arguments of MkR are the *representation* arguments
+of S (plus Int); the rep args of MkS are Int#.  This is obviously no
+good for T, because then we'd get an infinite number of arguments.
+
+But it's the *argument* type that matters. This is fine:
+	data S = MkS S !Int
+because Int is non-recursive.
+
+
+Note [Unpack equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a GADT with a contructor C :: (a~[b]) => b -> T a
+we definitely want that equality predicate *unboxed* so that it
+takes no space at all.  This is easily done: just give it
+an UNPACK pragma. The rest of the unpack/repack code does the
+heavy lifting.  This one line makes every GADT take a word less
+space for each equality predicate, so it's pretty important!
+
+
+\begin{code}
+mk_pred_strict_mark :: PredType -> HsBang
+mk_pred_strict_mark pred 
+  | isEqPred pred = HsUnpack	-- Note [Unpack equality predicates]
+  | otherwise     = HsNoBang
+\end{code}
 
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/basicTypes/MkId.lhs-boot b/compiler/basicTypes/MkId.lhs-boot
index 7891e65d7f..201f977e3d 100644
--- a/compiler/basicTypes/MkId.lhs-boot
+++ b/compiler/basicTypes/MkId.lhs-boot
@@ -1,12 +1,14 @@
 \begin{code}
 module MkId where
 import Name( Name )
-import DataCon( DataCon, DataConIds )
+import Var( Id )
+import {-# SOURCE #-} DataCon( DataCon )
 import {-# SOURCE #-} PrimOp( PrimOp )
-import Id( Id )
 
-mkDataConIds :: Name -> Name -> DataCon -> DataConIds
-mkPrimOpId :: PrimOp -> Id
+data DataConBoxer
+
+mkDataConWorkId :: Name -> DataCon -> Id
+mkPrimOpId      :: PrimOp -> Id
 \end{code}
 
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 405b7687a5..f25039c8a9 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -519,9 +519,9 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-		   L _ (HsBangTy HsUnpack ty) -> (unpackedName,  ty)
-		   L _ (HsBangTy _ ty)        -> (isStrictName,  ty)
-		   _                          -> (notStrictName, ty)
+		   L _ (HsBangTy (HsBang True) ty) -> (unpackedName,  ty)
+		   L _ (HsBangTy _ ty)             -> (isStrictName,  ty)
+		   _                               -> (notStrictName, ty)
 
 -------------------------------------------------------
 -- 			Deriving clause
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 609041ba24..504a76dc86 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -316,10 +316,14 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
     mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
                       return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
 
-    mk_alt fail (con, args, MatchResult _ body_fn) = do
-          body <- body_fn fail
-          us <- newUniqueSupply
-          return (mkReboxingAlt (uniqsFromSupply us) con args body)
+    mk_alt fail (con, args, MatchResult _ body_fn)
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) -> 
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
 
     mk_default fail | exhaustive_case = []
 		    | otherwise       = [(DEFAULT, [], fail)]
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b19f04f033..43086d2771 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -351,9 +351,9 @@ cvtConstr (ForallC tvs ctxt con)
                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
-cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (Unpacked, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' }
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True)  ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 cvt_id_arg (i, str, ty)
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 5d667ced4f..8226b426c3 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -749,19 +749,20 @@ instance Binary InlineSpec where
                   _ -> return NoInline
 
 instance Binary HsBang where
-    put_ bh HsNoBang        = putByte bh 0
-    put_ bh HsStrict        = putByte bh 1
-    put_ bh HsUnpack        = putByte bh 2
-    put_ bh HsUnpackFailed  = putByte bh 3
-    put_ bh HsNoUnpack      = putByte bh 4
+    put_ bh HsNoBang       = putByte bh 0
+    put_ bh (HsBang False) = putByte bh 1
+    put_ bh (HsBang True)  = putByte bh 2
+    put_ bh HsUnpack       = putByte bh 3
+    put_ bh HsStrict       = putByte bh 4
+
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return HsNoBang
-              1 -> do return HsStrict
-              2 -> do return HsUnpack
-              3 -> do return HsUnpackFailed
-              _ -> do return HsNoUnpack
+              1 -> do return (HsBang False)
+              2 -> do return (HsBang True)
+              3 -> do return HsUnpack
+              _ -> do return HsStrict
 
 instance Binary TupleSort where
     put_ bh BoxedTuple      = putByte bh 0
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index be757c62ad..f1361fa7e7 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -39,6 +39,7 @@ import Coercion
 
 import DynFlags
 import TcRnMonad
+import UniqSupply
 import Util
 import Outputable
 \end{code}
@@ -155,14 +156,17 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
 	-- code, which (for Haskell source anyway) will be in the DataName name
 	-- space, and puts it into the VarName name space
 
+        ; us <- newUniqueSupply
+        ; dflags <- getDynFlags
 	; let
 		stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
 		data_con = mkDataCon src_name declared_infix
 				     arg_stricts field_lbls
 				     univ_tvs ex_tvs eq_spec ctxt
 				     arg_tys res_ty rep_tycon
-				     stupid_ctxt dc_ids
-		dc_ids = mkDataConIds wrap_name work_name data_con
+				     stupid_ctxt dc_wrk dc_rep
+                dc_wrk = mkDataConWorkId work_name data_con
+                dc_rep = initUs_ us (mkDataConRep dflags wrap_name data_con)
 
 	; return data_con }
 
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index c410cd770f..09d3210c14 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1506,7 +1506,7 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType env2) arg_tys,
                     ifConFields  = map getOccName 
                                        (dataConFieldLabels data_con),
-                    ifConStricts = dataConStrictMarks data_con }
+                    ifConStricts = dataConRepBangs data_con }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 1c47d6dfad..698fc9a01e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -2360,7 +2360,7 @@ fFlags = [
   ( "do-eta-reduction",                 Opt_DoEtaReduction, nop ),
   ( "case-merge",                       Opt_CaseMerge, nop ),
   ( "unbox-strict-fields",              Opt_UnboxStrictFields, nop ),
-  ( "unbox-strict-primitive-fields",    Opt_UnboxStrictPrimitiveFields, nop ),
+  ( "unbox-small-strict-fields",        Opt_UnboxSmallStrictFields, nop ),
   ( "dicts-cheap",                      Opt_DictsCheap, nop ),
   ( "excess-precision",                 Opt_ExcessPrecision, nop ),
   ( "eager-blackholing",                Opt_EagerBlackHoling, nop ),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 9db8f41452..4833a1805a 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1007,7 +1007,7 @@ infixtype :: { LHsType RdrName }
 strict_mark :: { Located HsBang }
         : '!'                           { L1 HsStrict }
         | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
-        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack }
+        | '{-# NOUNPACK' '#-}' '!'      { LL HsStrict }
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 5071b33e9a..4b05e0efb0 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -76,7 +76,7 @@ module TysWiredIn (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} MkId( mkDataConIds )
+import {-# SOURCE #-} MkId( mkDataConWorkId )
 
 -- friends:
 import PrelNames
@@ -277,16 +277,14 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
 		arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) 
 		tycon
 		[]	-- No stupid theta
-		(mkDataConIds bogus_wrap_name wrk_name data_con)
-		
+                (mkDataConWorkId wrk_name data_con)
+		NoDataConRep	-- Wired-in types are too simple to need wrappers
 
     modu     = ASSERT( isExternalName dc_name ) 
 	       nameModule dc_name
     wrk_occ  = mkDataConWorkerOcc (nameOccName dc_name)
     wrk_name = mkWiredInName modu wrk_occ wrk_key
 			     (AnId (dataConWorkId data_con)) UserSyntax
-    bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name)
-	-- Wired-in types are too simple to need wrappers
 \end{code}
 
 
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 0ed650bff4..8aaa13171c 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -19,20 +19,21 @@ import CoreSyn
 import CoreUtils	( exprType )
 import Id		( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
 			  isOneShotLambda, setOneShotLambda, setIdUnfolding,
-                          setIdInfo
+                          setIdInfo, setIdType
 			)
 import IdInfo		( vanillaIdInfo )
 import DataCon
 import Demand		( Demand(..), DmdResult(..), Demands(..) ) 
 import MkCore		( mkRuntimeErrorApp, aBSENT_ERROR_ID )
-import MkId		( realWorldPrimId, voidArgId, 
-                          mkUnpackCase, mkProductBox )
+import MkId		( realWorldPrimId, voidArgId
+                        , wrapNewTypeBody, unwrapNewTypeBody )
 import TysPrim		( realWorldStatePrimTy )
 import TysWiredIn	( tupleCon )
 import Type
-import Coercion         ( mkSymCo, splitNewTypeRepCo_maybe )
+import Coercion         ( mkSymCo, instNewTyCon_maybe, splitNewTypeRepCo_maybe )
 import BasicTypes	( TupleSort(..) )
 import Literal		( absentLiteralOf )
+import TyCon
 import UniqSupply
 import Unique
 import Util		( zipWithEqual )
@@ -416,6 +417,62 @@ 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 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)
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection{CPR stuff}
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 236b834eb6..00b2230492 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -612,16 +612,15 @@ tcFamInstDecl1 fam_tc
        ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
 
        ; stupid_theta <- tcHsContext ctxt
-       ; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
+       ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
 
          -- Construct representation tycon
        ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
        ; axiom_name  <- newImplicitBinder rep_tc_name mkInstTyCoOcc
-       ; let ex_ok = True       -- Existentials ok for type families!
-             orig_res_ty = mkTyConApp fam_tc pats'
+       ; let orig_res_ty = mkTyConApp fam_tc pats'
 
        ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { data_cons <- tcConDecls new_or_data ex_ok rec_rep_tc
+           do { data_cons <- tcConDecls new_or_data rec_rep_tc
                                        (tvs', orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
@@ -641,10 +640,6 @@ tcFamInstDecl1 fam_tc
          -- Remember to check validity; no recursion to worry about here
        ; checkValidTyCon rep_tc
        ; return fam_inst } }
-    where
-       h98_syntax = case cons of      -- All constructors have same shape
-                        L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
-                        _ -> True
 
 
 ----------------
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a7606012ba..bfb33479ea 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -37,7 +37,6 @@ import TcClassDcl
 import TcHsType
 import TcMType
 import TcType
-import qualified TysPrim
 import TysWiredIn( unitTy )
 import Type
 import Kind
@@ -655,17 +654,12 @@ tcTyDefn calc_isrec tc_name tvs kind
                  , td_cons = cons })
   = do { extra_tvs <- tcDataKindSig kind
        ; let is_rec     = calc_isrec tc_name
-             h98_syntax = consUseH98Syntax cons
              final_tvs  = tvs ++ extra_tvs
        ; stupid_theta <- tcHsContext ctxt
        ; kind_signatures <- xoptM Opt_KindSignatures
-       ; existential_ok  <- xoptM Opt_ExistentialQuantification
-       ; gadt_ok         <- xoptM Opt_GADTs
        ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
-       ; let ex_ok = existential_ok || gadt_ok	-- Data cons can have existential context
 
              -- Check that we don't use kind signatures without Glasgow extensions
-       ; 
        ; case mb_ksig of
            Nothing   -> return ()
            Just hs_k -> do { checkTc (kind_signatures) (badSigTyDecl tc_name)
@@ -673,11 +667,11 @@ tcTyDefn calc_isrec tc_name tvs kind
                            ; checkKind kind tc_kind
                            ; return () }
 
-       ; dataDeclChecks tc_name new_or_data stupid_theta cons
+       ; h98_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons
 
        ; tycon <- fixM $ \ tycon -> do
              { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
-             ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons
+             ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons
              ; tc_rhs <-
                  if null cons && is_boot 	      -- In a hs-boot file, empty cons means
                  then return totallyAbstractTyConRhs  -- "don't know"; hence totally Abstract
@@ -947,7 +941,7 @@ So we
 %************************************************************************
 
 \begin{code}
-dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
+dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM Bool
 dataDeclChecks tc_name new_or_data stupid_theta cons
   = do {   -- Check that we don't use GADT syntax in H98 world
          gadtSyntax_ok <- xoptM Opt_GADTSyntax
@@ -968,25 +962,32 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
        ; empty_data_decls <- xoptM Opt_EmptyDataDecls
        ; is_boot <- tcIsHsBoot	-- Are we compiling an hs-boot file?
        ; checkTc (not (null cons) || empty_data_decls || is_boot)
-                 (emptyConDeclsErr tc_name) }
+                 (emptyConDeclsErr tc_name)
+       ; return h98_syntax }
     
+
+-----------------------------------
+consUseH98Syntax :: [LConDecl a] -> Bool
+consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
+consUseH98Syntax _                                             = True
+		 -- All constructors have same shape
+
 -----------------------------------
-tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type)
+tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type)
 	   -> [LConDecl Name] -> TcM [DataCon]
-tcConDecls new_or_data ex_ok rep_tycon res_tmpl cons
-  = mapM (addLocM (tcConDecl new_or_data ex_ok rep_tycon res_tmpl)) cons
+tcConDecls new_or_data rep_tycon res_tmpl cons
+  = mapM (addLocM (tcConDecl new_or_data rep_tycon res_tmpl)) cons
 
 tcConDecl :: NewOrData
-          -> Bool		-- True <=> -XExistentialQuantificaton or -XGADTs
 	  -> TyCon 		-- Representation tycon
 	  -> ([TyVar], Type)	-- Return type template (with its template tyvars)
 	  -> ConDecl Name 
 	  -> TcM DataCon
 
-tcConDecl new_or_data existential_ok rep_tycon res_tmpl 	-- Data types
-	  con@(ConDecl { con_name = name
-                       , con_qvars = hs_tvs, con_cxt = hs_ctxt
-                       , con_details = hs_details, con_res = hs_res_ty })
+tcConDecl new_or_data rep_tycon res_tmpl 	-- Data types
+	  (ConDecl { con_name = name
+                   , con_qvars = hs_tvs, con_cxt = hs_ctxt
+                   , con_details = hs_details, con_res = hs_res_ty })
   = addErrCtxt (dataConCtxt name) $
     do { traceTc "tcConDecl 1" (ppr name)
        ; (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) 
@@ -1018,9 +1019,6 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl 	-- Data types
                       ResTyH98     -> return ResTyH98
                       ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty
 
-       ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
-	         (badExistential name)
-
        ; let (univ_tvs, ex_tvs, eq_preds, res_ty')
                 = rejigConRes res_tmpl qtkvs res_ty
 
@@ -1054,10 +1052,7 @@ tcConArg new_or_data bty
   = do  { traceTc "tcConArg 1" (ppr bty)
         ; arg_ty <- tcHsConArgType new_or_data bty
         ; traceTc "tcConArg 2" (ppr bty)
-        ; dflags <- getDynFlags
-        ; let strict_mark = chooseBoxingStrategy dflags arg_ty (getBangStrictness bty)
-                            -- Must be computed lazily
-	; return (arg_ty, strict_mark) }
+	; return (arg_ty, getBangStrictness bty) }
 
 tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
 tcConRes ResTyH98           = return ResTyH98
@@ -1124,9 +1119,8 @@ rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
                        new_tmpl = updateTyVarKind (substTy subst) tmpl
       | otherwise = pprPanic "tcResultType" (ppr res_ty)
     ex_tvs = dc_tvs `minusList` univ_tvs
+\end{code}
 
-
-{-
 Note [Substitution in template variables kinds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1161,153 +1155,6 @@ which is why we create new_tmpl.
 The template substitution only maps kind variables to kind variables,
 since GADTs are not kind indexed.
 
--}
-
-
-consUseH98Syntax :: [LConDecl a] -> Bool
-consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
-consUseH98Syntax _                                             = True
-		 -- All constructors have same shape
-
-conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
-conRepresentibleWithH98Syntax
-    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
-        = null (hsQTvBndrs tvs) && null (unLoc ctxt)
-conRepresentibleWithH98Syntax
-    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
-        = null (unLoc ctxt) && f t (hsLTyVarNames tvs)
-    where -- Each type variable should be used exactly once in the
-          -- result type, and the result type must just be the type
-          -- constructor applied to type variables
-          f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
-              = (v2 `elem` vs) && f t1 (delete v2 vs)
-          f (HsTyVar _) [] = True
-          f _ _ = False
-
--------------------
-
--- We attempt to unbox/unpack a strict field when either:
---   (i)  The field is marked '!!', or
---   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
---
--- We have turned off unboxing of newtypes because coercions make unboxing 
--- and reboxing more complicated
-chooseBoxingStrategy :: DynFlags -> TcType -> HsBang -> HsBang
-chooseBoxingStrategy dflags arg_ty bang
-  = case initial_choice of
-      HsUnpack | gopt Opt_OmitInterfacePragmas dflags
-               -> HsStrict
-      _other   -> initial_choice
-       -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
-       -- See Trac #5252: unpacking means we must not conceal the
-       --                 representation of the argument type
-       -- However: even when OmitInterfacePragmas is on, we still want
-       -- to know if we have HsUnpackFailed, because we omit a
-       -- warning in that case (#3966)
-  where
-    initial_choice = case bang of
-	               HsNoBang -> HsNoBang
-	               HsStrict | gopt Opt_UnboxStrictFields dflags
-                                -> can_unbox HsStrict arg_ty
-	                        | gopt Opt_UnboxStrictPrimitiveFields dflags &&
-                                  can_unbox_prim arg_ty
-                                -> HsUnpack
-                                | otherwise -> HsStrict
-                       HsNoUnpack -> HsStrict
-	               HsUnpack   -> can_unbox HsUnpackFailed arg_ty
-                       HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
-		                    	  -- Source code never has HsUnpackFailed
-
-    can_unbox :: HsBang -> TcType -> HsBang
-    -- Returns   HsUnpack  if we can unpack arg_ty
-    -- 		 fail_bang if we know what arg_ty is but we can't unpack it
-    -- 		 HsStrict  if it's abstract, so we don't know whether or not we can unbox it
-    can_unbox fail_bang arg_ty 
-       = case splitTyConApp_maybe arg_ty of
-	    Nothing -> fail_bang
-
-	    Just (arg_tycon, tycon_args) 
-              | isAbstractTyCon arg_tycon -> HsStrict	
-                      -- See Note [Don't complain about UNPACK on abstract TyCons]
-              | not (isRecursiveTyCon arg_tycon) 	-- Note [Recusive unboxing]
-	      , isProductTyCon arg_tycon 
-	      	    -- We can unbox if the type is a chain of newtypes 
-		    -- with a product tycon at the end
-              -> if isNewTyCon arg_tycon 
-                 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
-                 else HsUnpack
-
-              | otherwise -> fail_bang
-
-    -- TODO: Deal with type synonyms?
-
-    can_unbox_prim :: TcType -> Bool
-    -- We unpack any field which final unpacked size would be smaller
-    -- or equal to the size of a pointer.
-    can_unbox_prim arg_ty
-       = case splitTyConApp_maybe arg_ty of
-            Nothing -> False
-
-            Just (arg_tycon, _)
-              | isAbstractTyCon arg_tycon -> False
-                      -- See Note [Don't complain about UNPACK on abstract TyCons]
-              | isPrimTyCon arg_tycon &&
-                arg_tycon `elem` ptrSizedPrimTyCons -> True
-              -- TODO: Check that the PrimTyCon corresponds to a type
-              -- with pointer-sized representation.
-              | isEmptyDataTyCon arg_tycon -> True
-              | not (isRecursiveTyCon arg_tycon)        -- Note [Recusive unboxing]
-              , Just ty <- tyConSingleFieldDataCon_maybe arg_tycon
-              -> can_unbox_prim ty
-              | otherwise -> False
-
-ptrSizedPrimTyCons :: [TyCon]
-ptrSizedPrimTyCons =
-    [ TysPrim.addrPrimTyCon
-    , TysPrim.arrayPrimTyCon
-    , TysPrim.byteArrayPrimTyCon
-    , TysPrim.arrayArrayPrimTyCon
-    , TysPrim.charPrimTyCon
-    , TysPrim.doublePrimTyCon
-    , TysPrim.floatPrimTyCon
-    , TysPrim.intPrimTyCon
-    , TysPrim.int32PrimTyCon
-    , TysPrim.int64PrimTyCon
-    , TysPrim.mutableArrayPrimTyCon
-    , TysPrim.mutableByteArrayPrimTyCon
-    , TysPrim.mutableArrayArrayPrimTyCon
-    , TysPrim.wordPrimTyCon
-    , TysPrim.word32PrimTyCon
-    , TysPrim.word64PrimTyCon
-    ]
-
-\end{code}
-
-Note [Don't complain about UNPACK on abstract TyCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We are going to complain about UnpackFailed, but if we say
-   data T = MkT {-# UNPACK #-} !Wobble
-and Wobble is a newtype imported from a module that was compiled 
-without optimisation, we don't want to complain. Because it might
-be fine when optimsation is on.  I think this happens when Haddock
-is working over (say) GHC souce files.
-
-Note [Recursive unboxing]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Be careful not to try to unbox this!
-	data T = MkT {-# UNPACK #-} !T Int
-Reason: consider
-  data R = MkR {-# UNPACK #-} !S Int
-  data S = MkS {-# UNPACK #-} !Int
-The representation arguments of MkR are the *representation* arguments
-of S (plus Int); the rep args of MkS are Int#.  This is obviously no
-good for T, because then we'd get an infinite number of arguments.
-
-But it's the *argument* type that matters. This is fine:
-	data S = MkS S !Int
-because Int is non-recursive.
-
-
 %************************************************************************
 %*									*
 		Validity checking
@@ -1376,7 +1223,11 @@ checkValidTyCon tc
 	
 	-- Check arg types of data constructors
        ; traceTc "cvtc2" (ppr tc)
-       ; mapM_ (checkValidDataCon tc) data_cons
+
+       ; existential_ok  <- xoptM Opt_ExistentialQuantification
+       ; gadt_ok         <- xoptM Opt_GADTs
+       ; let ex_ok = existential_ok || gadt_ok	-- Data cons can have existential context
+       ; mapM_ (checkValidDataCon ex_ok tc) data_cons
 
 	-- Check that fields with the same name share a type
        ; mapM_ check_fields groups }
@@ -1436,8 +1287,8 @@ checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
     mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
 
 -------------------------------
-checkValidDataCon :: TyCon -> DataCon -> TcM ()
-checkValidDataCon tc con
+checkValidDataCon :: Bool -> TyCon -> DataCon -> TcM ()
+checkValidDataCon existential_ok tc con
   = setSrcSpan (srcLocSpan (getSrcLoc con))	$
     addErrCtxt (dataConCtxt con)		$ 
     do	{ traceTc "Validity of data con" (ppr con)
@@ -1457,7 +1308,10 @@ checkValidDataCon tc con
 	; checkValidType ctxt (dataConUserType con)
 	; when (isNewTyCon tc) (checkNewDataCon con)
 
-        ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
+        ; mapM_ check_bang (zip3 (dataConStrictMarks con) (dataConRepBangs con) [1..])
+
+        ; checkTc (existential_ok || isVanillaDataCon con)
+ 	          (badExistential con)
 
         ; checkTc (not (any (isKindVar . fst) (dataConEqSpec con)))
                   (badGadtKindCon con)
@@ -1466,8 +1320,12 @@ checkValidDataCon tc con
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
-    check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
-    check_bang _                   = return ()
+    check_bang (HsBang want_unpack, rep_bang, n) 
+      | want_unpack
+      , case rep_bang of { HsUnpack -> False; _ -> True }
+      = addWarnTc (cant_unbox_msg n)
+    check_bang _
+      = return ()
 
     cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
                            , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
@@ -1899,7 +1757,7 @@ badGadtDecl tc_name
   = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
 	 , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
 
-badExistential :: Located Name -> SDoc
+badExistential :: DataCon -> SDoc
 badExistential con_name
   = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
 		ptext (sLit "has existential type variables, a context, or a specialised result type"))
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 36c52a4ab8..458f5c6e20 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -53,7 +53,6 @@ module TyCon(
         isTyConAssoc, tyConAssoc_maybe,
         isRecursiveTyCon,
         isImplicitTyCon,
-        isEmptyDataTyCon,
 
         -- ** Extracting information out of TyCons
         tyConName,
@@ -73,7 +72,6 @@ module TyCon(
         algTyConRhs,
         newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
         tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
-        tyConSingleFieldDataCon_maybe,
 
         -- ** Manipulating TyCons
         tcExpandTyCon_maybe, coreExpandTyCon_maybe,
@@ -90,7 +88,7 @@ module TyCon(
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
-import {-# SOURCE #-} DataCon ( DataCon, dataConRepArgTys, isVanillaDataCon )
+import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 
 import Var
 import Class
@@ -1076,18 +1074,6 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs})
 isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort)
 isDataTyCon _ = False
 
-isEmptyDataTyCon :: TyCon -> Bool
-isEmptyDataTyCon (AlgTyCon {algTcRhs = DataTyCon { data_cons = [data_con] } })
-    = isEmptyDataCon data_con
-isEmptyDataTyCon (TupleTyCon {dataCon = data_con })
-    = isEmptyDataCon data_con
-isEmptyDataTyCon _ = False
-
-isEmptyDataCon :: DataCon -> Bool
-isEmptyDataCon data_con = case dataConRepArgTys data_con of
-    [] -> True
-    _  -> False
-
 -- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to
 -- themselves, even via coercions (except for unsafeCoerce).
 -- This excludes newtypes, type functions, type synonyms.
@@ -1142,27 +1128,6 @@ isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
 isProductTyCon (TupleTyCon {})  = True
 isProductTyCon _                = False
 
--- | If the given 'TyCon' has a /single/ data constructor with a /single/ field,
--- i.e. it is a @data@ type with one alternative and one field, or a @newtype@
--- then the type of that field is returned. If the 'TyCon' has a single
--- constructor with more than one field, more than one constructor, or
--- represents a primitive or function type constructor then @Nothing@ is
--- returned. In any other case, the function panics
-tyConSingleFieldDataCon_maybe :: TyCon -> Maybe Type
-tyConSingleFieldDataCon_maybe tc@(AlgTyCon {}) = case algTcRhs tc of
-    DataTyCon{ data_cons = [data_con] }
-        | isVanillaDataCon data_con -> case dataConRepArgTys data_con of
-            [ty] -> Just ty
-            _    -> Nothing
-        | otherwise -> Nothing
-    NewTyCon { data_con = data_con }
-        ->  case dataConRepArgTys data_con of
-            [ty] -> Just ty
-            _    -> pprPanic "tyConSingleFieldDataCon_maybe"
-                    (ppr $ dataConRepArgTys data_con)
-    _           -> Nothing
-tyConSingleFieldDataCon_maybe _                = Nothing
-
 -- | Is this a 'TyCon' representing a type synonym (@type@)?
 isSynTyCon :: TyCon -> Bool
 isSynTyCon (SynTyCon {}) = True