[commit: ghc] : Add coercionKindNonRepr to work around coercionKind bug (028bb61)

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/028bb610d33b935e60c6846d031705578f08225b

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

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