[commit: ghc] master: Replace forall'ed Coercible by ~R# in RULES (b4715d6)
git at git.haskell.org
git at git.haskell.org
Tue Feb 11 15:40:21 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/b4715d67ae90f4cc847daa94f0fc056a40057d65/ghc
>---------------------------------------------------------------
commit b4715d67ae90f4cc847daa94f0fc056a40057d65
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).
>---------------------------------------------------------------
b4715d67ae90f4cc847daa94f0fc056a40057d65
compiler/basicTypes/Id.lhs | 5 +++++
compiler/basicTypes/OccName.lhs | 9 ++++----
compiler/deSugar/Desugar.lhs | 46 +++++++++++++++++++++++++++++++++++++--
3 files changed, 54 insertions(+), 6 deletions(-)
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 6194c50..aada6dc 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,
@@ -272,6 +273,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..cd75de9 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,7 @@ Reason
%************************************************************************
\begin{code}
+
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
@@ -359,9 +364,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 +377,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
@@ -398,6 +405,27 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
; return (Just rule)
} } }
+
+-- See Note [Desugaring coerce as cast]
+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)
+
\end{code}
Note [Desugaring RULE left hand sides]
@@ -417,6 +445,20 @@ the rule is precisly to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
+Note [Desugaring coerce as cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want the user to express a rule saying roughly “mapping a coercion over a
+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
+be written in Haskell. So we use `coerce` for that (#2110). The user writes
+ map coerce = coerce
+as a RULE, and this optimizes any kind of mapped' casts aways, including `map
+MkNewtype`.
+
+For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
+`let c = MkCoercible co in ...`. This is later simplified to the desired form
+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
+
%************************************************************************
%* *
%* Desugaring vectorisation declarations
More information about the ghc-commits
mailing list