Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/a0f8b3acec4af74be47808b30365aac85721e84c >--------------------------------------------------------------- commit a0f8b3acec4af74be47808b30365aac85721e84c Author: Simon Peyton Jones <[email protected]> Date: Mon Jan 9 14:06:25 2012 +0000 In mkCast (Coercion c1) c2, check that c2 has (~#) on both sides Otherwise the RHS is utterly bogus. I also added some asserts. Thanks to Max for pointing this out. >--------------------------------------------------------------- compiler/coreSyn/CoreUtils.lhs | 4 ++++ compiler/simplCore/Simplify.lhs | 7 +------ compiler/types/Coercion.lhs | 25 +++++++++++++++++++------ 3 files changed, 24 insertions(+), 12 deletions(-) diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 47e31fa..1549ff3 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -181,6 +181,10 @@ mkCast :: CoreExpr -> Coercion -> CoreExpr mkCast e co | isReflCo co = e mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind co)) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce = Coercion new_co where -- g :: (s1 ~# s2) ~# (t1 ~# t2) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2d84249..d5b3d76 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -976,11 +976,6 @@ simplType env ty --------------------------------- simplCoercionF :: SimplEnv -> InCoercion -> SimplCont -> SimplM (SimplEnv, OutExpr) --- We are simplifying a term of form (Coercion co) --- Simplify the InCoercion, and then try to combine with the --- context, to implememt the rule --- (Coercion co) |> g --- = Coercion (syn (nth 0 g) ; co ; nth 1 g) simplCoercionF env co cont = do { co' <- simplCoercion env co ; rebuild env (Coercion co') cont } @@ -1164,7 +1159,7 @@ rebuild env expr cont = case cont of Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation + -- NB: mkCast implements the (Coercion co |> g) optimisation Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 836c9e5..2b1656f 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -318,8 +318,9 @@ isCoVar v = isCoVarType (varType v) isCoVarType :: Type -> Bool isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality - | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey - | otherwise = False + = case splitTyConApp_maybe ty of + Just (tc,tys) -> tc `hasKey` eqPrimTyConKey && tys `lengthAtLeast` 2 + Nothing -> False \end{code} @@ -456,8 +457,9 @@ pprCoAxiom ax -- -- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] - -- Remember, Nth is zero-indexed +decomposeCo arity co + = [mkNthCo n co | n <- [0..(arity-1)] ] + -- Remember, Nth is zero-indexed -- | Attempts to obtain the type variable underlying a 'Coercion' getCoVar_maybe :: Coercion -> Maybe CoVar @@ -615,8 +617,19 @@ mkTransCo co (Refl _) = co mkTransCo co1 co2 = TransCo co1 co2 mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl ty) = Refl (tyConAppArgN n ty) -mkNthCo n co = NthCo n co +mkNthCo n (Refl ty) = ASSERT( ok_tc_app ty n ) + Refl (tyConAppArgN n ty) +mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) + NthCo n co + where + Pair _ty1 _ty2 = coercionKind co + +#ifdef DEBUG +ok_tc_app :: Type -> Int -> Bool +ok_tc_app ty n = case splitTyConApp_maybe ty of + Just (_, tys) -> tys `lengthExceeds` n + Nothing -> False +#endif -- | Instantiates a 'Coercion' with a 'Type' argument. mkInstCo :: Coercion -> Type -> Coercion _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
