Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/a91def9c2a8a211895eb99a6aa888b697594fa9e >--------------------------------------------------------------- commit a91def9c2a8a211895eb99a6aa888b697594fa9e Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Fri Aug 5 16:17:36 2011 +0100 Ensure we don't wrap answers in spurious refl coercions, for the sake of rule matching >--------------------------------------------------------------- .../Supercompile/Evaluator/Evaluate.hs | 11 ++++++++++- 1 files changed, 10 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index fcf0d45..bfe90a6 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -36,11 +36,20 @@ evaluatePrim iss tg pop tys args = do fmap (annedAnswer tg) $ fro res where to :: Answer -> Maybe CoreSyn.CoreExpr - to (mb_co, (rn, v)) = fmap (maybe id (flip CoreSyn.Cast . fst) mb_co) $ case v of + to (mb_co, (rn, v)) = fmap coerce $ case v of Literal l -> Just (CoreSyn.Lit l) Coercion co -> Just (CoreSyn.Coercion co) Data dc tys cos xs -> Just (CoreSyn.Var (dataConWrapId dc) `CoreSyn.mkTyApps` map (renameType iss rn) tys `CoreSyn.mkCoApps` cos `CoreSyn.mkVarApps` map (renameId rn) xs) _ -> Nothing + where + -- It is quite important that we don't wrap things with spurious refl coercions when it comes + -- to RULEs, because the default constant-folding rules don't trigger if there are too many coercions + coerce | Just (co, _tg) <- mb_co + , let Pair ty1 ty2 = coercionKind co + , not (ty1 `eqType` ty2) + = (`CoreSyn.Cast` co) + | otherwise + = id fro :: CoreSyn.CoreExpr -> Maybe Answer fro (CoreSyn.Cast e co) = fmap (\(mb_co', in_v) -> (Just (maybe co (\(co', _) -> co' `mkTransCo` co) mb_co', tg), in_v)) $ fro e _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
