X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FCoercion.lhs;h=794613b9aaf0481904e61c3b3e7ab95bf5ad3b87;hb=9a0100000f820caf09e2e8f5304a6e008a614729;hp=bc93372e0f4041531d13682bd1a5b81a5f5078b2;hpb=b06d623b2e367a572de5daf06d6a0b12c2740471;p=ghc-hetmet.git

diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index bc93372..794613b 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -379,9 +379,18 @@ mkInstsCoercion co tys = foldl mkInstCoercion co tys
 -- | Manufacture a coercion from this air. Needless to say, this is not usually safe,
 -- but it is used when we know we are dealing with bottom, which is one case in which 
 -- it is safe.  This is also used implement the @unsafeCoerce#@ primitive.
+-- Optimise by pushing down through type constructors
 mkUnsafeCoercion :: Type -> Type -> Coercion
-mkUnsafeCoercion ty1 ty2 = mkCoercion unsafeCoercionTyCon [ty1, ty2]
+mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+  | tc1 == tc2
+  = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2)
 
+mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2)
+  = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2)
+
+mkUnsafeCoercion ty1 ty2 
+  | ty1 `coreEqType` ty2 = ty1
+  | otherwise            = mkCoercion unsafeCoercionTyCon [ty1, ty2]
 
 -- See note [Newtype coercions] in TyCon
 
@@ -629,7 +638,7 @@ mkAppTyCoI ty1 coi1 ty2 coi2 =
 mkFunTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
 mkFunTyCoI _   IdCo _   IdCo = IdCo
 mkFunTyCoI ty1 coi1 ty2 coi2 =
-	ACo $ FunTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
+	ACo $ mkFunTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
 
 -- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion'
 mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI