Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/028bb610d33b935e60c6846d031705578f08225b >--------------------------------------------------------------- commit 028bb610d33b935e60c6846d031705578f08225b Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Aug 3 13:35:10 2011 +0100 Add coercionKindNonRepr to work around coercionKind bug >--------------------------------------------------------------- compiler/supercompile/Supercompile/Core/Syntax.hs | 31 ++++++++++++++++++- .../Supercompile/Evaluator/Evaluate.hs | 6 ++-- .../supercompile/Supercompile/Evaluator/Syntax.hs | 8 ++-- 3 files changed, 36 insertions(+), 9 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index d8a1730..ad08f74 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -13,10 +13,12 @@ import Name (Name, nameOccName) import OccName (occNameString) import Id (Id) import Literal (Literal) -import Type (Type, mkTyVarTy) -import Coercion (CoVar, Coercion) +import Type (Type, mkTyVarTy, splitTyConApp_maybe, mkPredTy, mkEqPred) +import TysPrim (eqPredPrimTyCon) +import Coercion (CoVar, Coercion, coercionKind) import PrimOp (PrimOp) import PprCore () +import Pair -- NB: don't use GHC's pprBndr because its way too noisy, printing unfoldings etc @@ -289,3 +291,28 @@ freshFloatVars ids s es = reassociate $ mapAccumL (\ids -> associate . freshFloa where reassociate (ids, floats_xs) = let (mb_floats, xs) = unzip floats_xs in (ids, catMaybes mb_floats, xs) associate (ids, mb_float, x) = (ids, (mb_float, x)) -} + +-- OK, this is a bit bizarre. +-- +-- The coercion handling stuff in GHC sometimes rewrites an equality PredTy +-- into its representation using eqPredPrimTyCon. We might observe such a type +-- in one of the return types of the coercionKind. +-- +-- We CANNOT let this "representation" type reach the top level, e.g. be set +-- as the type of a variable. Reason: a variable with a type of ((~) ty1 ty2) +-- is NOT a CoVar is the sense of isCoVar +-- +-- Our (slightly hacky) solution is to try to undo this representation type +-- rubbish right here. TODO: perhaps I should do it for other PredTy as well? +--- +-- Simon says that the fact that things with ((~) ty1 ty2) types are not detected +-- as CoVars is actually a bug, and he will fix it. We need to keep this workaround +-- if we want to work on earlier GHCs (e.g. the GHC 7.2 RC). +coercionKindNonRepr :: Coercion -> Pair Type +coercionKindNonRepr co = Pair (repair from_ty) (repair to_ty) + where Pair from_ty to_ty = coercionKind co + repair ty | Just (tc, [ty1, ty2]) <- splitTyConApp_maybe ty + , tc == eqPredPrimTyCon + = mkPredTy (mkEqPred (ty1, ty2)) + | otherwise + = ty diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index fc9c898..406b274 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -221,7 +221,7 @@ step' normalising state = Just (co', tg_co) -> fmap (\deeds -> (deeds, Heap (M.insert y' (internallyBound (renamedTerm e_arg)) h) ids', Tagged tg_co (CastIt res_co') : k, (rn', e_body))) $ claimDeeds (deeds + answerSize' a) (annedSize e_arg + annedSize e_body) where (ids', rn', y') = renameNonRecBinder ids rn (x `setIdType` arg_co_from_ty') - Pair arg_co_from_ty' _arg_co_to_ty' = coercionKind arg_co' + Pair arg_co_from_ty' _arg_co_to_ty' = coercionKindNonRepr arg_co' [arg_co', res_co'] = decomposeCo 2 co' e_arg = annedTerm tg_co (annedTerm tg_v (Var x') `Cast` mkSymCo arg_co') @@ -271,7 +271,7 @@ step' normalising state = , Just res <- [do (deeds3, h', ids', rn_alts') <- case mb_dc_cos of Nothing -> return (deeds2, h1, ids, insertIdRenamings (insertCoercionSubsts rn_alts' (alt_qs `zip` cos')) (alt_xs `zip` xs')) Just dc_cos -> foldM (\(deeds, h, ids, rn_alts) (uncast_e_arg', alt_y, (dc_co, tg_co)) -> - let Pair _dc_co_from_ty' dc_co_to_ty' = coercionKind dc_co -- TODO: use to_tc_arg_tys' from above? + let Pair _dc_co_from_ty' dc_co_to_ty' = coercionKindNonRepr dc_co -- TODO: use to_tc_arg_tys' from above? (ids', rn_alts', y') = renameNonRecBinder ids rn_alts (alt_y `setIdType` dc_co_to_ty') e_arg = annedTerm tg_co $ annedTerm tg_v uncast_e_arg' `Cast` dc_co in fmap (\deeds' -> (deeds', M.insert y' (internallyBound (renamedTerm e_arg)) h, ids', rn_alts')) $ claimDeeds deeds (annedSize e_arg)) @@ -288,7 +288,7 @@ step' normalising state = | otherwise = Nothing where (mb_co_deref, (rn_v_deref, v_deref)) = dereference (Heap h0 ids) a - mb_co_deref_kind = fmap (\(co, tg_co) -> (co, tg_co, coercionKind co)) mb_co_deref + mb_co_deref_kind = fmap (\(co, tg_co) -> (co, tg_co, coercionKindNonRepr co)) mb_co_deref (deeds1, h1) | isDeadBinder wild' = (deeds0 + answerSize' a, h0) | otherwise = (deeds0, M.insert wild' wild_hb h0) where wild_hb = internallyBound $ annedAnswerToInAnnedTerm ids (annedAnswer tg_v a) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 4020466..ae6c4d3 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -19,7 +19,7 @@ import Type (applyTy, applyTys, mkForAllTy, mkFunTy, splitFunTy, eqType, isU import Pair (pSnd) import DataCon (dataConWorkId) import Literal (literalType) -import Coercion (coercionKind, coercionType) +import Coercion (coercionType) import qualified Data.Map as M @@ -241,7 +241,7 @@ stackFrameType kf hole_ty = case tagee kf of PrimApply pop tys in_as in_es -> ((primOpType pop `applyTys` tys) `applyFunTys` map answerType in_as) `applyFunTys` map (\in_e@(rn, e) -> termType (renameAnnedTerm (mkInScopeSet (inFreeVars annedFreeVars in_e)) rn e)) in_es StrictLet _ in_e@(rn, e) -> termType (renameAnnedTerm (mkInScopeSet (inFreeVars annedFreeVars in_e)) rn e) Update _ -> hole_ty - CastIt co -> pSnd (coercionKind co) + CastIt co -> pSnd (coercionKindNonRepr co) qaType :: Anned QA -> Type qaType anned_qa = case traverse (\qa -> case qa of Question x' -> Left (idType x'); Answer a -> Right a) anned_qa of @@ -250,7 +250,7 @@ qaType anned_qa = case traverse (\qa -> case qa of Question x' -> Left (idType x answerType :: Anned Answer -> Type answerType a = case annee a of - (Just (co, _), _) -> pSnd (coercionKind co) + (Just (co, _), _) -> pSnd (coercionKindNonRepr co) (Nothing, (rn, v)) -> valueType (renameAnnedValue' (mkInScopeSet (annedFreeVars a)) rn v) valueType :: Copointed ann => ValueF ann -> Type @@ -272,7 +272,7 @@ termType e = case extract e of Case _ _ ty _ -> ty Let _ _ e -> termType e LetRec _ e -> termType e - Cast _ co -> pSnd (coercionKind co) + Cast _ co -> pSnd (coercionKindNonRepr co) applyFunTy :: Type -> Type -> Type applyFunTy fun_ty got_arg_ty = ASSERT2(got_arg_ty `eqType` expected_arg_ty, text "applyFunTy:" <+> ppr got_arg_ty <+> ppr expected_arg_ty) res_ty _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
