Commit b4715d67 authored by Joachim Breitner's avatar Joachim Breitner
Browse files

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).
parent a4450ece
......@@ -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
......
......@@ -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"
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment