newtype fixes, coercions for non-recursive newtypes now optional

Mon Sep 18 14:24:27 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * newtype fixes, coercions for non-recursive newtypes now optional
  Sat Aug  5 21:19:58 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * newtype fixes, coercions for non-recursive newtypes now optional
    Fri Jul  7 06:11:48 EDT 2006  kevind@bu.edu

20 files changed, 117 insertions, 95 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 33482feff9..d1d7a020a7 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -709,35 +709,23 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- body of the wrapper, namely
 --	e `cast` CoT [a]
 --
--- For non-recursive newtypes, GHC currently treats them like type
--- synonyms, so no cast is necessary.  This function is the only
--- place in the compiler that generates 
+-- If a coercion constructor is prodivided in the newtype, then we use
+-- it, otherwise the wrap/unwrap are both no-ops 
 --
 wrapNewTypeBody tycon args result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
-  = Cast result_expr co
---  | otherwise
---  = result_expr
-  where
-    co = mkTyConApp (newTyConCo tycon) args
+  | Just co_con <- newTyConCo tycon
+  = Cast result_expr (mkTyConApp co_con args)
+  | otherwise
+  = result_expr
 
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
-  = Cast result_expr sym_co
---  | otherwise
---  = result_expr
-  where
-    sym_co = mkSymCoercion co
-    co     = mkTyConApp (newTyConCo tycon) args
-
--- Old Definition of mkNewTypeBody
--- Used for both wrapping and unwrapping
---mkNewTypeBody tycon result_ty result_expr
---  | isRecursiveTyCon tycon	-- Recursive case; use a coerce
---  = Note (Coerce result_ty (exprType result_expr)) result_expr
---  | otherwise			-- Normal case
---  = result_expr
+  | Just co_con <- newTyConCo tycon
+  = Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
+  | otherwise
+  = result_expr
+
+
 \end{code}
 
 
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 11b4e3dffc..788c4b4bb6 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -38,7 +38,7 @@ import Type		( Type, tyVarsOfType, coreEqType,
 			  extendTvSubst, composeTvSubst, substTyVarBndr, isInScope,
 			  getTvSubstEnv, getTvInScope, mkTyVarTy )
 import Coercion         ( Coercion, coercionKind, coercionKindTyConApp )
-import TyCon		( isPrimTyCon )
+import TyCon		( isPrimTyCon, isNewTyCon )
 import BasicTypes	( RecFlag(..), Boxity(..), isNonRec )
 import StaticFlags	( opt_PprStyle_Debug )
 import DynFlags		( DynFlags, DynFlag(..), dopt )
@@ -497,6 +497,7 @@ lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
     lit_ty = literalType lit
 
 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+  | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
   = addLoc (CaseAlt alt) $  lintBinders args $ \ args -> 
     
@@ -801,6 +802,13 @@ mkBadAltMsg scrut_ty alt
 	   text "Scrutinee type:" <+> ppr scrut_ty,
 	   text "Alternative:" <+> pprCoreAlt alt ]
 
+mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
+mkNewTyDataConAltMsg scrut_ty alt
+  = vcat [ text "Data alternative for newtype datacon",
+	   text "Scrutinee type:" <+> ppr scrut_ty,
+	   text "Alternative:" <+> pprCoreAlt alt ]
+
+
 ------------------------------------------------------
 --	Other error messages
 
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index a10894524a..29b1ce467f 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -50,11 +50,13 @@ import StaticFlags	( opt_RuntimeTypes )
 import CostCentre	( CostCentre, noCostCentre )
 import Var		( Var, Id, TyVar, isTyVar, isId )
 import Type		( Type, mkTyVarTy, seqType )
+import TyCon            ( isNewTyCon )
 import Coercion         ( Coercion )
 import Name		( Name )
 import OccName		( OccName )
 import Literal	        ( Literal, mkMachInt )
-import DataCon		( DataCon, dataConWorkId, dataConTag )
+import DataCon		( DataCon, dataConWorkId, dataConTag, dataConTyCon,
+                          dataConWrapId )
 import BasicTypes	( Activation )
 import FastString
 import Outputable
@@ -440,7 +442,9 @@ mkLets	      :: [Bind b] -> Expr b -> Expr b
 mkLams	      :: [b] -> Expr b -> Expr b
 
 mkLit lit	  = Lit lit
-mkConApp con args = pprTrace "mkConApp" (ppr con) $ mkApps (Var (dataConWorkId con)) args
+mkConApp con args 
+  | isNewTyCon (dataConTyCon con) = mkApps (Var (dataConWrapId con)) args
+  | otherwise = mkApps (Var (dataConWorkId con)) args
 
 mkLams binders body = foldr Lam body binders
 mkLets binds body   = foldr Let body binds
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index c8885f7f1c..818175478f 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -179,7 +179,6 @@ make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 make_kind k
   | isLiftedTypeKind k   = C.Klifted
   | isUnliftedTypeKind k = C.Kunlifted
---   | isUnboxedTypeKind k  = C.Kunboxed	Fix me
   | isOpenTypeKind k     = C.Kopen
 make_kind _ = error "MkExternalCore died: make_kind"
 
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 8f9279e923..f3a0d0b316 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -25,7 +25,7 @@ import BasicTypes	( IPName, RecFlag(..), InlineSpec(..), Fixity )
 import Outputable	
 import SrcLoc		( Located(..), SrcSpan, unLoc )
 import Util		( sortLe )
-import Var		( TyVar, DictId, Id )
+import Var		( TyVar, DictId, Id, Var )
 import Bag		( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
 \end{code}
 
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index e4c392b6a5..ad580289c5 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -84,7 +84,9 @@ mkNewTyConRhs tycon_name tycon con
   = do	{ co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
 	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty 
 	; return (NewTyCon { data_con = con, 
- 		       	     nt_co = co_tycon,
+ 		       	     nt_co = Just co_tycon, 
+                             -- Coreview looks through newtypes with a Nothing
+                             -- for nt_co, or uses explicit coercions otherwise
 		       	     nt_rhs = rhs_ty,
 		       	     nt_etad_rhs = eta_reduce tvs rhs_ty,
 		       	     nt_rep = mkNewTyConRep tycon rhs_ty }) }
@@ -116,9 +118,8 @@ mkNewTyConRep :: TyCon		-- The original type constructor
 -- Remember that the representation type is the *ultimate* representation
 -- type, looking through other newtypes.
 -- 
--- The non-recursive newtypes are easy, because they look transparent
--- to splitTyConApp_maybe, but recursive ones really are represented as
--- TyConApps (see TypeRep).
+-- splitTyConApp_maybe no longer looks through newtypes, so we must
+-- deal explicitly with this case
 -- 
 -- The trick is to to deal correctly with recursive newtypes
 -- such as	newtype T = MkT T
@@ -133,10 +134,11 @@ mkNewTyConRep tc rhs_ty
 	= case splitTyConApp_maybe rep_ty of
 	    Just (tc, tys)
 		| tc `elem` tcs -> unitTy	-- Recursive loop
-		| isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
-					-- Non-recursive ones have been 
-					-- dealt with by splitTyConApp_maybe
-				   go (tc:tcs) (substTyWith tvs tys rhs_ty)
+		| isNewTyCon tc -> 
+                    if isRecursiveTyCon tc then
+			go (tc:tcs) (substTyWith tvs tys rhs_ty)
+                    else
+                        go tcs (head tys)
 		where
 		  (tvs, rhs_ty) = newTyConRhs tc
 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 26d6fab1a8..2c8780ca3d 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -640,8 +640,9 @@ implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++
 implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
 
 	-- For newtypes, add the implicit coercion tycon
-implicitNewCoTyCon tc | isNewTyCon tc = [ATyCon (newTyConCo tc)]
-		      | otherwise     = []
+implicitNewCoTyCon tc 
+  | isNewTyCon tc, Just co_con <- newTyConCo tc = [ATyCon co_con]
+  | otherwise = []
 
 extras_plus thing = thing : implicitTyThings thing
 
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 4cb3ef7de4..4b6832a856 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -50,7 +50,7 @@ import OccName		( mkOccNameFS, tcName, mkTyVarOcc )
 import TyCon		( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
 			  PrimRep(..) )
 import Type		( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
-			  unliftedTypeKind, unboxedTypeKind, 
+			  unliftedTypeKind, 
 			  liftedTypeKind, openTypeKind, 
 			  Kind, mkArrowKinds,
 			  TyThing(..)
@@ -187,17 +187,13 @@ pcPrimTyCon name arity rep
   = mkPrimTyCon name kind arity rep
   where
     kind        = mkArrowKinds (replicate arity liftedTypeKind) result_kind
-    result_kind = case rep of 
-		    PtrRep -> unliftedTypeKind
-		    _other -> unboxedTypeKind
+    result_kind = unliftedTypeKind
 
 pcPrimTyCon0 :: Name -> PrimRep -> TyCon
 pcPrimTyCon0 name rep
   = mkPrimTyCon name result_kind 0 rep
   where
-    result_kind = case rep of 
-		    PtrRep -> unliftedTypeKind
-		    _other -> unboxedTypeKind
+    result_kind = unliftedTypeKind
 
 charPrimTy	= mkTyConTy charPrimTyCon
 charPrimTyCon	= pcPrimTyCon0 charPrimTyConName WordRep
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 4a61341b5b..235cdfe5f4 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1144,7 +1144,8 @@ mkDataConAlt :: DataCon -> [OutType] -> InExpr -> SimplM InAlt
 -- Make a data-constructor alternative to replace the DEFAULT case
 -- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
 mkDataConAlt con inst_tys rhs
-  = do 	{ tv_uniqs <- getUniquesSmpl 
+  = ASSERT(not (isNewTyCon (dataConTyCon con)))
+    do 	{ tv_uniqs <- getUniquesSmpl 
 	; arg_uniqs <- getUniquesSmpl
 	; let tv_bndrs  = zipWith mk_tv_bndr (dataConExTyVars con) tv_uniqs
 	      arg_tys   = dataConInstArgTys con (inst_tys ++ mkTyVarTys tv_bndrs)
@@ -1491,7 +1492,7 @@ mkCase1 scrut case_bndr ty alts	-- Identity case
       | isNewTyCon (dataConTyCon con) 
       = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
       | otherwise
-      = pprTrace "mkCase1" (ppr con) $ mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
+      = mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
     identity_rhs (LitAlt lit)  _    = Lit lit
     identity_rhs DEFAULT       _    = Var case_bndr
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index efc59d16cc..85b4b49f65 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -611,7 +611,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
 	-- means that we can avoid tests in exprIsConApp, for example.
 	-- This is important: if exprIsConApp says 'yes' for a recursive
 	-- thing, then we can get into an infinite loop
-
 	-- If the unfolding is a value, the demand info may
 	-- go pear-shaped, so we nuke it.  Example:
 	--	let x = (a,b) in
@@ -1520,6 +1519,7 @@ simplDefault :: SimplEnv
 
 simplDefault env case_bndr' imposs_cons cont Nothing
   = return []	-- No default branch
+
 simplDefault env case_bndr' imposs_cons cont (Just rhs)
   | 	-- This branch handles the case where we are 
 	-- scrutinisng an algebraic data type
@@ -1560,7 +1560,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
 
 	two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
 
-  | otherwise
+  | otherwise 
   = simplify_default imposs_cons
   where
     cant_match tys data_con = not (dataConCanMatch data_con tys)
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 3fc84773af..6adda66ed5 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -171,9 +171,10 @@ dmdAnal sigs dmd (Cast e co)
     (dmd_ty, e') = dmdAnal sigs dmd' e
     to_co        = snd (coercionKind co)
     dmd'
-      | Just (tc, args) <- splitTyConApp_maybe to_co
-      , isRecursiveTyCon tc = evalDmd
-      | otherwise           = dmd
+--      | Just (tc, args) <- splitTyConApp_maybe to_co
+      = evalDmd
+--      , isRecursiveTyCon tc = evalDmd
+--      | otherwise           = dmd
 	-- This coerce usually arises from a recursive
         -- newtype, and we don't want to look inside them
 	-- for exactly the same reason that we don't look
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index f3af6f0395..c4e78ebec4 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -240,7 +240,6 @@ mkWWargs fun_ty demands one_shots
 	      \ e -> Cast (wrap_fn_args e) co,
 	      \ e -> work_fn_args (Cast e (mkSymCoercion co)),
 	      res_ty)
-
   | notNull demands
   = getUniquesUs 		`thenUs` \ wrap_uniqs ->
     let
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 8971320491..98fe3e9872 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -71,6 +71,7 @@ import Type	( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSub
 import Unify	( tcMatchTys )
 import Module	( modulePackageId )
 import {- Kind parts of -} Type	( isSubKind )
+import Coercion ( isEqPred )
 import HscTypes	( ExternalPackageState(..), HscEnv(..) )
 import CoreFVs	( idFreeTyVars )
 import DataCon	( DataCon, dataConStupidTheta, dataConName, 
@@ -80,7 +81,7 @@ import Name	( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
 		  isInternalName, setNameUnique )
 import NameSet	( addOneToNameSet )
 import Literal	( inIntRange )
-import Var	( TyVar, tyVarKind, setIdType )
+import Var	( Var, TyVar, tyVarKind, setIdType, mkTyVar )
 import VarEnv	( TidyEnv, emptyTidyEnv )
 import VarSet	( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
 import TysWiredIn ( floatDataCon, doubleDataCon )
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 46e702c9a3..fdf78cf0a4 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -42,7 +42,8 @@ import NameSet		( duDefs )
 import Type		( splitKindFunTys )
 import TyCon		( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
 			  tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
-			  isEnumerationTyCon, isRecursiveTyCon, TyCon
+			  isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon,
+                          newTyConCo
 			)
 import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
 			  isUnLiftedType, mkClassPred, tyVarsOfType,
@@ -367,7 +368,7 @@ makeDerivEqns overlap_flag tycl_decls
 	   traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)	`thenM_`
        	   new_dfun_name clas tycon  		`thenM` \ dfun_name ->
 	   returnM (Nothing, Just (InstInfo { iSpec  = mk_inst_spec dfun_name,
-					      iBinds = NewTypeDerived rep_tys }))
+					      iBinds = NewTypeDerived (newTyConCo tycon) rep_tys }))
       | std_class gla_exts clas
       = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys	-- Go via bale-out route
 
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 19deca9e4c..936ec5b5ac 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -565,7 +565,9 @@ data InstBindings
 	[LSig Name]		-- User pragmas recorded for generating 
 				-- specialised instances
 
-  | NewTypeDerived 		-- Used for deriving instances of newtypes, where the
+  | NewTypeDerived 		
+        (Maybe TyCon)           -- maybe a coercion for the newtype
+                                -- Used for deriving instances of newtypes, where the
 	[Type]			-- witness dictionary is identical to the argument 
 				-- dictionary.  Hence no bindings, no pragmas
 	-- The [Type] are the representation types
@@ -576,7 +578,7 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
   where
     details (VanillaInst b _)  = pprLHsBinds b
-    details (NewTypeDerived _) = text "Derived from the representation type"
+    details (NewTypeDerived _  _) = text "Derived from the representation type"
 
 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index cf27ead743..3e5584475f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -523,6 +523,44 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
     mapM tc_method_bind meth_infos		`thenM` \ meth_binds_s ->
    
     returnM (meth_ids, unionManyBags meth_binds_s)
+v v v v v v v
+*************
+
+
+-- Derived newtype instances
+tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
+	  avail_insts op_items (NewTypeDerived maybe_co rep_tys)
+  = getInstLoc origin				`thenM` \ inst_loc ->
+    mapAndUnzip3M (do_one inst_loc) op_items	`thenM` \ (meth_ids, meth_binds, rhs_insts) ->
+    
+    tcSimplifyCheck
+	 (ptext SLIT("newtype derived instance"))
+	 inst_tyvars' avail_insts rhs_insts	`thenM` \ lie_binds ->
+
+	-- I don't think we have to do the checkSigTyVars thing
+
+    returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
+
+  where
+    do_one inst_loc (sel_id, _)
+	= -- The binding is like "op @ NewTy = op @ RepTy"
+		-- Make the *binder*, like in mkMethodBind
+	  tcInstClassOp inst_loc sel_id inst_tys'	`thenM` \ meth_inst ->
+
+		-- Make the *occurrence on the rhs*
+	  tcInstClassOp inst_loc sel_id rep_tys'	`thenM` \ rhs_inst ->
+	  let
+	     meth_id = instToId meth_inst
+	  in
+	  return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
+
+	-- Instantiate rep_tys with the relevant type variables
+	-- This looks a bit odd, because inst_tyvars' are the skolemised version
+	-- of the type variables in the instance declaration; but rep_tys doesn't
+	-- have the skolemised version, so we substitute them in here
+    rep_tys' = substTys subst rep_tys
+    subst    = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
+^ ^ ^ ^ ^ ^ ^
 \end{code}
 
 
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3cf6145a5c..a23c6bac04 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -43,7 +43,8 @@ import Generics		( validGenericMethodType, canDoGenerics )
 import Class		( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
 import TyCon		( TyCon, AlgTyConRhs( AbstractTyCon ),
 			  tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
-			  tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
+			  tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
+                          isNewTyCon )
 import DataCon		( DataCon, dataConUserType, dataConName, 
 			  dataConFieldLabels, dataConTyCon, dataConAllTyVars,
 			  dataConFieldType, dataConResTys )
@@ -598,7 +599,9 @@ argStrictness unbox_strict tycon bangs arg_tys
 -- 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 :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
   = case bang of
@@ -609,7 +612,7 @@ chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
   where
     can_unbox = case splitTyConApp_maybe arg_ty of
 		   Nothing 	       -> False
-		   Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
+		   Just (arg_tycon, _) -> not (isNewTyCon arg_tycon) && not (isRecursiveTyCon tycon) &&
 					  isProductTyCon arg_tycon
 \end{code}
 
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 06eb0dcc08..84d944a0d0 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -89,7 +89,7 @@ module TcType (
   --------------------------------
   -- Rexported from Type
   Kind, 	-- Stuff to do with kinds is insensitive to pre/post Tc
-  unliftedTypeKind, liftedTypeKind, unboxedTypeKind, argTypeKind,
+  unliftedTypeKind, liftedTypeKind, argTypeKind,
   openTypeKind, mkArrowKind, mkArrowKinds, 
   isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, 
   isSubArgTypeKind, isSubKind, defaultKind,
@@ -135,7 +135,6 @@ import Type		(	-- Re-exports
 			  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 			  tyVarsOfTheta, Kind, PredType(..), KindVar,
 			  ThetaType, isUnliftedTypeKind, unliftedTypeKind, 
--- ???			  unboxedTypeKind,
 			  argTypeKind,
 			  liftedTypeKind, openTypeKind, mkArrowKind,
 		  	  tySuperKind, isLiftedTypeKind,
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index fab15fc682..99afac952b 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -20,7 +20,7 @@ module TyCon(
 	isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 
-	tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe,
+	tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 
 	makeTyConAbstract, isAbstractTyCon,
 
@@ -199,8 +199,9 @@ data AlgTyConRhs
 				--  = the representation type of the tycon
 				-- The free tyvars of this type are the tyConTyVars
       
-        nt_co :: TyCon,		-- The coercion used to create the newtype
+        nt_co :: Maybe TyCon,   -- The coercion used to create the newtype
                                 -- from the representation
+                                -- optional for non-recursive newtypes
 				-- See Note [Newtype coercions]
 
 	nt_etad_rhs :: ([TyVar], Type) ,
@@ -514,9 +515,10 @@ isProductTyCon :: TyCon -> Bool
 --	has *one* constructor, 
 --	is *not* existential
 -- but
---	may be  DataType or NewType, 
+--	may be  DataType, NewType
 -- 	may be  unboxed or not, 
 --	may be  recursive or not
+-- 
 isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
 				    DataTyCon{ data_cons = [data_con] } 
 						-> isVanillaDataCon data_con
@@ -606,24 +608,15 @@ tcExpandTyCon_maybe other_tycon tys = Nothing
 
 ---------------
 -- For the *Core* view, we expand synonyms only as well
-{-
+
 coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,	-- Not recursive
-         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
+         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
    = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
 			-- match the etad_rhs of a *recursive* newtype
 	(tvs,rhs) -> expand tvs rhs tys
--}
-coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
 
----------------
--- For the *STG* view, we expand synonyms *and* non-recursive newtypes
-stgExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,	-- Not recursive
-         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
-   = case etad_rhs of	-- Don't do this in the pattern match, lest we accidentally
-			-- match the etad_rhs of a *recursive* newtype
-	(tvs,rhs) -> expand tvs rhs tys
+coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
 
-stgExpandTyCon_maybe tycon tys = coreExpandTyCon_maybe tycon tys
 
 ----------------
 expand	:: [TyVar] -> Type 			-- Template
@@ -682,7 +675,7 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
-newTyConCo :: TyCon -> TyCon
+newTyConCo :: TyCon -> Maybe TyCon
 newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index ccabfb778a..461439509b 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -47,7 +47,7 @@ module Type (
 	splitTyConApp_maybe, splitTyConApp, 
         splitNewTyConApp_maybe, splitNewTyConApp,
 
-	repType, typePrimRep, coreView, tcView, stgView, kindView,
+	repType, typePrimRep, coreView, tcView, kindView,
 
 	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
 	applyTy, applyTys, isForAllTy, dropForAlls,
@@ -123,7 +123,6 @@ import TyCon	( TyCon, isRecursiveTyCon, isPrimTyCon,
 		  isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
 		  isAlgTyCon, tyConArity, isSuperKindTyCon,
 		  tcExpandTyCon_maybe, coreExpandTyCon_maybe,
-                  stgExpandTyCon_maybe,
 	          tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
                   isCoercionTyCon_maybe, isCoercionTyCon
 		)
@@ -177,19 +176,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc
 				-- partially-applied type constructor; indeed, usually will!
 coreView ty		   = Nothing
 
-{-# INLINE stgView #-}
-stgView :: Type -> Maybe Type
--- When generating STG from Core it is important that we look through newtypes
--- but for the rest of Core we are just using coercions.  This does just what
--- coreView USED to do.
-stgView (NoteTy _ ty) 	   = Just ty
-stgView (PredTy p)    	   = Just (predTypeRep p)
-stgView (TyConApp tc tys) | Just (tenv, rhs, tys') <- stgExpandTyCon_maybe tc tys 
-			   = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-				-- Its important to use mkAppTys, rather than (foldl AppTy),
-				-- because the function part might well return a 
-				-- partially-applied type constructor; indeed, usually will!
-stgView ty		   = Nothing
 
 
 -----------------------------------------------