[project @ 2001-05-18 08:46:18 by simonpj]

-----------------------------
	Get unbox-strict-fields right
	-----------------------------

The problem was that when a library was compiled *without* -funbox-strict-fields,
and the main program was compiled *with* that flag, we were wrongly treating
the fields of imported data types as unboxed.

To fix this I added an extra constructor to StrictnessMark to express whether
the "!" annotation came from an interface file (don't fiddle) or a source
file (decide whether to unbox).

On the way I tided things up:

* StrictnessMark moves to Demand.lhs, and doesn't have the extra DataCon
  fields that kept it in DataCon before.

* HsDecls.BangType has one constructor, not three, with a StrictnessMark field.

* DataCon keeps track of its strictness signature (dcRepStrictness), but not
  its "user strict marks" (which were never used)

* All the functions, like getUniquesDs, that used to take an Int saying how
  many uniques to allocate, now return an infinite list. This saves arguments
  and hassle.  But it involved touching quite a few files.

* rebuildConArgs takes a list of Uniques to use as its unique supply.  This
  means I could combine DsUtils.rebuildConArgs with MkId.rebuildConArgs
  (hooray; the main point of the previous change)


I also tidied up one or two error messages

32 files changed, 294 insertions, 388 deletions

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 3a1bd476dd..293e0f1863 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -289,8 +289,8 @@ mapAndUnzipFlt f (x:xs)
 getUniqFlt :: FlatM Unique
 getUniqFlt us = uniqFromSupply us
 
-getUniqsFlt :: Int -> FlatM [Unique]
-getUniqsFlt i us = uniqsFromSupply i us
+getUniqsFlt :: FlatM [Unique]
+getUniqsFlt us = uniqsFromSupply us
 \end{code}
 
 %************************************************************************
@@ -474,7 +474,7 @@ doSimultaneously1 vertices
 	    returnFlt (CAssign the_temp src, CAssign dest the_temp)
 
 	go_via_temps (COpStmt dests op srcs vol_regs)
-	  = getUniqsFlt (length dests)	`thenFlt` \ uniqs ->
+	  = getUniqsFlt			`thenFlt` \ uniqs ->
 	    let
 		the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 	    in
diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index dd6212b735..c5dd0e1d70 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -18,9 +18,6 @@ module DataCon (
 	isExistentialDataCon, classDataCon,
 
 	splitProductType_maybe, splitProductType,
-
-	StrictnessMark(..), 	-- Representation visible to MkId only
-	markedStrict, notMarkedStrict, markedUnboxed, maybeMarkedUnboxed
     ) where
 
 #include "HsVersions.h"
@@ -40,14 +37,14 @@ import Name		( Name, NamedThing(..), nameUnique )
 import Var		( TyVar, Id )
 import FieldLabel	( FieldLabel )
 import BasicTypes	( Arity )
-import Demand		( Demand, wwStrict, wwLazy )
+import Demand		( Demand, StrictnessMark(..), wwStrict, wwLazy )
 import Outputable
 import Unique		( Unique, Uniquable(..) )
 import CmdLineOpts	( opt_UnboxStrictFields )
 import PprType		()	-- Instances
-import Maybes		( maybeToBool )
 import Maybe
 import ListSetOps	( assoc )
+import Util		( zipEqual, zipWithEqual )
 \end{code}
 
 
@@ -118,18 +115,16 @@ data DataCon
 	dcRepArgTys :: [Type],		-- Final, representation argument types, after unboxing and flattening,
 					-- and including existential dictionaries
 
+	dcRepStrictness :: [Demand],	-- One for each representation argument	
+
 	dcTyCon  :: TyCon,		-- Result tycon
 
 	-- Now the strictness annotations and field labels of the constructor
-	dcUserStricts :: [StrictnessMark],
-		-- Strictness annotations, as placed on the data type defn,
-		-- in the same order as the argument types;
-		-- length = dataConSourceArity dataCon
-
-	dcRealStricts :: [StrictnessMark],
-		-- Strictness annotations as deduced by the compiler.  May
-		-- include some MarkedUnboxed fields that are merely MarkedStrict
-		-- in dcUserStricts.  Also includes the existential dictionaries.
+	dcStrictMarks :: [StrictnessMark],
+		-- Strictness annotations as deduced by the compiler.  
+		-- Has no MarkedUserStrict; they have been changed to MarkedStrict
+		-- or MarkedUnboxed by the compiler.
+		-- *Includes the existential dictionaries*
 		-- length = length dcExTheta + dataConSourceArity dataCon
 
 	dcFields  :: [FieldLabel],
@@ -174,26 +169,6 @@ Actually, the unboxed part isn't implemented yet!
 
 %************************************************************************
 %*									*
-\subsection{Strictness indication}
-%*									*
-%************************************************************************
-
-\begin{code}
-data StrictnessMark = MarkedStrict
-		    | MarkedUnboxed DataCon [Type]
-		    | NotMarkedStrict
-
-markedStrict    = MarkedStrict
-notMarkedStrict = NotMarkedStrict
-markedUnboxed   = MarkedUnboxed (panic "markedUnboxed1") (panic "markedUnboxed2")
-
-maybeMarkedUnboxed (MarkedUnboxed dc tys) = Just (dc,tys)
-maybeMarkedUnboxed other		  = Nothing
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection{Instances}
 %*									*
 %************************************************************************
@@ -254,18 +229,23 @@ mkDataCon name arg_stricts fields
 		  dcOrigArgTys = orig_arg_tys,
 		  dcRepArgTys = rep_arg_tys,
 	     	  dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
-		  dcRealStricts = all_stricts, dcUserStricts = user_stricts,
+		  dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_demands,
 		  dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
 		  dcId = work_id, dcWrapId = wrap_id}
 
-    (real_arg_stricts, strict_arg_tyss)
-	= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
-    rep_arg_tys = mkPredTys ex_theta ++ concat strict_arg_tyss
-	
-    ex_dict_stricts = map mk_dict_strict_mark ex_theta
-	-- Add a strictness flag for the existential dictionary arguments
-    all_stricts     = ex_dict_stricts ++ real_arg_stricts
-    user_stricts    = ex_dict_stricts ++ arg_stricts
+	-- Strictness marks for source-args
+	--	*after unboxing choices*, 
+	-- but  *including existential dictionaries*
+    real_stricts = (map mk_dict_strict_mark ex_theta) ++
+		   zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) 
+				orig_arg_tys arg_stricts 
+
+	-- Representation arguments and demands
+    (rep_arg_demands, rep_arg_tys) 
+	= unzip $ concat $ 
+	  zipWithEqual "mkDataCon2" unbox_strict_arg_ty 
+		       real_stricts 
+		       (mkPredTys ex_theta ++ orig_arg_tys)
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys (tyvars ++ ex_tyvars)
@@ -304,7 +284,7 @@ dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConFieldLabels = dcFields
 
 dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks = dcRealStricts
+dataConStrictMarks = dcStrictMarks
 
 -- Number of type-instantiation arguments
 -- All the remaining arguments of the DataCon are (notionally)
@@ -326,13 +306,7 @@ isNullaryDataCon con  = dataConRepArity con == 0
 dataConRepStrictness :: DataCon -> [Demand]
 	-- Give the demands on the arguments of a
 	-- Core constructor application (Con dc args)
-dataConRepStrictness dc
-  = go (dcRealStricts dc)
-  where
-    go []			  = []
-    go (MarkedStrict        : ss) = wwStrict : go ss
-    go (NotMarkedStrict     : ss) = wwLazy   : go ss
-    go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
+dataConRepStrictness dc = dcRepStrictness dc
 
 dataConSig :: DataCon -> ([TyVar], ThetaType,
 			  [TyVar], ThetaType,
@@ -449,23 +423,36 @@ splitProductType str ty
 -- some without, the compiler doesn't get confused about the constructor
 -- representations.
 
-unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type])
-
-unbox_strict_arg_ty tycon strict_mark ty
-  | case strict_mark of
-	NotMarkedStrict   -> False
-	MarkedUnboxed _ _ -> True				-- !! From interface file
-	MarkedStrict      -> opt_UnboxStrictFields &&		-- !  From source
-			     maybeToBool maybe_product &&
-			     not (isRecursiveTyCon tycon) &&
-			     isDataTyCon arg_tycon
-	-- We can't look through newtypes in arguments (yet)
-  = (MarkedUnboxed con arg_tys, arg_tys)
+chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark
+	-- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict
+chooseBoxingStrategy tycon arg_ty strict
+  = case strict of
+	MarkedUserStrict | unbox arg_ty -> MarkedUnboxed
+			 | otherwise    -> MarkedStrict
+	other			  	-> strict
+  where
+    unbox ty = opt_UnboxStrictFields &&
+	       case splitTyConApp_maybe ty of
+		  Just (arg_tycon, _) -> not (isRecursiveTyCon arg_tycon) && 
+					 isProductTyCon arg_tycon && 
+					 isDataTyCon arg_tycon
+		  Nothing	      -> False
+	-- Recursion: check whether the *argument* type constructor is
+	-- recursive.  Checking the *parent* tycon is over-conservative
+	--
+	-- We can't look through newtypes in arguments (yet); hence isDataTyCon
 
-  | otherwise
-  = (strict_mark, [ty])
 
+unbox_strict_arg_ty 
+	:: StrictnessMark	-- After strategy choice; can't be MkaredUserStrict
+	-> Type			-- Source argument type
+	-> [(Demand,Type)]	-- Representation argument types and demamds
+	
+unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy,   ty)]
+unbox_strict_arg_ty MarkedStrict    ty = [(wwStrict, ty)]
+unbox_strict_arg_ty MarkedUnboxed   ty 
+  = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys
   where
-    maybe_product = splitProductType_maybe ty
-    Just (arg_tycon, _, con, arg_tys) = maybe_product
+    (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+
 \end{code}
diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs
index 546e3a2bbb..17d13dc162 100644
--- a/ghc/compiler/basicTypes/Demand.lhs
+++ b/ghc/compiler/basicTypes/Demand.lhs
@@ -17,6 +17,8 @@ module Demand(
 	noStrictnessInfo,
 	ppStrictnessInfo, seqStrictnessInfo,
 	isBottomingStrictness, appIsBottom,
+
+	StrictnessMark(..), isMarkedUnboxed, isMarkedStrict
      ) where
 
 #include "HsVersions.h"
@@ -207,3 +209,35 @@ ppStrictnessInfo NoStrictnessInfo		   = empty
 ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Strictness indication}
+%*									*
+%************************************************************************
+
+The strictness annotations on types in data type declarations
+e.g. 	data T = MkT !Int !(Bool,Bool)
+
+\begin{code}
+data StrictnessMark
+   = MarkedUserStrict	-- "!"  in a source decl
+   | MarkedStrict	-- "!"  in an interface decl: strict but not unboxed
+   | MarkedUnboxed	-- "!!" in an interface decl: unboxed 
+   | NotMarkedStrict	-- No annotation at all
+   deriving( Eq )
+
+isMarkedUnboxed MarkedUnboxed = True
+isMarkedUnboxed other	      = False
+
+isMarkedStrict NotMarkedStrict = False
+isMarkedStrict other	       = True	-- All others are strict
+
+instance Outputable StrictnessMark where
+  ppr MarkedUserStrict = ptext SLIT("!u")
+  ppr MarkedStrict     = ptext SLIT("!")
+  ppr MarkedUnboxed    = ptext SLIT("! !")
+  ppr NotMarkedStrict  = empty
+\end{code}
+
+
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index c59fefe256..8e496b3170 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -98,8 +98,7 @@ import TysPrim		( statePrimTyCon )
 import FieldLabel	( FieldLabel )
 import SrcLoc		( SrcLoc )
 import Outputable
-import Unique		( Unique, mkBuiltinUnique, getBuiltinUniques, 
-			  getNumBuiltinUniques )
+import Unique		( Unique, mkBuiltinUnique )
 
 infixl 	1 `setIdUnfolding`,
 	  `setIdArityInfo`,
@@ -173,15 +172,11 @@ mkWorkerId uniq unwrkr ty
 
 -- "Template locals" typically used in unfoldings
 mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
-			       (getBuiltinUniques (length tys))
-			       tys
+mkTemplateLocals tys = zipWith mkTemplateLocal [1..] tys
 
 mkTemplateLocalsNum :: Int -> [Type] -> [Id]
 -- The Int gives the starting point for unique allocation
-mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
-			    	    (getNumBuiltinUniques n (length tys))
-			       	    tys
+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
 
 mkTemplateLocal :: Int -> Type -> Id
 mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index dae32dfeb5..b639f2178f 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -17,7 +17,7 @@ module MkId (
 	mkDictSelId,
 
 	mkDataConId, mkDataConWrapId,
-	mkRecordSelId,
+	mkRecordSelId, rebuildConArgs,
 	mkPrimOpId, mkCCallOpId,
 
 	-- And some particular Ids; see below for why they are wired in
@@ -59,16 +59,17 @@ import PrimOp		( PrimOp(DataToTagOp, CCallOp),
 			  primOpSig, mkPrimOpIdName,
 			  CCall, pprCCallOp
 			)
-import Demand		( wwStrict, wwPrim, mkStrictnessInfo )
-import DataCon		( DataCon, StrictnessMark(..), 
+import Demand		( wwStrict, wwPrim, mkStrictnessInfo, 
+			  StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import DataCon		( DataCon, 
 			  dataConFieldLabels, dataConRepArity, dataConTyCon,
 			  dataConArgTys, dataConRepType, dataConRepStrictness, 
 			  dataConInstOrigArgTys,
                           dataConName, dataConTheta,
 			  dataConSig, dataConStrictMarks, dataConId,
-			  maybeMarkedUnboxed, splitProductType_maybe
+			  splitProductType
 			)
-import Id		( idType, mkGlobalId, mkVanillaGlobal,
+import Id		( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
 			  mkTemplateLocals, mkTemplateLocalsNum,
 			  mkTemplateLocal, idCprInfo
 			)
@@ -83,6 +84,7 @@ import FieldLabel	( mkFieldLabel, fieldLabelName,
 			  firstFieldLabelTag, allFieldLabelTags, fieldLabelType
 			)
 import CoreSyn
+import Unique		( mkBuiltinUnique )
 import Maybes
 import PrelNames
 import Maybe            ( isJust )
@@ -239,7 +241,7 @@ mkDataConWrapId data_con
 	       mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
 	       Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
 
-	     | null dict_args && all not_marked_strict strict_marks
+	     | null dict_args && not (any isMarkedStrict strict_marks)
 	     = Var work_id	-- The common case.  Not only is this efficient,
 				-- but it also ensures that the wrapper is replaced
 				-- by the worker even when there are no args.
@@ -286,15 +288,12 @@ mkDataConWrapId data_con
     (id_arg1:_)   = id_args		-- Used for newtype only
 
     strict_marks  = dataConStrictMarks data_con
-    not_marked_strict NotMarkedStrict = True
-    not_marked_strict other	      = False
-
 
     mk_case 
-	   :: (Id, StrictnessMark)	-- arg, strictness
-	   -> (Int -> [Id] -> CoreExpr) -- body
-	   -> Int			-- next rep arg id
-	   -> [Id]			-- rep args so far
+	   :: (Id, StrictnessMark)	-- 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
@@ -304,11 +303,12 @@ mkDataConWrapId data_con
 		   | otherwise ->
 			Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
 
-		MarkedUnboxed con tys ->
+		MarkedUnboxed ->
 		   Case (Var arg) arg [(DataAlt con, con_args,
-					body i' (reverse con_args++rep_args))]
+					body i' (reverse con_args ++ rep_args))]
 		   where 
-			(con_args,i') = mkLocals i tys
+			(con_args, i')   = mkLocals i tys
+			(_, _, con, tys) = splitProductType "mk_case" (idType arg)
 \end{code}
 
 
@@ -451,12 +451,12 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
     mk_maybe_alt data_con 
 	  = case maybe_the_arg_id of
 		Nothing		-> Nothing
-		Just the_arg_id -> Just (DataAlt data_con, real_args, expr)
+		Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
 		  where
-	    	    body 	      = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
-	    	    strict_marks      = dataConStrictMarks data_con
-	    	    (expr, real_args) = rebuildConArgs data_con arg_ids strict_marks body
-						       unpack_base
+	    	    body 	       = mkVarApps (mkVarApps (Var the_arg_id) field_tyvars) field_dict_ids
+	    	    strict_marks       = dataConStrictMarks data_con
+	    	    (binds, real_args) = rebuildConArgs arg_ids strict_marks
+						        (map mkBuiltinUnique [unpack_base..])
 	where
             arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
 
@@ -480,41 +480,42 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
     full_msg   = showSDoc (sep [text "No match in record selector", ppr sel_id]) 
 
 
--- this rather ugly function converts the unpacked data con arguments back into
--- their packed form.  It is almost the same as the version in DsUtils, except that
--- we use template locals here rather than newDsId (ToDo: merge these).
+-- This rather ugly function converts the unpacked data con 
+-- arguments back into their packed form.
 
 rebuildConArgs
-  :: DataCon				-- the con we're matching on
-  -> [Id]				-- the source-level args
-  -> [StrictnessMark]			-- the strictness annotations (per-arg)
-  -> CoreExpr				-- the body
-  -> Int				-- template local
-  -> (CoreExpr, [Id])
-
-rebuildConArgs con [] stricts body i = (body, [])
-rebuildConArgs con (arg:args) stricts body i | isTyVar arg
-  = let (body', args') = rebuildConArgs con args stricts body i
-    in  (body',arg:args')
-rebuildConArgs con (arg:args) (str:stricts) body i
-  = case maybeMarkedUnboxed str of
-	Just (pack_con1, _) -> 
-	    case splitProductType_maybe (idType arg) of
-		Just (_, tycon_args, pack_con, con_arg_tys) ->
-		    ASSERT( pack_con == pack_con1 )
-		    let unpacked_args = zipWith mkTemplateLocal [i..] con_arg_tys
-			(body', real_args) = rebuildConArgs con args stricts body 
-						(i + length con_arg_tys)
-		    in
-		    (
-			 Let (NonRec arg (mkConApp pack_con 
-				   	          (map Type tycon_args ++
-				        	   map Var  unpacked_args))) body', 
-			 unpacked_args ++ real_args
-		    )
-
-	_ -> let (body', args') = rebuildConArgs con args stricts body i
-	     in  (body', arg:args')
+  :: [Id]			-- Source-level args
+  -> [StrictnessMark]		-- Strictness annotations (per-arg)
+  -> [Unique]			-- Uniques for the new Ids
+  -> ([CoreBind], [Id])		-- A binding for each source-level arg, plus
+				-- a list of the representation-level arguments 
+-- e.g.   data T = MkT Int !Int
+--
+-- rebuild [x::Int, y::Int] [Not, Unbox]
+--  = ([ y = I# t ], [x,t])
+
+rebuildConArgs []	  stricts us = ([], [])
+
+-- Type variable case
+rebuildConArgs (arg:args) stricts us 
+  | isTyVar arg
+  = let (binds, args') = rebuildConArgs args stricts us
+    in  (binds, arg:args')
+
+-- Term variable case
+rebuildConArgs (arg:args) (str:stricts) us
+  | isMarkedUnboxed str
+  = let
+	(_, tycon_args, pack_con, con_arg_tys) = splitProductType "rebuildConArgs" (idType arg)
+	unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
+	(binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
+	con_app	       = mkConApp pack_con (map Type tycon_args ++ map Var  unpacked_args)
+    in
+    (NonRec arg con_app : binds, unpacked_args ++ args')
+
+  | otherwise
+  = let (binds, args') = rebuildConArgs args stricts us
+    in  (binds, arg:args')
 \end{code}
 
 
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index a24a4c1996..218df9ee90 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -66,7 +66,7 @@ mkSplitUniqSupply :: Char -> IO UniqSupply
 
 splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
 uniqFromSupply  :: UniqSupply -> Unique
-uniqsFromSupply :: Int -> UniqSupply -> [Unique]
+uniqsFromSupply :: UniqSupply -> [Unique]	-- Infinite
 \end{code}
 
 \begin{code}
@@ -94,13 +94,8 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
 \end{code}
 
 \begin{code}
-uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
-
-uniqsFromSupply (I# i) supply = i `get_from` supply
-  where
-    get_from 0# _ = []
-    get_from n (MkSplitUniqSupply (I# u) _ s2)
-      = mkUniqueGrimily u : get_from (n -# 1#) s2
+uniqFromSupply  (MkSplitUniqSupply (I# n) _ _)  = mkUniqueGrimily n
+uniqsFromSupply (MkSplitUniqSupply (I# n) _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
 \end{code}
 
 %************************************************************************
@@ -157,9 +152,9 @@ getUniqueUs :: UniqSM Unique
 getUniqueUs us = case splitUniqSupply us of
 		   (us1,us2) -> (uniqFromSupply us1, us2)
 
-getUniquesUs :: Int -> UniqSM [Unique]
-getUniquesUs n us = case splitUniqSupply us of
-		      (us1,us2) -> (uniqsFromSupply n us1, us2)
+getUniquesUs :: UniqSM [Unique]
+getUniquesUs us = case splitUniqSupply us of
+		      (us1,us2) -> (uniqsFromSupply us1, us2)
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index feb4e8ed1c..86e6d600b6 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -41,7 +41,7 @@ module Unique (
 	mkPreludeMiscIdUnique, mkPreludeDataConUnique,
 	mkPreludeTyConUnique, mkPreludeClassUnique,
 
-	getNumBuiltinUniques, getBuiltinUniques, mkBuiltinUnique,
+	mkBuiltinUnique,
 	mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
     ) where
 
@@ -330,15 +330,5 @@ mkBuiltinUnique i = mkUnique 'B' i
 mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
 mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
 mkPseudoUnique3 i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs
-
-
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-
-getNumBuiltinUniques :: Int        -- First unique
-                     -> Int        -- Number required
-                     -> [Unique]
-getNumBuiltinUniques base n = map (mkUnique 'B') [base .. base+n-1]
 \end{code}
 
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 90a3ead69f..ec86225e18 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -665,14 +665,14 @@ subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq)
 
 substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 substAndCloneIds subst us ids
-  = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply (length ids) us)
+  = mapAccumL (subst_clone_id subst) subst (ids `zip` uniqsFromSupply us)
 
 substAndCloneRecIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])
 substAndCloneRecIds subst us ids
   = (subst', ids')
   where
     (subst', ids') = mapAccumL (subst_clone_id subst') subst
-			       (ids `zip` uniqsFromSupply (length ids) us)
+			       (ids `zip` uniqsFromSupply us)
 
 substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id)
 substAndCloneId subst@(Subst in_scope env) us old_id
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index a83a1f4a7b..717faad02c 100644
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -14,7 +14,7 @@ module DsMonad (
 	newFailLocalDs,
 	getSrcLocDs, putSrcLocDs,
 	getModuleDs,
-	getUniqueDs,
+	getUniqueDs, getUniquesDs,
 	getDOptsDs,
 	dsLookupGlobalValue,
 
@@ -152,8 +152,11 @@ newFailLocalDs ty dflags us genv loc mod warns
 
 getUniqueDs :: DsM Unique
 getUniqueDs dflags us genv loc mod warns
-  = case (uniqFromSupply us) of { assigned_uniq ->
-    (assigned_uniq, warns) }
+  = (uniqFromSupply us, warns)
+
+getUniquesDs :: DsM [Unique]
+getUniquesDs dflags us genv loc mod warns
+  = (uniqsFromSupply us, warns)
 
 getDOptsDs :: DsM DynFlags
 getDOptsDs dflags us genv loc mod warns
@@ -166,16 +169,13 @@ duplicateLocalDs old_local dflags us genv loc mod warns
 
 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 cloneTyVarsDs tyvars dflags us genv loc mod warns
-  = case uniqsFromSupply (length tyvars) us of { uniqs ->
-    (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
+  = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns)
 \end{code}
 
 \begin{code}
 newTyVarsDs :: [TyVar] -> DsM [TyVar]
-
 newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
-  = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
-    (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
+  = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns)
 \end{code}
 
 We can also reach out and either set/grab location information from
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 15e08a8eb9..12ea7df333 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -41,12 +41,11 @@ import DsMonad
 
 import CoreUtils	( exprType, mkIfThenElse )
 import PrelInfo		( iRREFUT_PAT_ERROR_ID )
+import MkId		( rebuildConArgs )
 import Id		( idType, Id, mkWildId )
 import Literal		( Literal(..), inIntRange, tARGET_MAX_INT )
 import TyCon		( isNewTyCon, tyConDataCons )
-import DataCon		( DataCon, StrictnessMark, maybeMarkedUnboxed, 
-			  dataConStrictMarks, dataConId, splitProductType_maybe
-			)
+import DataCon		( DataCon, dataConStrictMarks, dataConId )
 import Type		( mkFunTy, isUnLiftedType, splitAlgTyConApp,
 			  Type
 			)
@@ -298,10 +297,12 @@ mkCoAlgCaseMatchResult var match_alts
 		   returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 
     mk_alt fail (con, args, MatchResult _ body_fn)
-	= body_fn fail		`thenDs` \ body ->
-	  rebuildConArgs con args (dataConStrictMarks con) body 
-				`thenDs` \ (body', real_args) ->
-	  returnDs (DataAlt con, real_args, body')
+	= body_fn fail						`thenDs` \ body ->
+	  getUniquesDs						`thenDs` \ us ->
+	  let
+	     (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
+	  in
+	  returnDs (DataAlt con, real_args, mkDsLets binds body)
 
     mk_default fail | exhaustive_case = []
 		    | otherwise       = [(DEFAULT, [], fail)]
@@ -310,39 +311,7 @@ mkCoAlgCaseMatchResult var match_alts
         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 \end{code}
-%
-For each constructor we match on, we might need to re-pack some
-of the strict fields if they are unpacked in the constructor.
-%
-\begin{code}
-rebuildConArgs
-  :: DataCon				-- the con we're matching on
-  -> [Id]				-- the source-level args
-  -> [StrictnessMark]			-- the strictness annotations (per-arg)
-  -> CoreExpr				-- the body
-  -> DsM (CoreExpr, [Id])
-
-rebuildConArgs con [] stricts body = returnDs (body, [])
-rebuildConArgs con (arg:args) stricts body | isTyVar arg
-  = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
-    returnDs (body',arg:args')
-rebuildConArgs con (arg:args) (str:stricts) body
-  = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
-    case maybeMarkedUnboxed str of
-	Just (pack_con1, _) -> 
-	    case splitProductType_maybe (idType arg) of
-		Just (_, tycon_args, pack_con, con_arg_tys) ->
-		    ASSERT( pack_con == pack_con1 )
-		    newSysLocalsDs con_arg_tys 		`thenDs` \ unpacked_args ->
-		    returnDs (
-			 mkDsLet (NonRec arg (mkConApp pack_con 
-				   	          (map Type tycon_args ++
-				        	   map Var  unpacked_args))) body', 
-			 unpacked_args ++ real_args
-		    )
-		
-	_ -> returnDs (body', arg:real_args)
-\end{code}
+
 
 %************************************************************************
 %*									*
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index a537ee8164..0ca118b3b8 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -111,14 +111,14 @@ pp_context NoMatchContext msg rest_of_msg_fun
   = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
 
 pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
-  = addWarnLocHdrLine loc message (nest 8 (rest_of_msg_fun pref))
+  = addWarnLocHdrLine loc 
+	(ptext SLIT("Pattern match(es)") <+> msg)
+	(sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
   where
     (ppr_match, pref)
 	= case kind of
 	     FunRhs fun -> (pprMatchContext kind,		    \ pp -> ppr fun <+> pp)
 	     other	-> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp)
-          
-    message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
 
 ppr_pats pats = sep (map ppr pats)
 
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index d6901889f6..33ef7368ba 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -12,7 +12,7 @@ module HsDecls (
 	DefaultDecl(..), ForeignDecl(..), ForKind(..),
 	ExtName(..), isDynamicExtName, extNameStatic,
 	ConDecl(..), ConDetails(..), 
-	BangType(..), getBangType,
+	BangType(..), getBangType, getBangStrictness, unbangedType,
 	DeprecDecl(..), DeprecTxt,
 	hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
 	isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
@@ -32,6 +32,7 @@ import HsCore		( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
 			)
 import CoreSyn		( CoreRule(..) )
 import BasicTypes	( NewOrData(..) )
+import Demand		( StrictnessMark(..) )
 import CallConv		( CallConv, pprCallConv )
 
 -- others:
@@ -556,19 +557,14 @@ eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
 \end{code}
   
 \begin{code}
-data BangType name
-  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
-  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
-  | Unpacked (HsType name)	-- Field is strict and to be unpacked if poss.
-
-getBangType (Banged ty)   = ty
-getBangType (Unbanged ty) = ty
-getBangType (Unpacked ty) = ty
-
-eq_btype env (Banged t1)   (Banged t2)   = eq_hsType env t1 t2
-eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
-eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
-eq_btype env _		   _		 = False
+data BangType name = BangType StrictnessMark (HsType name)
+
+getBangType       (BangType _ ty) = ty
+getBangStrictness (BangType s _)  = s
+
+unbangedType ty = BangType NotMarkedStrict ty
+
+eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2
 \end{code}
 
 \begin{code}
@@ -592,9 +588,7 @@ ppr_con_details con (RecCon fields)
 instance Outputable name => Outputable (BangType name) where
     ppr = ppr_bang
 
-ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
-ppr_bang (Unbanged ty) = pprParendHsType ty
-ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
+ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty
 \end{code}
 
 
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 7667b4517d..4671fc4ebb 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -207,13 +207,6 @@ data ModDetails
 \end{code}
 
 \begin{code}
-emptyModDetails :: ModDetails
-emptyModDetails
-  = ModDetails { md_types = emptyTypeEnv,
-                 md_insts = [],
-                 md_rules = []
-    }
-
 emptyModIface :: Module -> ModIface
 emptyModIface mod
   = ModIface { mi_module   = mod,
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 45828c7630..49c1cb1404 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -34,7 +34,7 @@ import CmdLineOpts
 import Id		( idType, idInfo, isImplicitId, idCgInfo,
 			  isLocalId, idName,
 			)
-import DataCon		( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon		( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
 import IdInfo		-- Lots
 import CoreSyn		( CoreRule(..) )
 import CoreFVs		( ruleLhsFreeNames )
@@ -202,20 +202,18 @@ ifaceTyCls (ATyCon tycon) so_far
 	where
 	  (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
           field_labels   = dataConFieldLabels data_con
-          strict_marks   = dataConStrictMarks data_con
+          strict_marks   = drop (length ex_theta) (dataConStrictMarks data_con)
+				-- The 'drop' is because dataConStrictMarks
+				-- includes the existential dictionaries
 	  details | null field_labels
 	    	  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
-	    	    VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
+	    	    VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys))
 
     	    	  | otherwise
 	    	  = RecCon (zipWith mk_field strict_marks field_labels)
 
-    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
-    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
-    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
-
     mk_field strict_mark field_label
-	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+	= ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
 
 ifaceTyCls (AnId id) so_far
   | isImplicitId id = so_far
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 5c4e6a47e4..47b0d16e19 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -42,7 +42,7 @@ import CallConv
 import OccName  	( dataName, varName, tcClsName,
 			  occNameSpace, setOccNameSpace, occNameUserString )
 import FastString	( unpackFS )
-import UniqFM		( UniqFM, listToUFM, lookupUFM )
+import UniqFM		( UniqFM, listToUFM )
 import Outputable
 
 -----------------------------------------------------------------------------
@@ -68,7 +68,7 @@ mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDeta
 mkVanillaCon ty tys
  = split ty tys
  where
-   split (HsAppTy t u)  ts = split t (Unbanged u : ts)
+   split (HsAppTy t u)  ts = split t (unbangedType u : ts)
    split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
 			     returnP (data_con, VanillaCon ts)
    split _		 _ = parseError "Illegal data/newtype declaration"
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index ca4fafbdd6..f83ce6f38a 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.63 2001/05/09 13:05:07 simonpj Exp $
+$Id: Parser.y,v 1.64 2001/05/18 08:46:20 simonpj Exp $
 
 Haskell grammar.
 
@@ -25,6 +25,7 @@ import OccName		( UserFS, varName, tcName, dataName, tcClsName, tvName )
 import SrcLoc		( SrcLoc )
 import Module
 import CallConv
+import Demand		( StrictnessMark(..) )
 import CmdLineOpts	( opt_SccProfilingOn )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
 import Panic
@@ -574,9 +575,9 @@ varids0	:: { [RdrName] }
 -- Datatype declarations
 
 newconstr :: { RdrNameConDecl }
-	: srcloc conid atype	{ mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
+	: srcloc conid atype	{ mkConDecl $2 [] [] (VanillaCon [unbangedType $3]) $1 }
 	| srcloc conid '{' var '::' type '}'
-				{ mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
+				{ mkConDecl $2 [] [] (RecCon [([$4], unbangedType $6)]) $1 }
 
 constrs :: { [RdrNameConDecl] }
 	: constrs '|' constr		{ $3 : $1 }
@@ -597,18 +598,18 @@ context :: { RdrNameContext }
 
 constr_stuff :: { (RdrName, RdrNameConDetails) }
 	: btype				{% mkVanillaCon $1 []		    }
-	| btype '!' atype satypes	{% mkVanillaCon $1 (Banged $3 : $4) }
+	| btype '!' atype satypes	{% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) }
 	| gtycon '{' fielddecls '}' 	{% mkRecCon $1 $3 }
 	| sbtype conop sbtype		{ ($2, InfixCon $1 $3) }
 
 satypes	:: { [RdrNameBangType] }
-	: atype satypes			{ Unbanged $1 : $2 }
-	| '!' atype satypes		{ Banged   $2 : $3 }
+	: atype satypes			{ unbangedType $1 : $2 }
+	| '!' atype satypes		{ BangType MarkedUserStrict $2 : $3 }
 	| {- empty -}			{ [] }
 
 sbtype :: { RdrNameBangType }
-	: btype				{ Unbanged $1 }
-	| '!' atype			{ Banged   $2 }
+	: btype				{ unbangedType $1 }
+	| '!' atype			{ BangType MarkedUserStrict $2 }
 
 fielddecls :: { [([RdrName],RdrNameBangType)] }
 	: fielddecl ',' fielddecls	{ $1 : $3 }
@@ -618,8 +619,8 @@ fielddecl :: { ([RdrName],RdrNameBangType) }
 	: sig_vars '::' stype		{ (reverse $1, $3) }
 
 stype :: { RdrNameBangType }
-	: ctype				{ Unbanged $1 }	
-	| '!' atype			{ Banged   $2 }
+	: ctype				{ unbangedType $1 }
+	| '!' atype			{ BangType MarkedUserStrict $2 }
 
 deriving :: { Maybe [RdrName] }
 	: {- empty -}			{ Nothing }
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 57695057cd..5e10b29e13 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -103,7 +103,8 @@ import Name		( Name, nameRdrName, nameUnique, nameOccName,
 			  nameModule, mkWiredInName )
 import OccName		( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
 import RdrName		( rdrNameOcc )
-import DataCon		( DataCon, StrictnessMark(..),  mkDataCon, dataConId )
+import DataCon		( DataCon, mkDataCon, dataConId )
+import Demand		( StrictnessMark(..) )
 import Var		( TyVar, tyVarKind )
 import TyCon		( TyCon, AlgTyConFlavour(..), tyConDataCons,
 			  mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index e4bcf4b67f..4a942ead6b 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -42,6 +42,7 @@ import BasicTypes	( Fixity(..), FixityDirection(..),
 			  NewOrData(..), Version, initialVersion, Boxity(..)
 			)
 import CostCentre       ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
+import Demand		( StrictnessMark(..) )
 import CallConv         ( cCallConv )
 import Type		( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
 import IdInfo           ( InlinePragInfo(..) )
@@ -477,9 +478,9 @@ constr		:  src_loc ex_stuff qdata_name batypes		{ mk_con_decl $3 $2 (VanillaCon
                 -- We use "data_fs" so as to include ()
 
 newtype_constr	:: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr	: src_loc '=' ex_stuff qdata_name atype	{ [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
+newtype_constr	: src_loc '=' ex_stuff qdata_name atype	{ [mk_con_decl $4 $3 (VanillaCon [unbangedType $5]) $1] }
 		| src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'
-							{ [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] }
+							{ [mk_con_decl $4 $3 (RecCon [([$6], unbangedType $8)]) $1] }
 
 ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
 ex_stuff	:                                       { ([],[]) }
@@ -490,18 +491,18 @@ batypes		:  					{ [] }
 		|  batype batypes			{ $1 : $2 }
 
 batype		:: { RdrNameBangType }
-batype		:  tatype				{ Unbanged $1 }
-		|  '!' tatype				{ Banged   $2 }
-		|  '!' '!' tatype			{ Unpacked $3 }
+batype		:  tatype				{ unbangedType $1 }
+		|  '!' tatype				{ BangType MarkedStrict    $2 }
+		|  '!' '!' tatype			{ BangType MarkedUnboxed   $3 }
 
 fields1		:: { [([RdrName], RdrNameBangType)] }
 fields1		: field					{ [$1] }
 		| field ',' fields1			{ $1 : $3 }
 
 field		:: { ([RdrName], RdrNameBangType) }
-field		:  qvar_names1 '::' ttype		{ ($1, Unbanged $3) }
-		|  qvar_names1 '::' '!' ttype    	{ ($1, Banged   $4) }
-		|  qvar_names1 '::' '!' '!' ttype	{ ($1, Unpacked $5) }
+field		:  qvar_names1 '::' ttype		{ ($1, unbangedType $3) }
+		|  qvar_names1 '::' '!' ttype    	{ ($1, BangType MarkedStrict    $4) }
+		|  qvar_names1 '::' '!' '!' ttype	{ ($1, BangType MarkedUnboxed   $5) }
 
 --------------------------------------------------------------------------
 
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 137e916192..33dacd7d73 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -546,29 +546,6 @@ renameSig (NoInlineSig v p src_loc)
     returnRn (NoInlineSig new_v p src_loc)
 \end{code}
 
-\begin{code}
-renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
-renameIE lookup_occ_nm (IEVar v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEVar new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAbs v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEThingAbs new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingAll v)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    returnRn (IEThingAll new_v, unitFV new_v)
-
-renameIE lookup_occ_nm (IEThingWith v vs)
-  = lookup_occ_nm v		`thenRn` \ new_v ->
-    mapRn lookup_occ_nm vs	`thenRn` \ new_vs ->
-    returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
-
-renameIE lookup_occ_nm (IEModuleContents m)
-  = returnRn (IEModuleContents m, emptyFVs)
-\end{code}
-
 
 %************************************************************************
 %*									*
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index d402a4c214..8f536984b0 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -12,7 +12,6 @@ import {-# SOURCE #-} RnHiFiles
 
 import HsSyn
 import RdrHsSyn		( RdrNameIE )
-import RnHsSyn		( RenamedTyClDecl )
 import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
 			  mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv
 			)
@@ -39,11 +38,10 @@ import Module		( ModuleName, moduleName, mkVanillaModule,
 import PrelNames	( mkUnboundName, syntaxList, SyntaxMap,	vanillaSyntaxMap,
 			  derivingOccurrences,
 			  mAIN_Name, pREL_MAIN_Name, 
-			  ioTyConName, integerTyConName, doubleTyConName, intTyConName, 
+			  ioTyConName, intTyConName, 
 			  boolTyConName, funTyConName,
 			  unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
 			  eqStringName, printName, 
-			  hasKey, fractionalClassKey, numClassKey,
 			  bindIOName, returnIOName, failIOName
 			)
 import TysWiredIn	( unitTyCon )	-- A little odd
@@ -458,9 +456,8 @@ newLocalsRn :: [(RdrName,SrcLoc)]
 newLocalsRn rdr_names_w_loc
  =  getNameSupplyRn		`thenRn` \ name_supply ->
     let
-	n	   = length rdr_names_w_loc
 	(us', us1) = splitUniqSupply (nsUniqs name_supply)
-	uniqs	   = uniqsFromSupply n us1
+	uniqs	   = uniqsFromSupply us1
 	names	   = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
 		     | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
 		     ]
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 4477e89df4..87f8953059 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -508,10 +508,10 @@ mkHiPath hi_boot_file locn
 	if b then returnRn hi_boot_ver_path
 	     else returnRn hi_boot_path
   | otherwise    = returnRn hi_path
-	where (Just hi_path)    = ml_hi_file locn
-	      (hi_base, hi_suf) = splitFilename hi_path
-    	      hi_boot_path      = hi_base ++ ".hi-boot"
-    	      hi_boot_ver_path  = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
+	where (Just hi_path)     = ml_hi_file locn
+	      (hi_base, _hi_suf) = splitFilename hi_path
+    	      hi_boot_path       = hi_base ++ ".hi-boot"
+    	      hi_boot_ver_path   = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
 \end{code}
 
 @readIface@ tries just the one file.
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 0023a130c5..65fbfd50ee 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -488,17 +488,9 @@ rnField doc (names, ty)
     rnBangTy doc ty		`thenRn` \ new_ty ->
     returnRn (new_names, new_ty) 
 
-rnBangTy doc (Banged ty)
+rnBangTy doc (BangType s ty)
   = rnHsType doc ty		`thenRn` \ new_ty ->
-    returnRn (Banged new_ty)
-
-rnBangTy doc (Unbanged ty)
-  = rnHsType doc ty 		`thenRn` \ new_ty ->
-    returnRn (Unbanged new_ty)
-
-rnBangTy doc (Unpacked ty)
-  = rnHsType doc ty 		`thenRn` \ new_ty ->
-    returnRn (Unpacked new_ty)
+    returnRn (BangType s new_ty)
 
 -- This data decl will parse OK
 --	data T = a Int
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index e128eea0b0..4fc7362155 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -716,7 +716,7 @@ mapLvl		= mapUs
 
 \begin{code}
 newPolyBndrs dest_lvl env abs_vars bndrs
-  = getUniquesUs (length bndrs)		`thenLvl` \ uniqs ->
+  = getUniquesUs 		`thenLvl` \ uniqs ->
     let
 	new_bndrs = zipWith mk_poly_bndr bndrs uniqs
     in
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 9978ab2671..19faf99852 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -283,10 +283,10 @@ getUniqueSmpl dflags env us sc
    = case splitUniqSupply us of
         (us1, us2) -> (uniqFromSupply us1, us2, sc)
 
-getUniquesSmpl :: Int -> SimplM [Unique]
-getUniquesSmpl n dflags env us sc 
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl dflags env us sc 
    = case splitUniqSupply us of
-        (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
+        (us1, us2) -> (uniqsFromSupply us1, us2, sc)
 
 getDOptsSmpl :: SimplM DynFlags
 getDOptsSmpl dflags env us sc 
@@ -751,6 +751,5 @@ newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
 	(us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) 
 			us2 sc
 		   where
-		      vs = zipWithEqual "newIds" (mkSysLocal fs) 
-					(uniqsFromSupply (length tys) us1) tys
+		      vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys
 \end{code}
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index e3dcba73c9..d28523f0b0 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -63,7 +63,6 @@ import TysPrim		( realWorldStatePrimTy )
 import PrelInfo		( realWorldPrimId )
 import OrdList
 import Maybes		( maybeToBool )
-import Util		( zipWithEqual )
 import Outputable
 \end{code}
 
@@ -1390,9 +1389,9 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
 		   let
 			(_,_,ex_tyvars,_,_,_) = dataConSig data_con
 		   in
-		   getUniquesSmpl (length ex_tyvars)				`thenSmpl` \ tv_uniqs ->
+		   getUniquesSmpl 			`thenSmpl` \ tv_uniqs ->
 		   let
-			ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+			ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
 			mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
 			arg_tys    = dataConArgTys data_con
 					  	   (inst_tys ++ mkTyVarTys ex_tyvars')
@@ -1626,13 +1625,20 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside
 	-- Consider:	let j = if .. then I# 3 else I# 4
 	--		in case .. of { A -> j; B -> j; C -> ... }
 	--
-	-- Now CPR should not w/w j because it's a thunk, so
+	-- Now CPR doesn't w/w j because it's a thunk, so
 	-- that means that the enclosing function can't w/w either,
 	-- which is a lose.  Here's the example that happened in practice:
 	--	kgmod :: Int -> Int -> Int
 	--	kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
 	--	            then 78
 	--		    else 5
+	--
+	-- I have seen a case alternative like this:
+	--	True -> \v -> ...
+	-- It's a bit silly to add the realWorld dummy arg in this case, making
+	--	$j = \s v -> ...
+	--	   True -> $j s
+	-- (the \v alone is enough to make CPR happy) but I think it's rare
 
 	then newId SLIT("w") realWorldStatePrimTy  $ \ rw_id ->
 	     returnSmpl ([rw_id], [Var realWorldPrimId])
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs
index b7640656d8..1bcf59bef6 100644
--- a/ghc/compiler/stranal/WwLib.lhs
+++ b/ghc/compiler/stranal/WwLib.lhs
@@ -308,7 +308,7 @@ mkWWargs fun_ty arity demands res_bot one_shots
 	-- build lots of wrapper args:
 	--	  \x. let v=E in \y. bottom
 	--	= \xy. let v=E in bottom
-  = getUniquesUs n_args		`thenUs` \ wrap_uniqs ->
+  = getUniquesUs 		`thenUs` \ wrap_uniqs ->
     let
       val_args	= zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
       wrap_args = tyvars ++ val_args
@@ -421,7 +421,7 @@ mk_ww_str (arg : ds)
 
 	-- Unpack case
       WwUnpack new_or_data True cs ->
-	getUniquesUs (length inst_con_arg_tys)		`thenUs` \ uniqs ->
+	getUniquesUs 		`thenUs` \ uniqs ->
 	let
 	  unpk_args	 = zipWith mk_ww_local uniqs inst_con_arg_tys
 	  unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs
@@ -481,7 +481,7 @@ mkWWcpr body_ty ReturnsCPR
 
     | n_con_args == 1 && isUnLiftedType con_arg_ty1
 	-- Special case when there is a single result of unlifted type
-    = getUniquesUs 2			`thenUs` \ [work_uniq, arg_uniq] ->
+    = getUniquesUs 			`thenUs` \ (work_uniq : arg_uniq : _) ->
       let
 	work_wild = mk_ww_local work_uniq body_ty
 	arg	  = mk_ww_local arg_uniq  con_arg_ty1
@@ -491,7 +491,7 @@ mkWWcpr body_ty ReturnsCPR
 		con_arg_ty1)
 
     | otherwise		-- The general case
-    = getUniquesUs (n_con_args + 2)  	`thenUs` \ uniqs ->
+    = getUniquesUs 	  	`thenUs` \ uniqs ->
       let
         (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
 	arg_vars		       = map Var args
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index c0c5f78011..3cdbf52f29 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -74,7 +74,7 @@ import TysWiredIn ( isIntTy,
 		    isIntegerTy
 		  ) 
 import PrelNames( fromIntegerName, fromRationalName )
-import Util	( thenCmp, zipWithEqual )
+import Util	( thenCmp )
 import Bag
 import Outputable
 \end{code}
@@ -310,8 +310,8 @@ newDictsAtLoc :: InstLoc
  	      -> TcThetaType
 	      -> NF_TcM [Inst]
 newDictsAtLoc inst_loc@(_,loc,_) theta
-  = tcGetUniques (length theta)		`thenNF_Tc` \ new_uniqs ->
-    returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
+  = tcGetUniques 			`thenNF_Tc` \ new_uniqs ->
+    returnNF_Tc (zipWith mk_dict new_uniqs theta)
   where
     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 3994e93952..43e833407c 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -40,7 +40,8 @@ import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
 import Class		( classTyVars, classBigSig, classTyCon, 
 			  Class, ClassOpItem, DefMeth (..) )
 import MkId		( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
-import DataCon		( mkDataCon, notMarkedStrict )
+import DataCon		( mkDataCon )
+import Demand		( StrictnessMark(..) )
 import Id		( Id, idType, idName )
 import Module		( Module )
 import Name		( Name, NamedThing(..) )
@@ -152,7 +153,7 @@ tcClassDecl1 is_rec rec_env
 	dict_component_tys = sc_tys ++ op_tys
 
         dict_con = mkDataCon datacon_name
-			     [notMarkedStrict | _ <- dict_component_tys]
+			     [NotMarkedStrict | _ <- dict_component_tys]
 			     [{- No labelled fields -}]
 		      	     tyvars
 		      	     [{-No context-}]
@@ -561,9 +562,9 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id)
 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
   =  	-- No default method
 	-- Warn only if -fwarn-missing-methods
-    doptsTc Opt_WarnMissingMethods  `thenNF_Tc` \ warn -> 
+    doptsTc Opt_WarnMissingMethods 		`thenNF_Tc` \ warn -> 
     warnTc (is_inst_decl && warn)
-   	   (omittedMethodWarn sel_id clas)		`thenNF_Tc_`
+   	   (omittedMethodWarn sel_id)		`thenNF_Tc_`
     returnTc error_rhs
   where
     error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
@@ -578,7 +579,7 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
 	-- a type constructor applied to type arguments in the instance decl
 	-- 	(checkTc, so False provokes the error)
      checkTc (not is_inst_decl || simple_inst)
-	     (badGenericInstance sel_id clas)			`thenTc_`
+	     (badGenericInstance sel_id)			`thenTc_`
 
      ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)	`thenNF_Tc_`
      returnTc rhs
@@ -645,20 +646,18 @@ badMethodErr clas op
   = hsep [ptext SLIT("Class"), quotes (ppr clas), 
 	  ptext SLIT("does not have a method"), quotes (ppr op)]
 
-omittedMethodWarn sel_id clas
-  = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), 
-	 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+omittedMethodWarn sel_id
+  = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 
 badGenericMethodType op op_ty
   = hang (ptext SLIT("Generic method type is too complex"))
        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 		ptext SLIT("You can only use type variables, arrows, and tuples")])
 
-badGenericInstance sel_id clas
+badGenericInstance sel_id
   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 	 ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
-	 ptext SLIT("(where T is a derivable type constructor)"),
-	 ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+	 ptext SLIT("(where T is a derivable type constructor)")]
 
 mixedGenericErr op
   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 07c33745b0..006983ddf4 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -36,11 +36,12 @@ import TcType		( TcType, TcTauType,
 			  tcInstTyVars, tcInstType, 
 			  newTyVarTy, newTyVarTys, zonkTcType )
 
-import FieldLabel	( fieldLabelName, fieldLabelType, fieldLabelTyCon )
+import FieldLabel	( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
 import Id		( idType, recordSelectorFieldLabel, isRecordSelector )
 import DataCon		( dataConFieldLabels, dataConSig, 
-			  dataConStrictMarks, StrictnessMark(..)
+			  dataConStrictMarks
 			)
+import Demand		( isMarkedStrict )
 import Name		( Name )
 import Type		( mkFunTy, mkAppTy, mkTyConTy,
 			  splitFunTy_maybe, splitFunTys,
@@ -62,7 +63,7 @@ import PrelNames	( cCallableClassName,
 			  thenMName, failMName, returnMName, ioTyConName
 			)
 import Outputable
-import Maybes		( maybeToBool, mapMaybe )
+import Maybes		( maybeToBool )
 import ListSetOps	( minusList )
 import Util
 import CmdLineOpts
@@ -400,14 +401,11 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
     tcRecordBinds tycon ty_args rbinds		`thenTc` \ (rbinds', rbinds_lie) ->
     
     let
-      missing_s_fields = missingStrictFields rbinds data_con
+      (missing_s_fields, missing_fields) = missingFields rbinds data_con
     in
     checkTcM (null missing_s_fields)
 	(mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
 	 returnNF_Tc ())  `thenNF_Tc_`
-    let
-      missing_fields = missingFields rbinds data_con
-    in
     doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
     checkTcM (not (warn && not (null missing_fields)))
 	(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
@@ -868,35 +866,32 @@ badFields rbinds data_con
   where
     field_names = map fieldLabelName (dataConFieldLabels data_con)
 
-missingStrictFields rbinds data_con
-  = [ fn | fn <- strict_field_names,
-  		 not (fn `elem` field_names_used)
-    ]
-  where
-    field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
-    strict_field_names = mapMaybe isStrict field_info
-
-    isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
-    isStrict _			= Nothing
-
-    field_info = zip (dataConFieldLabels data_con)
-    		     (dataConStrictMarks data_con)
-
 missingFields rbinds data_con
-  = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
+  | null field_labels = ([], [])	-- Not declared as a record;
+					-- But C{} is still valid
+  | otherwise	
+  = (missing_strict_fields, other_missing_fields)
   where
-    field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
-
-     -- missing strict fields have already been flagged as 
-     -- being so, so leave them out here.
-    non_strict_field_names = mapMaybe isn'tStrict field_info
-
-    isn'tStrict (fl, MarkedStrict) = Nothing
-    isn'tStrict (fl, _)            = Just (fieldLabelName fl)
-
-    field_info = zip (dataConFieldLabels data_con)
-    		     (dataConStrictMarks data_con)
+    missing_strict_fields
+	= [ fl | (fl, str) <- field_info,
+	  	 isMarkedStrict str,
+	  	 not (fieldLabelName fl `elem` field_names_used)
+	  ]
+    other_missing_fields
+	= [ fl | (fl, str) <- field_info,
+	  	 not (isMarkedStrict str),
+	  	 not (fieldLabelName fl `elem` field_names_used)
+	  ]
 
+    field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
+    field_labels     = dataConFieldLabels data_con
+
+    field_info = zipEqual "missingFields"
+			  field_labels
+	  		  (drop (length ex_theta) (dataConStrictMarks data_con))
+	-- The 'drop' is because dataConStrictMarks
+	-- includes the existential dictionaries
+    (_, _, _, ex_theta, _, _) = dataConSig data_con
 \end{code}
 
 %************************************************************************
@@ -946,11 +941,6 @@ tcLit lit res_ty
 
 Mini-utils:
 
-\begin{code}
-pp_nest_hang :: String -> SDoc -> SDoc
-pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
-\end{code}
-
 Boring and alphabetical:
 \begin{code}
 arithSeqCtxt expr
@@ -1013,12 +1003,12 @@ recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
 notSelector field
   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
 
-missingStrictFieldCon :: Name -> Name -> SDoc
+missingStrictFieldCon :: Name -> FieldLabel -> SDoc
 missingStrictFieldCon con field
   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
 	  ptext SLIT("does not have the required strict field"), quotes (ppr field)]
 
-missingFieldCon :: Name -> Name -> SDoc
+missingFieldCon :: Name -> FieldLabel -> SDoc
 missingFieldCon con field
   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
 	  ptext SLIT("is not initialised")]
diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index c0fb587abb..b6f0291cd0 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -544,11 +544,11 @@ tcGetUnique down env
   where
     u_var = getUniqSupplyVar down
 
-tcGetUniques :: Int -> NF_TcM [Unique]
-tcGetUniques n down env
+tcGetUniques :: NF_TcM [Unique]
+tcGetUniques down env
   = do	uniq_supply <- readIORef u_var
 	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-	    uniqs		      = uniqsFromSupply n uniq_s
+	    uniqs		      = uniqsFromSupply uniq_s
 	writeIORef u_var new_uniq_supply
 	return uniqs
   where
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index bde665527a..a0a00b040a 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -11,7 +11,7 @@ module TcTyDecls (
 #include "HsVersions.h"
 
 import HsSyn		( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
-			  getBangType, conDetailsTys
+			  getBangType, getBangStrictness, conDetailsTys
 			)
 import RnHsSyn		( RenamedTyClDecl, RenamedConDecl, RenamedContext )
 import BasicTypes	( NewOrData(..), RecFlag, isRec )
@@ -25,9 +25,7 @@ import TcEnv		( tcExtendTyVarEnv,
 			)
 import TcMonad
 
-import DataCon		( DataCon, mkDataCon, dataConFieldLabels,  markedStrict, 
-		 	  notMarkedStrict, markedUnboxed, dataConRepType
-			)
+import DataCon		( DataCon, mkDataCon, dataConFieldLabels, dataConRepType )
 import MkId		( mkDataConId, mkDataConWrapId, mkRecordSelId )
 import FieldLabel
 import Var		( TyVar )
@@ -183,10 +181,6 @@ thinContext arg_tys ctxt
       arg_tyvars = tyVarsOfTypes arg_tys
       in_arg_tys pred = not $ isEmptyVarSet $ 
 			tyVarsOfPred pred `intersectVarSet` arg_tyvars
-
-getBangStrictness (Banged   _) = markedStrict
-getBangStrictness (Unbanged _) = notMarkedStrict
-getBangStrictness (Unpacked _) = markedUnboxed
 \end{code}
 
 
diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 44fd27a757..537be155d4 100644
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -340,13 +340,6 @@ mk_sum_stuff i tyvars datacons
 	where
 	  datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys
 
-
--- This constructs the c_of datatype from a DataCon and a Type
--- The identity function at the moment.
-cOfConstr :: DataCon -> Type -> Type
-cOfConstr y z = z
-
-
 ----------------------------------------------------
 --	Dealing with products
 ----------------------------------------------------