[commit: ghc] : Ensure we don't wrap answers in spurious refl coercions, for the sake of rule matching (a91def9)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/a91def9c2a8a211895eb99a6aa888b697594fa9e

>---------------------------------------------------------------

commit a91def9c2a8a211895eb99a6aa888b697594fa9e
Author: Max Bolingbroke <[email protected]>
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