[commit: ghc] wip/nomeata-T2110: Replace forall'ed Coercible by ~R# in RULES (b76e50d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nomeata-T2110
Link       : http://ghc.haskell.org/trac/ghc/changeset/b76e50d94deef792e1adf8101824db1c89a8763e/ghc

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

commit b76e50d94deef792e1adf8101824db1c89a8763e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Jan 24 13:33:37 2014 +0000

    Replace forall'ed Coercible by ~R# in RULES
    
    we want a rule "map coerce = coerce" to match the core generated for
    "map Age" (this is #2110).


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

b76e50d94deef792e1adf8101824db1c89a8763e
 compiler/basicTypes/Id.lhs      |    5 +++++
 compiler/basicTypes/OccName.lhs |    9 +++++----
 compiler/deSugar/Desugar.lhs    |   30 ++++++++++++++++++++++++++++--
 3 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 50b3641..0020032 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -30,6 +30,7 @@ module Id (
         mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
         mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
         mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
+        mkDerivedLocalM,
         mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
         mkWorkerId, mkWiredInIdName,
 
@@ -269,6 +270,10 @@ mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
 mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
 mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
 
+mkDerivedLocalM :: MonadUnique m => (OccName -> OccName) -> Id -> Type -> m Id
+mkDerivedLocalM deriv_name id ty
+    = getUniqueM >>= (\uniq -> return (mkLocalId (mkDerivedInternalName deriv_name uniq (getName id)) ty))
+
 mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
 mkWiredInIdName mod fs uniq id
  = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 6dbae4b..e993767 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -62,9 +62,9 @@ module OccName (
         mkGenDefMethodOcc, 
 	mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
-  	mkClassDataConOcc, mkDictOcc, mkIPOcc, 
- 	mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- 	mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
+	mkClassDataConOcc, mkDictOcc, mkIPOcc,
+	mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
+	mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 	mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc,
@@ -572,7 +572,7 @@ isDerivedOccName occ =
 \begin{code}
 mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
         mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
- 	mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+	mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
  	mkGenD, mkGenR, mkGen1R, mkGenRCo,
 	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
@@ -593,6 +593,7 @@ mkDictOcc	    = mk_simple_deriv varName  "$d"
 mkIPOcc		    = mk_simple_deriv varName  "$i"
 mkSpecOcc	    = mk_simple_deriv varName  "$s"
 mkForeignExportOcc  = mk_simple_deriv varName  "$f"
+mkRepEqOcc          = mk_simple_deriv tvName   "$r"      -- In RULES involving Coercible
 mkNewTyCoOcc        = mk_simple_deriv tcName   "NTCo:"	-- Coercion for newtypes
 mkInstTyCoOcc       = mk_simple_deriv tcName   "TFCo:"   -- Coercion for type functions
 mkEqPredCoOcc	    = mk_simple_deriv tcName   "$co"
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e13767f..663c1cd 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -18,6 +18,7 @@ import Id
 import Name
 import Type
 import FamInstEnv
+import Coercion
 import InstEnv
 import Class
 import Avail
@@ -33,8 +34,11 @@ import Module
 import NameSet
 import NameEnv
 import Rules
+import TysPrim (eqReprPrimTyCon)
+import TysWiredIn (coercibleTyCon )
 import BasicTypes       ( Activation(.. ) )
 import CoreMonad        ( endPass, CoreToDo(..) )
+import MkCore
 import FastString
 import ErrUtils
 import Outputable
@@ -347,6 +351,26 @@ Reason
 %************************************************************************
 
 \begin{code}
+
+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
+unfold_coerce bndrs lhs rhs = do
+    (bndrs', wrap) <- go bndrs
+    return (bndrs', wrap lhs, wrap rhs)
+  where
+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
+    go []     = return ([], id)
+    go (v:vs)
+        | Just (tc, args) <- splitTyConApp_maybe (idType v)
+        , tc == coercibleTyCon = do
+            let ty' = mkTyConApp eqReprPrimTyCon args
+            v' <- mkDerivedLocalM mkRepEqOcc v ty'
+
+            (bndrs, wrap) <- go vs
+            return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
+        | otherwise = do
+            (bndrs,wrap) <- go vs
+            return (v:bndrs, wrap)
+
 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $
@@ -359,9 +383,11 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
         ; rhs' <- dsLExpr rhs
         ; dflags <- getDynFlags
 
+        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
+
         -- Substitute the dict bindings eagerly,
         -- and take the body apart into a (f args) form
-        ; case decomposeRuleLhs bndrs' lhs' of {
+        ; case decomposeRuleLhs bndrs'' lhs'' of {
                 Left msg -> do { warnDs msg; return Nothing } ;
                 Right (final_bndrs, fn_id, args) -> do
 
@@ -370,7 +396,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                 -- we don't want to attach rules to the bindings of implicit Ids,
                 -- because they don't show up in the bindings until just before code gen
               fn_name   = idName fn_id
-              final_rhs = simpleOptExpr rhs'    -- De-crap it
+              final_rhs = simpleOptExpr rhs''    -- De-crap it
               rule      = mkRule False {- Not auto -} is_local
                                  name act fn_name final_bndrs args final_rhs