X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=d67ae90d8494231c42012318a18007160f29036f;hb=a4c34367ce3e836f52f0ffb1e379ce81b8d65316;hp=a23c6bac04e9847425c93f0dac3ecc8dbaf3e554;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a23c6ba..d67ae90 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -36,7 +36,8 @@ import TcMType		( newKindVar, checkValidTheta, checkValidType,
 import TcType		( TcKind, TcType, Type, tyVarsOfType, mkPhiTy,
 			  mkArrowKind, liftedTypeKind, mkTyVarTys, 
 			  tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
-import Type		( PredType(..), splitTyConApp_maybe, mkTyVarTy
+import Type		( PredType(..), splitTyConApp_maybe, mkTyVarTy,
+                          newTyConInstRhs
 			  -- pprParendType, pprThetaArrow
 			)
 import Generics		( validGenericMethodType, canDoGenerics )
@@ -606,14 +607,21 @@ chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
 chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
   = case bang of
 	HsNoBang				    -> NotMarkedStrict
-	HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed
-	HsUnbox  | can_unbox			    -> MarkedUnboxed
+	HsStrict | unbox_strict_fields 
+                   && can_unbox arg_ty 		    -> MarkedUnboxed
+	HsUnbox  | can_unbox arg_ty		    -> MarkedUnboxed
 	other					    -> MarkedStrict
   where
-    can_unbox = case splitTyConApp_maybe arg_ty of
-		   Nothing 	       -> False
-		   Just (arg_tycon, _) -> not (isNewTyCon arg_tycon) && not (isRecursiveTyCon tycon) &&
-					  isProductTyCon arg_tycon
+    -- we can unbox if the type is a chain of newtypes with a product tycon
+    -- at the end
+    can_unbox arg_ty = case splitTyConApp_maybe arg_ty of
+		   Nothing 	       		-> False
+		   Just (arg_tycon, tycon_args) -> 
+                       not (isRecursiveTyCon tycon) &&
+		       isProductTyCon arg_tycon &&
+                       (if isNewTyCon arg_tycon then 
+                            can_unbox (newTyConInstRhs arg_tycon tycon_args)
+                        else True)
 \end{code}
 
 %************************************************************************