Commit 0a4ca9eb authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Split up coercionKind

This patch implements the idea in #17515, splitting `coercionKind` into:

 * `coercion{Left,Right}Kind`, which computes the left/right side of the
    pair
 * `coercionKind`, which computes the pair of coercible types

This is reduces allocation since we frequently only need only one side
of the pair. Specifically, we see the following improvements on x86-64
Debian 9:

| test     | new        | old           | relative chg. |
| :------- | ---------: | ------------: | ------------: |
| T5030	   | 695537752  | 747641152.0   | -6.97%        |
| T5321Fun | 449315744  | 474009040.0   | -5.21%        |
| T9872a   | 2611071400 | 2645040952.0  | -1.28%        |
| T9872c   | 2957097904 | 2994260264.0  | -1.24%        |
| T12227   | 773435072  | 812367768.0   | -4.79%        |
| T12545   | 3142687224 | 3215714752.0  | -2.27%        |
| T14683   | 9392407664 | 9824775000.0  | -4.40%        |

Metric Decrease:
    T12545
    T9872a
    T14683
    T5030
    T12227
    T9872c
    T5321Fun
    T9872b
parent ee07421f
Pipeline #13576 failed with stages
in 153 minutes and 32 seconds
......@@ -67,7 +67,6 @@ import UniqSupply
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
import Pair
import DynFlags
import Outputable
import FastString
......@@ -962,7 +961,7 @@ dataConArgRep arg_ty (HsUnpack Nothing)
= (rep_tys, wrappers)
dataConArgRep _ (HsUnpack (Just co))
| let co_rep_ty = pSnd (coercionKind co)
| let co_rep_ty = coercionRKind co
, (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
= (rep_tys, wrapCo co co_rep_ty wrappers)
......
......@@ -37,7 +37,6 @@ import Unique
import DynFlags ( DynFlags, GeneralFlag(..), gopt )
import Outputable
import FastString
import Pair
import Util ( debugIsOn )
{-
......@@ -98,7 +97,7 @@ exprArity e = go e
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Tick t e) | not (tickishIsCode t) = go e
go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co))
go (Cast e co) = trim_arity (go e) (coercionRKind co)
-- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
......@@ -744,7 +743,7 @@ arityType env (Cast e co)
ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo)
| otherwise -> ABot n
where
co_arity = length (typeArity (pSnd (coercionKind co)))
co_arity = length (typeArity (coercionRKind co))
-- See Note [exprArity invariant] (2); must be true of
-- arityType too, since that is how we compute the arity
-- of variables, and they in turn affect result of exprArity
......@@ -1038,7 +1037,7 @@ etaInfoAppTy :: Type -> [EtaInfo] -> Type
-- then etaInfoApp e eis :: etaInfoApp ty eis
etaInfoAppTy ty [] = ty
etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis
etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (pSnd (coercionKind co)) eis
etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis
--------------
mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
......
......@@ -1278,7 +1278,8 @@ pushCoTyArg co ty
| otherwise
= Nothing
where
Pair tyL tyR = coercionKind co
tyL = coercionLKind co
tyR = coercionRKind co
-- co :: tyL ~ tyR
-- tyL = forall (a1 :: k1). ty1
-- tyR = forall (a2 :: k2). ty2
......
......@@ -51,7 +51,6 @@ import OrdList
import ErrUtils
import DynFlags
import Util
import Pair
import Outputable
import GHC.Platform
import FastString
......@@ -932,7 +931,7 @@ cpeApp top_env expr
(fs, arg') <- cpeArg top_env ss1 arg arg_ty
rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
CpeCast co ->
let Pair _ty1 ty2 = coercionKind co
let ty2 = coercionRKind co
in rebuild_app as (Cast fun' co) ty2 floats ss
CpeTick tickish ->
-- See [Floating Ticks in CorePrep]
......
......@@ -177,7 +177,7 @@ isExprLevPoly = go
go_app (Lam _ e) = go_app e
go_app (Let _ e) = go_app e
go_app (Case _ _ ty _) = resultIsLevPoly ty
go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co)
go_app (Cast _ co) = resultIsLevPoly (coercionRKind co)
go_app (Tick _ e) = go_app e
go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e)
go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)
......@@ -267,15 +267,15 @@ mkCast e co
= e
mkCast (Coercion e_co) co
| isCoVarType (pSnd (coercionKind co))
| isCoVarType (coercionRKind co)
-- The guard here checks that g has a (~#) on both sides,
-- otherwise decomposeCo fails. Can in principle happen
-- with unsafeCoerce
= Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co
= WARN(let { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind co2} in
= WARN(let { from_ty = coercionLKind co;
to_ty2 = coercionRKind co2 } in
not (from_ty `eqType` to_ty2),
vcat ([ text "expr:" <+> ppr expr
, text "co2:" <+> ppr co2
......@@ -286,7 +286,7 @@ mkCast (Tick t expr) co
= Tick t (mkCast expr co)
mkCast expr co
= let Pair from_ty _to_ty = coercionKind co in
= let from_ty = coercionLKind co in
WARN( not (from_ty `eqType` exprType expr),
text "Trying to coerce" <+> text "(" <> ppr expr
$$ text "::" <+> ppr (exprType expr) <> text ")"
......
......@@ -51,7 +51,6 @@ import FastString
import DynFlags
import GHC.Platform
import OrdList
import Pair
import Util
import Hooks
import Encoding
......@@ -156,7 +155,7 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ _ = do
dflags <- getDynFlags
let ty = pFst $ coercionKind co
let ty = coercionLKind co
fod = case tyConAppTyCon_maybe (dropForAlls ty) of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
......@@ -204,7 +203,7 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall mDeclHeader = do
let
ty = pFst $ coercionKind co
ty = coercionLKind co
(tv_bndrs, rho) = tcSplitForAllVarBndrs ty
(arg_tys, io_res_ty) = tcSplitFunTys rho
......@@ -305,7 +304,7 @@ dsPrimCall :: Id -> Coercion -> ForeignCall
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsPrimCall fn_id co fcall = do
let
ty = pFst $ coercionKind co
ty = coercionLKind co
(tvs, fun_ty) = tcSplitForAllTys ty
(arg_tys, io_res_ty) = tcSplitFunTys fun_ty
......@@ -355,7 +354,7 @@ dsFExport :: Id -- Either the exported Id,
dsFExport fn_id co ext_name cconv isDyn = do
let
ty = pSnd $ coercionKind co
ty = coercionRKind co
(bndrs, orig_res_ty) = tcSplitPiTys ty
fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs
-- We must use tcSplits here, because we want to see
......@@ -477,7 +476,7 @@ dsFExportDynamic id co0 cconv = do
return ([fed], h_code, c_code)
where
ty = pFst (coercionKind co0)
ty = coercionLKind co0
(tvs,sans_foralls) = tcSplitForAllTys ty
([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
......
......@@ -66,7 +66,6 @@ import Util
import OrdList ( isNilOL )
import MonadUtils
import Outputable
import Pair
import PrelRules
import FastString ( fsLit )
......@@ -297,7 +296,7 @@ addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
, ai_type = pSnd (coercionKind co) }
, ai_type = coercionRKind co }
argInfoAppArgs :: [ArgSpec] -> [OutExpr]
argInfoAppArgs [] = []
......@@ -407,7 +406,7 @@ contResultType (TickIt _ k) = contResultType k
contHoleType :: SimplCont -> OutType
contHoleType (Stop ty _) = ty
contHoleType (TickIt _ k) = contHoleType k
contHoleType (CastIt co _) = pFst (coercionKind co)
contHoleType (CastIt co _) = coercionLKind co
contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
= perhapsSubstTy dup se (idType b)
contHoleType (StrictArg { sc_fun = ai }) = funArgTy (ai_type ai)
......
......@@ -50,7 +50,6 @@ import Maybes ( orElse )
import Control.Monad
import Outputable
import FastString
import Pair
import Util
import ErrUtils
import Module ( moduleName, pprModuleName )
......@@ -440,7 +439,7 @@ prepareRhs :: SimplMode -> TopLevelFlag
-- x = Just a
-- See Note [prepareRhs]
prepareRhs mode top_lvl occ info (Cast rhs co) -- Note [Float coercions]
| Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
| let ty1 = coercionLKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnliftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs
; return (floats, Cast rhs' co) }
......@@ -1308,7 +1307,7 @@ simplCast env body co0 cont0
-- only needed by `sc_hole_ty` which is often not forced.
-- Consequently it is worthwhile using a lazy pattern match here to
-- avoid unnecessary coercionKind evaluations.
, ~(Pair hole_ty _) <- coercionKind co
, let hole_ty = coercionLKind co
= {-#SCC "addCoerce-pushCoTyArg" #-}
do { tail' <- addCoerceM m_co' tail
; return (cont { sc_arg_ty = arg_ty'
......@@ -1319,7 +1318,7 @@ simplCast env body co0 cont0
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = tail })
| Just (co1, m_co2) <- pushCoValArg co
, Pair _ new_ty <- coercionKind co1
, let new_ty = coercionRKind co1
, not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg
-- See Note [Levity polymorphism invariants] in CoreSyn
-- test: typecheck/should_run/EtaExpandLevPoly
......
......@@ -19,8 +19,8 @@ module Coercion (
-- ** Functions over coercions
coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole,
coercionType, coercionKind, coercionKinds,
mkCoercionType,
coercionType, mkCoercionType,
coercionKind, coercionLKind, coercionRKind,coercionKinds,
coercionRole, coercionKindRole,
-- ** Constructing coercions
......@@ -1109,7 +1109,8 @@ nthCoRole n co
= pprPanic "nthCoRole" (ppr co)
where
(Pair lty _, r) = coercionKindRole co
lty = coercionLKind co
r = coercionRole co
mkLRCo :: LeftOrRight -> Coercion -> Coercion
mkLRCo lr co
......@@ -1532,7 +1533,7 @@ mkCoCast c g
-- g :: (s1 ~# t1) ~# (s2 ~# t2)
-- g1 :: s1 ~# s2
-- g2 :: t1 ~# t2
(tc, _) = splitTyConApp (pFst $ coercionKind g)
(tc, _) = splitTyConApp (coercionLKind g)
co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)
{-
......@@ -2005,7 +2006,7 @@ liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var
where
old_kind = tyVarKind old_var
(eta, stuff) = fun lc old_kind
Pair k1 _ = coercionKind eta
k1 = coercionLKind eta
new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1)
lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta
......@@ -2023,7 +2024,7 @@ liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var
where
old_kind = coVarKind old_var
(eta, stuff) = fun lc old_kind
Pair k1 _ = coercionKind eta
k1 = coercionLKind eta
new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1)
-- old_var :: s1 ~r s2
......@@ -2876,7 +2877,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
go acc_xis acc_cos lc [] inner_ki roles args
= let co1 = liftCoSubst Nominal lc inner_ki
co1_kind = coercionKind co1
unflattened_tys = map (pSnd . coercionKind . snd) args
unflattened_tys = map (coercionRKind . snd) args
(arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys
casted_args = ASSERT2( equalLength args arg_cos
, ppr args $$ ppr arg_cos )
......
......@@ -49,4 +49,6 @@ liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion
seqCo :: Coercion -> ()
coercionKind :: Coercion -> Pair Type
coercionLKind :: Coercion -> Type
coercionRKind :: Coercion -> Type
coercionType :: Coercion -> Type
......@@ -57,7 +57,6 @@ import CoreMap
import Unique
import Util
import Var
import Pair
import SrcLoc
import FastString
import Control.Monad
......@@ -1118,13 +1117,13 @@ reduceTyFamApp_maybe envs role tc tys
-- NB: Allow multiple matches because of compatible overlap
= let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos
ty = pSnd (coercionKind co)
ty = coercionRKind co
in Just (co, ty)
| Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
, Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys
= let co = mkAxInstCo role ax ind inst_tys inst_cos
ty = pSnd (coercionKind co)
ty = coercionRKind co
in Just (co, ty)
| Just ax <- isBuiltInSynFamTyCon_maybe tc
......@@ -1493,7 +1492,7 @@ normalise_tyvar tv
do { lc <- getLC
; r <- getRole
; return $ case liftCoSubstTyVar lc r tv of
Just co -> (co, pSnd $ coercionKind co)
Just co -> (co, coercionRKind co)
Nothing -> (mkReflCo r ty, ty) }
where ty = mkTyVarTy tv
......
......@@ -795,8 +795,9 @@ opt_trans_rule is co1 co2
role = coercionRole co1 -- should be the same as coercionRole co2!
opt_trans_rule _ co1 co2 -- Identity rule
| (Pair ty1 _, r) <- coercionKindRole co1
, Pair _ ty2 <- coercionKind co2
| let ty1 = coercionLKind co1
r = coercionRole co1
ty2 = coercionRKind co2
, ty1 `eqType` ty2
= fireTransRule "RedTypeDirRefl" co1 co2 $
mkReflCo r ty2
......@@ -824,11 +825,13 @@ opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
| otherwise
= ASSERT( co1bs `equalLength` co2bs )
fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $
let Pair _ rt1a = coercionKind co1a
(Pair lt2a _, rt2a) = coercionKindRole co2a
let rt1a = coercionRKind co1a
Pair _ rt1bs = traverse coercionKind co1bs
Pair lt2bs _ = traverse coercionKind co2bs
lt2a = coercionLKind co2a
rt2a = coercionRole co2a
rt1bs = map coercionRKind co1bs
lt2bs = map coercionLKind co2bs
rt2bs = map coercionRole co2bs
kcoa = mkKindCo $ buildCoercion lt2a rt1a
......@@ -972,7 +975,7 @@ checkAxInstCo (AxiomInstCo ax ind cos)
tvs = coAxBranchTyVars branch
cvs = coAxBranchCoVars branch
incomps = coAxBranchIncomps branch
(tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos)
(tys, cotys) = splitAtList tvs (map coercionLKind cos)
co_args = map stripCoercionTy cotys
subst = zipTvSubst tvs tys `composeTCvSubst`
zipCvSubst cvs co_args
......@@ -1045,8 +1048,8 @@ compatible_co :: Coercion -> Coercion -> Bool
compatible_co co1 co2
= x1 `eqType` x2
where
Pair _ x1 = coercionKind co1
Pair x2 _ = coercionKind co2
x1 = coercionRKind co1
x2 = coercionLKind co2
-------------
{-
......
......@@ -61,7 +61,7 @@ import {-# SOURCE #-} Coercion ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo
, mkAxiomInstCo, mkAppCo, mkGReflCo
, mkInstCo, mkLRCo, mkTyConAppCo
, mkCoercionType
, coercionKind, coVarKindsTypesRole )
, coercionKind, coercionLKind, coVarKindsTypesRole )
import TyCoRep
import TyCoFVs
......@@ -869,7 +869,7 @@ substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_ki
new_kind_co | no_kind_change = old_kind_co
| otherwise = sco old_kind_co
Pair new_ki1 _ = coercionKind new_kind_co
new_ki1 = coercionLKind new_kind_co
-- We could do substitution to (tyVarKind old_var). We don't do so because
-- we already substituted new_kind_co, which contains the kind information
-- we want. We don't want to do substitution once more. Also, in most cases,
......
......@@ -246,7 +246,8 @@ import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo
, mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo
, mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo
, mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo
, decomposePiCos, coercionKind, coercionType
, decomposePiCos, coercionKind, coercionLKind
, coercionRKind, coercionType
, isReflexiveCo, seqCo )
-- others
......@@ -2433,7 +2434,7 @@ typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
typeKind (LitTy l) = typeLiteralKind l
typeKind (FunTy {}) = liftedTypeKind
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (CastTy _ty co) = pSnd $ coercionKind co
typeKind (CastTy _ty co) = coercionRKind co
typeKind (CoercionTy co) = coercionType co
typeKind (AppTy fun arg)
......@@ -2466,7 +2467,7 @@ tcTypeKind :: HasDebugCallStack => Type -> Kind
tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
tcTypeKind (LitTy l) = typeLiteralKind l
tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar
tcTypeKind (CastTy _ty co) = pSnd $ coercionKind co
tcTypeKind (CastTy _ty co) = coercionRKind co
tcTypeKind (CoercionTy co) = coercionType co
tcTypeKind (FunTy { ft_af = af, ft_res = res })
......@@ -2694,7 +2695,7 @@ occCheckExpand vs_to_avoid ty
go_co cxt@(as, env) (ForAllCo tv kind_co body_co)
= do { kind_co' <- go_co cxt kind_co
; let tv' = setVarType tv $
pFst (coercionKind kind_co')
coercionLKind kind_co'
env' = extendVarEnv env tv tv'
as' = as `delVarSet` tv
; body' <- go_co (as', env') body_co
......
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