diff options
Diffstat (limited to 'compiler/GHC/Core')
32 files changed, 483 insertions, 434 deletions
diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 6b28adf371..03e0d59f38 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -134,6 +134,7 @@ import GHC.Core.TyCo.Tidy import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion.Axiom +import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -149,7 +150,6 @@ import GHC.Builtin.Types.Prim import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM -import GHC.Core.Multiplicity import Control.Monad (foldM, zipWithM) import Data.Function ( on ) @@ -397,8 +397,8 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args in go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys - | Just (_s1, t1) <- splitFunTy_maybe k1 - , Just (_s2, t2) <- splitFunTy_maybe k2 + | Just (_w1, _s1, t1) <- splitFunTy_maybe k1 + , Just (_w1, _s2, t2) <- splitFunTy_maybe k2 -- know co :: (s1 -> t1) ~ (s2 -> t2) -- function :: s1 -> t1 -- ty :: s2 diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot index 70c8328da1..831392e9ba 100644 --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -8,8 +8,7 @@ import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Types.Unique ( Uniquable ) import GHC.Utils.Outputable ( Outputable, OutputableBndr ) import GHC.Types.Basic (Arity) -import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType ) -import GHC.Core.Multiplicity (Scaled) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType, Scaled ) data DataCon data DataConRep diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index 5d65eec042..700f961b9a 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -76,7 +76,6 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.FamInstEnv -import GHC.Core.Multiplicity import GHC.Builtin.Types( unrestrictedFunTyConName ) import GHC.Builtin.Types.Prim( funTyConName ) import GHC.Data.Maybe( orElse ) diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 81221c25ed..a35f49b78f 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -1418,7 +1418,7 @@ normalise_type ty go ty@(FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) = do { (co1, nty1) <- go ty1 ; (co2, nty2) <- go ty2 - ; (wco, wty) <- go w + ; (wco, wty) <- withRole Nominal $ go w ; r <- getRole ; return (mkFunCo r wco co1 co2, ty { ft_mult = wty, ft_arg = nty1, ft_res = nty2 }) } go (ForAllTy (Bndr tcvar vis) ty) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 43c93595df..d14bc633fe 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1277,7 +1277,7 @@ lintTyApp fun_ty arg_ty -- application. lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue - | Just (Scaled w arg_ty', res_ty') <- splitFunTy_maybe fun_ty + | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty = do { ensureEqTys arg_ty' arg_ty err1 ; let app_ue = addUE fun_ue (scaleUE w arg_ue) ; return (res_ty', app_ue) } @@ -2743,17 +2743,18 @@ ensureSubMult actual_usage described_usage err_msg = do flags <- getLintFlags when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of Submult -> return () - Unknown -> case actual_usage' of - MultMul m1 m2 -> ensureSubMult m1 described_usage' err_msg >> + Unknown -> case isMultMul actual_usage' of + Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >> ensureSubMult m2 described_usage' err_msg - _ -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) + Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) where actual_usage' = normalize actual_usage described_usage' = normalize described_usage normalize :: Mult -> Mult - normalize (MultMul m1 m2) = mkMultMul (normalize m1) (normalize m2) - normalize m = m + normalize m = case isMultMul m of + Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2) + Nothing -> m lintRole :: Outputable thing => thing -- where the role appeared diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 9ea1ed85e0..40911f2a89 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -165,9 +165,9 @@ mkCoreAppTyped _ (fun, fun_ty) (Coercion co) = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) - (mkValApp fun arg arg_ty res_ty, res_ty) + (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty) where - (arg_ty, res_ty) = splitFunTy fun_ty + (mult, arg_ty, res_ty) = splitFunTy fun_ty mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -- Build an application (e1 e2), diff --git a/compiler/GHC/Core/Multiplicity.hs b/compiler/GHC/Core/Multiplicity.hs index a4203fa6e0..81e84e9936 100644 --- a/compiler/GHC/Core/Multiplicity.hs +++ b/compiler/GHC/Core/Multiplicity.hs @@ -14,7 +14,7 @@ module GHC.Core.Multiplicity ( Mult , pattern One , pattern Many - , pattern MultMul + , isMultMul , mkMultAdd , mkMultMul , mkMultSup @@ -34,11 +34,10 @@ module GHC.Core.Multiplicity import GHC.Prelude -import Data.Data import GHC.Utils.Outputable -import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type) -import {-# SOURCE #-} GHC.Builtin.Types ( oneDataConTy, manyDataConTy, multMulTyCon ) -import {-# SOURCE #-} GHC.Core.Type( eqType, splitTyConApp_maybe, mkTyConApp ) +import GHC.Core.TyCo.Rep +import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon ) +import GHC.Core.Type import GHC.Builtin.Names (multMulTyConKey) import GHC.Types.Unique (hasKey) @@ -271,45 +270,11 @@ To add a new multiplicity, you need to: and Zero -} --- --- * Core properties of multiplicities --- - -{- -Note [Mult is type] -~~~~~~~~~~~~~~~~~~~ -Mult is a type alias for Type. - -Mult must contain Type because multiplicity variables are mere type variables -(of kind Multiplicity) in Haskell. So the simplest implementation is to make -Mult be Type. - -Multiplicities can be formed with: -- One: GHC.Types.One (= oneDataCon) -- Many: GHC.Types.Many (= manyDataCon) -- Multiplication: GHC.Types.MultMul (= multMulTyCon) - -So that Mult feels a bit more structured, we provide pattern synonyms and smart -constructors for these. --} -type Mult = Type - -pattern One :: Mult -pattern One <- (eqType oneDataConTy -> True) - where One = oneDataConTy - -pattern Many :: Mult -pattern Many <- (eqType manyDataConTy -> True) - where Many = manyDataConTy - isMultMul :: Mult -> Maybe (Mult, Mult) isMultMul ty | Just (tc, [x, y]) <- splitTyConApp_maybe ty , tc `hasKey` multMulTyConKey = Just (x, y) | otherwise = Nothing -pattern MultMul :: Mult -> Mult -> Mult -pattern MultMul p q <- (isMultMul -> Just (p,q)) - {- Note [Overapproximating multiplicities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -341,6 +306,9 @@ mkMultMul Many _ = Many mkMultMul _ Many = Many mkMultMul p q = mkTyConApp multMulTyCon [p, q] +scaleScaled :: Mult -> Scaled a -> Scaled a +scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t + -- See Note [Joining usages] -- | @mkMultSup w1 w2@ returns a multiplicity such that @mkMultSup w1 -- w2 >= w1@ and @mkMultSup w1 w2 >= w2@. See Note [Overapproximating multiplicities]. @@ -368,43 +336,3 @@ submult One One = Submult -- The 1 <= p rule submult One _ = Submult submult _ _ = Unknown - --- --- * Utilities --- - --- | A shorthand for data with an attached 'Mult' element (the multiplicity). -data Scaled a = Scaled Mult a - deriving (Data) - -scaledMult :: Scaled a -> Mult -scaledMult (Scaled m _) = m - -scaledThing :: Scaled a -> a -scaledThing (Scaled _ t) = t - -unrestricted, linear, tymult :: a -> Scaled a -unrestricted = Scaled Many -linear = Scaled One - --- Used for type arguments in core -tymult = Scaled Many - -irrelevantMult :: Scaled a -> a -irrelevantMult = scaledThing - -mkScaled :: Mult -> a -> Scaled a -mkScaled = Scaled - -instance (Outputable a) => Outputable (Scaled a) where - ppr (Scaled _cnt t) = ppr t - -- Do not print the multiplicity here because it tends to be too verbose - -scaledSet :: Scaled a -> b -> Scaled b -scaledSet (Scaled m _) b = Scaled m b - -scaleScaled :: Mult -> Scaled a -> Scaled a -scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t - -mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type -mapScaledType f (Scaled m t) = Scaled (f m) (f t) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 44505ef0b6..5df571ee1c 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -125,8 +125,8 @@ typeArity ty | Just (_, ty') <- splitForAllTy_maybe ty = go rec_nts ty' - | Just (arg,res) <- splitFunTy_maybe ty - = typeOneShot (scaledThing arg) : go rec_nts res + | Just (_,arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys @@ -1090,17 +1090,18 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty -- lambda \co:ty. e co. In this case we generate a new variable -- of the coercion type, update the scope, and reduce n by 1. | isTyVar tcv = ((subst', tcv'), n) - | otherwise = (freshEtaId n subst' (varScaledType tcv'), n-1) + -- covar case: + | otherwise = (freshEtaId n subst' (unrestricted (varType tcv')), n-1) -- Avoid free vars of the original expression in go n_n n_subst ty' (EtaVar n_tcv : eis) ----------- Function types (t1 -> t2) - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , not (isTypeLevPoly (scaledThing arg_ty)) + | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , not (isTypeLevPoly arg_ty) -- See Note [Levity polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly - , let (subst', eta_id') = freshEtaId n subst arg_ty + , let (subst', eta_id') = freshEtaId n subst (Scaled mult arg_ty) -- Avoid free vars of the original expression = go (n-1) subst' res_ty (EtaVar eta_id' : eis) @@ -1183,8 +1184,8 @@ etaBodyForJoinPoint need_args body | Just (tv, res_ty) <- splitForAllTy_maybe ty , let (subst', tv') = Type.substVarBndr subst tv = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') - | Just (arg_ty, res_ty) <- splitFunTy_maybe ty - , let (subst', b) = freshEtaId n subst arg_ty + | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) | otherwise = pprPanic "etaBodyForJoinPoint" $ int need_args $$ diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs index 16a0137a4c..d6f37f6eb5 100644 --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -16,7 +16,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where import GHC.Prelude import GHC.Core.Subst -import GHC.Types.Var ( Var, varMultMaybe ) +import GHC.Types.Var ( Var ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Id ( Id, idType, idHasRules , idInlineActivation, setInlineActivation @@ -33,7 +33,6 @@ import GHC.Types.Basic import GHC.Core.Map import GHC.Utils.Misc ( filterOut, equalLength, debugIsOn ) import Data.List ( mapAccumL ) -import GHC.Core.Multiplicity {- Simple common sub-expression @@ -450,34 +449,8 @@ noCSE id = not (isAlwaysActive (idInlineActivation id)) && -- See Note [CSE for INLINE and NOINLINE] || isAnyInlinePragma (idInlinePragma id) -- See Note [CSE for stable unfoldings] - || not (multiplicityOkForCSE id) || isJoinId id -- See Note [CSE for join points?] - where - -- It doesn't make sense to do CSE for a binding which can't be freely - -- shared or dropped. In particular linear bindings, but this is true for - -- any binding whose multiplicity contains a variable. - -- - -- This shows up, in particular, when performing a substitution - -- - -- CSE[let x # 'One = y in x] - -- ==> let x # 'One = y in CSE[x[x\y]] - -- ==> let x # 'One = y in y - -- - -- Here @x@ doesn't appear in the body, but it is required by linearity! - -- Also @y@ appears shared, while we expect it to be a linear variable. - -- - -- This is usually not a problem with let-binders because they are aliases. - -- But we don't have such luxury for case binders. Still, substitution of - -- the case binder by the scrutinee happens routinely in CSE to discover - -- more CSE opportunities (see Note [CSE for case expressions]). - -- - -- It's alright, though! Because there is never a need to share linear - -- definitions. - multiplicityOkForCSE v = case varMultMaybe v of - Just Many -> True - Just _ -> False - Nothing -> True {- Note [Take care with literal strings] diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 6ca8efce2e..b0a83e5edb 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1557,10 +1557,10 @@ match_inline _ = Nothing -- for a description of what is going on here. match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] - | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap - , Just (dictTy, _) <- splitFunTy_maybe (scaledThing fieldTy) - , Just dictTc <- tyConAppTyCon_maybe (scaledThing dictTy) - , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc + | Just (_, fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap + , Just (_, dictTy, _) <- splitFunTy_maybe fieldTy + , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc = Just $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) `App` y @@ -1580,7 +1580,7 @@ match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> + Just (_, _, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_WordToInteger: Id has the wrong type" @@ -1590,7 +1590,7 @@ match_Int64ToInteger :: RuleFun match_Int64ToInteger _ id_unf id [xl] | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> + Just (_, _, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_Int64ToInteger: Id has the wrong type" @@ -1600,7 +1600,7 @@ match_Word64ToInteger :: RuleFun match_Word64ToInteger _ id_unf id [xl] | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of - Just (_, integerTy) -> + Just (_, _, integerTy) -> Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" @@ -1610,7 +1610,7 @@ match_NaturalToInteger :: RuleFun match_NaturalToInteger _ id_unf id [xl] | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> + Just (_, _, naturalTy) -> Just (Lit (LitNumber LitNumInteger x naturalTy)) _ -> panic "match_NaturalToInteger: Id has the wrong type" @@ -1621,7 +1621,7 @@ match_NaturalFromInteger _ id_unf id [xl] | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl , x >= 0 = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> + Just (_, _, naturalTy) -> Just (Lit (LitNumber LitNumNatural x naturalTy)) _ -> panic "match_NaturalFromInteger: Id has the wrong type" @@ -1631,7 +1631,7 @@ match_WordToNatural :: RuleFun match_WordToNatural _ id_unf id [xl] | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of - Just (_, naturalTy) -> + Just (_, _, naturalTy) -> Just (Lit (LitNumber LitNumNatural x naturalTy)) _ -> panic "match_WordToNatural: Id has the wrong type" @@ -1666,7 +1666,7 @@ match_bitInteger env id_unf fn [arg] -- would be a bad idea (#14959) , let x_int = fromIntegral x :: Int = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) + Just (_, _, integerTy) -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" @@ -1692,7 +1692,7 @@ match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun match_IntToInteger_unop unop _ id_unf fn [xl] | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of - Just (_, integerTy) -> + Just (_, _, integerTy) -> Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) _ -> panic "match_IntToInteger_unop: Id has the wrong type" @@ -1803,7 +1803,7 @@ match_decodeDouble :: RuleFun match_decodeDouble env id_unf fn [xl] | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of - Just (_, res) + Just (_, _, res) | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res -> case decodeFloat (fromRational x :: Double) of (y, z) -> diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs index 5aa893e7b6..7372b79ebc 100644 --- a/compiler/GHC/Core/Opt/Exitify.hs +++ b/compiler/GHC/Core/Opt/Exitify.hs @@ -50,7 +50,6 @@ import GHC.Types.Var.Env import GHC.Core.FVs import GHC.Data.FastString import GHC.Core.Type -import GHC.Core.Multiplicity ( pattern Many ) import GHC.Utils.Misc( mapSnd ) import Data.Bifunctor diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index 03a84b872c..896507d77a 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -36,9 +36,7 @@ import GHC.Types.Var.Set import GHC.Utils.Misc import GHC.Driver.Session import GHC.Utils.Outputable --- import Data.List ( mapAccumL ) import GHC.Types.Basic ( RecFlag(..), isRec ) -import GHC.Core.Multiplicity {- Top-level interface function, @floatInwards@. Note that we do not @@ -202,12 +200,12 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {}) = (piResultTy fun_ty ty, extra_fvs) add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg (irrelevantMult arg_ty) + | noFloatIntoArg arg arg_ty = (res_ty, extra_fvs `unionDVarSet` arg_fvs) | otherwise = (res_ty, extra_fvs) where - (arg_ty, res_ty) = splitFunTy fun_ty + (_, arg_ty, res_ty) = splitFunTy fun_ty {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index bdd28d6a2f..91e9f6ec34 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -84,6 +84,7 @@ import GHC.Core.Utils ( exprType, exprIsHNF , exprIsTopLevelBindable , isExprLevPoly , collectMakeStaticArgs + , mkLamTypes ) import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) import GHC.Core.FVs -- all of it @@ -103,7 +104,7 @@ import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey ) -import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType +import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet ) import GHC.Core.Multiplicity ( pattern Many ) import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index bf75a9de38..81cf962d91 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1035,8 +1035,16 @@ simplExprF1 env (App fun arg) cont , sc_hole_ty = hole' , sc_cont = cont } } _ -> + -- crucially, these are /lazy/ bindings. They will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. let fun_ty = exprType fun - (Scaled m _, _) = splitFunTy fun_ty + (m, _, _) = splitFunTy fun_ty in simplExprF env fun $ ApplyToVal { sc_arg = arg, sc_env = env @@ -1148,7 +1156,7 @@ simplJoinRhs env bndr expr cont | Just arity <- isJoinId_maybe bndr = do { let (join_bndrs, join_body) = collectNBinders arity expr mult = contHoleScaling cont - ; (env', join_bndrs') <- simplLamBndrs env (map (scaleIdBy mult) join_bndrs) + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) ; join_body' <- simplExprC env' join_body cont ; return $ mkLams join_bndrs' join_body' } @@ -2665,7 +2673,7 @@ rebuildCase env scrut case_bndr alts cont -- they are aliases anyway. scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = let - scale_id id = scaleIdBy holeScaling id + scale_id id = scaleVarBy holeScaling id in GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) scale_float f = f diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 5c8e0f21c2..71658c1295 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -63,7 +63,6 @@ import qualified GHC.Core.Type as Type import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) -import GHC.Core.Multiplicity import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index b84ed1028f..5c111374c8 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -27,9 +27,10 @@ import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) -import GHC.Core.Type ( Type, mkLamTypes, Mult ) +import GHC.Core.Type ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Core ( RuleEnv(..) ) +import GHC.Core.Utils ( mkLamTypes ) import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Core.Opt.Monad diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index c1cb4c9f3f..5f2db4508d 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -546,7 +546,7 @@ mkArgInfo env fun rules n_val_args call_cont add_type_str _ [] = [] add_type_str fun_ty all_strs@(str:strs) - | Just (Scaled _ arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info + | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info = (str || Just False == isLiftedType_maybe arg_ty) : add_type_str fun_ty' strs -- If the type is levity-polymorphic, we can't know whether it's diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs index dd015924e3..d4b76dc0d8 100644 --- a/compiler/GHC/Core/Opt/StaticArgs.hs +++ b/compiler/GHC/Core/Opt/StaticArgs.hs @@ -56,7 +56,6 @@ import GHC.Prelude import GHC.Types.Var import GHC.Core import GHC.Core.Utils -import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.Type import GHC.Core.Coercion import GHC.Types.Id diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 9da3065bed..2357c4e3e3 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -186,7 +186,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info -- Note [Do not split void functions] only_one_void_argument | [d] <- demands - , Just (Scaled _ arg_ty1, _) <- splitFunTy_maybe fun_ty + , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty , isAbsDmd d && isVoidTy arg_ty1 = True | otherwise @@ -422,9 +422,9 @@ mkWWargs subst fun_ty demands = return ([], id, id, substTy subst fun_ty) | (dmd:demands') <- demands - , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty + , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty = do { uniq <- getUniqueM - ; let arg_ty' = substScaledTy subst arg_ty + ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty) id = mk_wrap_arg uniq arg_ty' dmd ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs subst fun_ty' demands' @@ -1021,7 +1021,7 @@ findTypeShape fam_envs ty -- to look deep into such products -- see #18034 where go rec_tc ty - | Just (_, res) <- splitFunTy_maybe ty + | Just (_, _, res) <- splitFunTy_maybe ty = TsFun (go rec_tc res) | Just (tc, tc_args) <- splitTyConApp_maybe ty diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index 6f88fd897d..3902bb6b18 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -33,7 +33,6 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Utils.Misc -import GHC.Core.Multiplicity import GHC.Types.Basic import GHC.Types.Var import GHC.Types.FieldLabel diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index b0b6416c0b..4833d1e499 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1429,8 +1429,8 @@ pushCoercionIntoLambda pushCoercionIntoLambda in_scope x e co | ASSERT(not (isTyVar x) && not (isCoVar x)) True , Pair s1s2 t1t2 <- coercionKind co - , Just (_s1,_s2) <- splitFunTy_maybe s1s2 - , Just (Scaled w1 t1,_t2) <- splitFunTy_maybe t1t2 + , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 + , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2 , (co_mult, co1, co2) <- decomposeFunCo Representational co , isReflexiveCo co_mult -- We can't push the coercion in the case where co_mult isn't diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index c6bf57e6d2..44899be2ac 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + -- | Pretty-printing types and coercions. module GHC.Core.TyCo.Ppr ( @@ -34,10 +36,8 @@ import {-# SOURCE #-} GHC.CoreToIface import {-# SOURCE #-} GHC.Core.DataCon ( dataConFullSig , dataConUserTyVarBinders , DataCon ) -import GHC.Core.Multiplicity -import {-# SOURCE #-} GHC.Core.Type - ( isLiftedTypeKind ) +import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot index 8e89c334ea..2b1a787f1f 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs-boot +++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot @@ -1,10 +1,11 @@ module GHC.Core.TyCo.Ppr where +import {-# SOURCE #-} GHC.Types.Var ( TyVar ) import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit) -import GHC.Utils.Outputable +import GHC.Utils.Outputable ( SDoc ) pprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc pprTyLit :: TyLit -> SDoc - +pprTyVar :: TyVar -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index e201dcfea3..e72284477a 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -25,10 +25,7 @@ module GHC.Core.TyCo.Rep ( TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, -- * Types - Type( TyVarTy, AppTy, TyConApp, ForAllTy - , LitTy, CastTy, CoercionTy - , FunTy, ft_mult, ft_arg, ft_res, ft_af - ), -- Export the type synonym FunTy too + Type(..), TyLit(..), KindOrType, Kind, @@ -53,6 +50,7 @@ module GHC.Core.TyCo.Rep ( mkScaledFunTy, mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTyMany, mkInvisFunTysMany, + mkTyConApp, -- * Functions over binders TyCoBinder(..), TyCoVarBinder, TyBinder, @@ -69,7 +67,10 @@ module GHC.Core.TyCo.Rep ( TyCoFolder(..), foldTyCo, -- * Sizes - typeSize, coercionSize, provSize + typeSize, coercionSize, provSize, + + -- * Multiplicities + Scaled(..), scaledMult, scaledThing, mapScaledType, Mult ) where #include "HsVersions.h" @@ -87,12 +88,14 @@ import GHC.Iface.Type import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName ) -import GHC.Core.Multiplicity import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others +import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey ) +import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy ) import GHC.Types.Basic ( LeftOrRight(..), pickLR ) +import GHC.Types.Unique ( hasKey ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc @@ -1003,14 +1006,14 @@ mkVisFunTy = mkFunTy VisArg mkInvisFunTy = mkFunTy InvisArg mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkFunTyMany af = mkFunTy af Many +mkFunTyMany af = mkFunTy af manyDataConTy -- | Special, common, case: Arrow type with mult Many mkVisFunTyMany :: Type -> Type -> Type -mkVisFunTyMany = mkVisFunTy Many +mkVisFunTyMany = mkVisFunTy manyDataConTy mkInvisFunTyMany :: Type -> Type -> Type -mkInvisFunTyMany = mkInvisFunTy Many +mkInvisFunTyMany = mkInvisFunTy manyDataConTy -- | Make nested arrow types mkVisFunTys :: [Scaled Type] -> Type -> Type @@ -1046,6 +1049,58 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs mkTyConTy :: TyCon -> Type mkTyConTy tycon = TyConApp tycon [] +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon + , [w, _rep1,_rep2,ty1,ty2] <- tys + -- The FunTyCon (->) is always a visible one + = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } + + -- Note [mkTyConApp and Type] + | tycon `hasKey` liftedTypeKindTyConKey + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + liftedTypeKindTyConApp + | tycon `hasKey` manyDataConKey + -- There are a lot of occurrences of 'Many' so it's a small optimisation to + -- avoid reboxing every time `mkTyConApp` is called. + = ASSERT2( null tys, ppr tycon $$ ppr tys ) + manyDataConTy + | otherwise + = TyConApp tycon tys + +-- This is a single, global definition of the type `Type` +-- Defined here so it is only allocated once. +-- See Note [mkTyConApp and Type] +liftedTypeKindTyConApp :: Type +liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] + +{- +Note [mkTyConApp and Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whilst benchmarking it was observed in #17292 that GHC allocated a lot +of `TyConApp` constructors. Upon further inspection a large number of these +TyConApp constructors were all duplicates of `Type` applied to no arguments. + +``` +(From a sample of 100000 TyConApp closures) +0x45f3523 - 28732 - `Type` +0x420b840702 - 9629 - generic type constructors +0x42055b7e46 - 9596 +0x420559b582 - 9511 +0x420bb15a1e - 9509 +0x420b86c6ba - 9501 +0x42055bac1e - 9496 +0x45e68fd - 538 - `TYPE ...` +``` + +Therefore in `mkTyConApp` we have a special case for `Type` to ensure that +only one `TyConApp 'Type []` closure is allocated during the course of +compilation. In order to avoid a potentially expensive series of checks in +`mkTyConApp` only this egregious case is special cased at the moment. +-} + {- %************************************************************************ %* * @@ -1954,3 +2009,50 @@ provSize :: UnivCoProvenance -> Int provSize (PhantomProv co) = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _) = 1 + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These definitions are here to avoid module loops, and to keep +GHC.Core.Multiplicity above this module. + +-} + +-- | A shorthand for data with an attached 'Mult' element (the multiplicity). +data Scaled a = Scaled Mult a + deriving (Data.Data) + +instance (Outputable a) => Outputable (Scaled a) where + ppr (Scaled _cnt t) = ppr t + -- Do not print the multiplicity here because it tends to be too verbose + +scaledMult :: Scaled a -> Mult +scaledMult (Scaled m _) = m + +scaledThing :: Scaled a -> a +scaledThing (Scaled _ t) = t + +-- | Apply a function to both the Mult and the Type in a 'Scaled Type' +mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type +mapScaledType f (Scaled m t) = Scaled (f m) (f t) + +{- | +Mult is a type alias for Type. + +Mult must contain Type because multiplicity variables are mere type variables +(of kind Multiplicity) in Haskell. So the simplest implementation is to make +Mult be Type. + +Multiplicities can be formed with: +- One: GHC.Types.One (= oneDataCon) +- Many: GHC.Types.Many (= manyDataCon) +- Multiplication: GHC.Types.MultMul (= multMulTyCon) + +So that Mult feels a bit more structured, we provide pattern synonyms and smart +constructors for these. +-} +type Mult = Type diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index 25a22435cf..7bc1eb4f81 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -12,6 +12,9 @@ data TyLit data TyCoBinder data MCoercion +data Scaled a +type Mult = Type + type PredType = Type type Kind = Type type ThetaType = [PredType] diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs index 88799c2414..b3f51739b5 100644 --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -65,11 +65,10 @@ import {-# SOURCE #-} GHC.Core.Coercion , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType , coercionKind, coercionLKind, coVarKindsTypesRole ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr -import GHC.Core.Multiplicity import GHC.Types.Var import GHC.Types.Var.Set @@ -733,12 +732,15 @@ subst_ty subst ty = go ty where go (TyVarTy tv) = substTyVar subst tv - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + go (AppTy fun arg) = (mkAppTy $! (go fun)) $! (go arg) -- The mkAppTy smart constructor is important -- we might be replacing (a Int), represented with App -- by [Int], represented with TyConApp - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args + go ty@(TyConApp tc []) = tc `seq` ty -- avoid allocation in this common case + go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys + -- NB: mkTyConApp, not TyConApp. + -- mkTyConApp has optimizations. + -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res }) = let !mult' = go mult !arg' = go arg @@ -846,7 +848,7 @@ subst_co subst co -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) - = h { ch_co_var = updateVarTypeAndMult go_ty cv } + = h { ch_co_var = updateVarType go_ty cv } substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion -> (TCvSubst, TyCoVar, Coercion) diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs index bc586d77c8..dd07a2775f 100644 --- a/compiler/GHC/Core/TyCo/Tidy.hs +++ b/compiler/GHC/Core/TyCo/Tidy.hs @@ -52,7 +52,7 @@ tidyVarBndr tidy_env@(occ_env, subst) var (occ_env', occ') -> ((occ_env', subst'), var') where subst' = extendVarEnv subst var var' - var' = updateVarTypeAndMult (tidyType tidy_env) (setVarName var name') + var' = updateVarType (tidyType tidy_env) (setVarName var name') name' = tidyNameOcc name occ' name = varName var @@ -119,7 +119,7 @@ tidyOpenTyCoVar env@(_, subst) tyvar tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar tidyTyCoVarOcc env@(_, subst) tv = case lookupVarEnv subst tv of - Nothing -> updateVarTypeAndMult (tidyType env) tv + Nothing -> updateVarType (tidyType env) tv Just tv' -> tv' --------------- diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index eac2d8b109..20d789bd74 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -1872,6 +1872,7 @@ isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True isVanillaAlgTyCon _ = False -- | Returns @True@ for the 'TyCon' of the 'Constraint' kind. +{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type isConstraintKindCon :: TyCon -> Bool -- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is -- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector @@ -2032,6 +2033,7 @@ arguments are simply value arguments, and should not get in the way. -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type isTypeSynonymTyCon :: TyCon -> Bool isTypeSynonymTyCon (SynonymTyCon {}) = True isTypeSynonymTyCon _ = False @@ -2308,8 +2310,8 @@ expandSynTyCon_maybe tc tys GT -> Just (tvs `zip` tys, rhs, drop arity tys) EQ -> Just (tvs `zip` tys, rhs, []) LT -> Nothing - | otherwise - = Nothing + | otherwise + = Nothing ---------------- diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index bdf9ba21da..e853bdd2e5 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms #-} +{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -56,7 +56,6 @@ module GHC.Core.Type ( splitPiTy_maybe, splitPiTy, splitPiTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, - mkLamType, mkLamTypes, mkFunctionType, piResultTy, piResultTys, applyTysX, dropForAlls, mkFamilyTyConApp, @@ -133,9 +132,13 @@ module GHC.Core.Type ( dropRuntimeRepArgs, getRuntimeRep, - -- Multiplicity + -- * Multiplicity isMultiplicityTy, isMultiplicityVar, + unrestricted, linear, tymult, + mkScaled, irrelevantMult, scaledSet, + pattern One, pattern Many, + isOneDataConTy, isManyDataConTy, isLinearType, -- * Main data types representing Kinds @@ -244,7 +247,6 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs -import GHC.Core.Multiplicity -- friends: import GHC.Types.Var @@ -257,9 +259,9 @@ import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon, typeNatKind , typeSymbolKind, liftedTypeKind - , liftedTypeKindTyCon , constraintKind - , unrestrictedFunTyCon ) + , unrestrictedFunTyCon + , manyDataConTy, oneDataConTy ) import GHC.Types.Name( Name ) import GHC.Builtin.Names import GHC.Core.Coercion.Axiom @@ -282,7 +284,7 @@ import GHC.Data.Pair import GHC.Data.List.SetOps import GHC.Types.Unique ( nonDetCmpUnique ) -import GHC.Data.Maybe ( orElse ) +import GHC.Data.Maybe ( orElse, expectJust ) import Data.Maybe ( isJust, mapMaybe ) import Control.Monad ( guard ) @@ -402,6 +404,37 @@ coreView ty@(TyConApp tc tys) coreView _ = Nothing +{-# INLINE coreFullView #-} +coreFullView :: Type -> Type +-- ^ Iterates 'coreView' until there is no more to synonym to expand. +-- See Note [Inlining coreView]. +coreFullView ty@(TyConApp tc _) + | isTypeSynonymTyCon tc || isConstraintKindCon tc = go ty + where + go ty + | Just ty' <- coreView ty = go ty' + | otherwise = ty + +coreFullView ty = ty + +{- Note [Inlining coreView] in GHC.Core.Type +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very common to have a function + + f :: Type -> ... + f ty | Just ty' <- coreView ty = f ty' + f (TyVarTy ...) = ... + f ... = ... + +If f is not otherwise recursive, the initial call to coreView +causes f to become recursive, which kills the possibility of +inlining. Instead, for non-recursive functions, we prefer to +use coreFullView, which guarantees to unwrap top-level type +synonyms. It can be inlined and is efficient and non-allocating +in its fast path. For this to really be fast, all calls made +on its fast path must also be inlined, linked back to this Note. +-} + ----------------------------------------------- expandTypeSynonyms :: Type -> Type -- ^ Expand out all type synonyms. Actually, it'd suffice to expand out @@ -511,8 +544,7 @@ kindRep k = case kindRep_maybe k of -- Treats * and Constraint as the same kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type kindRep_maybe kind - | Just kind' <- coreView kind = kindRep_maybe kind' - | TyConApp tc [arg] <- kind + | TyConApp tc [arg] <- coreFullView kind , tc `hasKey` tYPETyConKey = Just arg | otherwise = Nothing @@ -530,8 +562,7 @@ isLiftedRuntimeRep :: Type -> Bool -- False of type variables (a :: RuntimeRep) -- and of other reps e.g. (IntRep :: RuntimeRep) isLiftedRuntimeRep rep - | Just rep' <- coreView rep = isLiftedRuntimeRep rep' - | TyConApp rr_tc args <- rep + | TyConApp rr_tc args <- coreFullView rep , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True | otherwise = False @@ -549,9 +580,8 @@ isUnliftedRuntimeRep :: Type -> Bool -- False of (LiftedRep :: RuntimeRep) -- and of variables (a :: RuntimeRep) isUnliftedRuntimeRep rep - | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' - | TyConApp rr_tc _ <- rep -- NB: args might be non-empty - -- e.g. TupleRep [r1, .., rn] + | TyConApp rr_tc _ <- coreFullView rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) -- Avoid searching all the unlifted RuntimeRep type cons -- In the RuntimeRep data type, only LiftedRep is lifted @@ -561,10 +591,11 @@ isUnliftedRuntimeRep rep -- | Is this the type 'RuntimeRep'? isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' -isRuntimeRepTy (TyConApp tc args) - | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True -isRuntimeRepTy _ = False +isRuntimeRepTy ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True + + | otherwise = False -- | Is a tyvar of type 'RuntimeRep'? isRuntimeRepVar :: TyVar -> Bool @@ -572,27 +603,14 @@ isRuntimeRepVar = isRuntimeRepTy . tyVarKind -- | Is this the type 'Multiplicity'? isMultiplicityTy :: Type -> Bool -isMultiplicityTy ty | Just ty' <- coreView ty = isMultiplicityTy ty' -isMultiplicityTy (TyConApp tc []) = tc `hasKey` multiplicityTyConKey -isMultiplicityTy _ = False +isMultiplicityTy ty + | TyConApp tc [] <- coreFullView ty = tc `hasKey` multiplicityTyConKey + | otherwise = False -- | Is a tyvar of type 'Multiplicity'? isMultiplicityVar :: TyVar -> Bool isMultiplicityVar = isMultiplicityTy . tyVarKind -isLinearType :: Type -> Bool --- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function --- where at least one argument is linear (or otherwise non-unrestricted). We use --- this function to check whether it is safe to eta reduce an Id in CorePrep. It --- is always safe to return 'True', because 'True' deactivates the optimisation. -isLinearType ty = case ty of - FunTy _ Many _ res -> isLinearType res - FunTy _ _ _ _ -> True - ForAllTy _ res -> isLinearType res - _ - | Just ty' <- coreView ty -> isLinearType ty' - | otherwise -> False - {- ********************************************************************* * * mapType @@ -780,17 +798,15 @@ isTyVarTy ty = isJust (getTyVar_maybe ty) -- | Attempts to obtain the type variable underlying a 'Type' getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' - | otherwise = repGetTyVar_maybe ty +getTyVar_maybe = repGetTyVar_maybe . coreFullView -- | If the type is a tyvar, possibly under a cast, returns it, along -- with the coercion. Thus, the co is :: kind tv ~N kind ty getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' -getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -getCastedTyVar_maybe (TyVarTy tv) - = Just (tv, mkReflCo Nominal (tyVarKind tv)) -getCastedTyVar_maybe _ = Nothing +getCastedTyVar_maybe ty = case coreFullView ty of + CastTy (TyVarTy tv) co -> Just (tv, co) + TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) + _ -> Nothing -- | Attempts to obtain the type variable underlying a 'Type', without -- any expansion @@ -869,9 +885,7 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempt to take a type application apart, whether it is a -- function, type constructor, or plain type application. Note -- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe ty | Just ty' <- coreView ty - = splitAppTy_maybe ty' -splitAppTy_maybe ty = repSplitAppTy_maybe ty +splitAppTy_maybe = repSplitAppTy_maybe . coreFullView ------------- repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) @@ -978,24 +992,24 @@ mkNumLitTy n = LitTy (NumTyLit n) -- | Is this a numeric literal. We also look through type synonyms. isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 -isNumLitTy (LitTy (NumTyLit n)) = Just n -isNumLitTy _ = Nothing +isNumLitTy ty + | LitTy (NumTyLit n) <- coreFullView ty = Just n + | otherwise = Nothing mkStrLitTy :: FastString -> Type mkStrLitTy s = LitTy (StrTyLit s) -- | Is this a symbol literal. We also look through type synonyms. isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 -isStrLitTy (LitTy (StrTyLit s)) = Just s -isStrLitTy _ = Nothing +isStrLitTy ty + | LitTy (StrTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing -- | Is this a type literal (symbol or numeric). isLitTy :: Type -> Maybe TyLit -isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 -isLitTy (LitTy l) = Just l -isLitTy _ = Nothing +isLitTy ty + | LitTy l <- coreFullView ty = Just l + | otherwise = Nothing -- | Is this type a custom user error? -- If so, give us the kind and the error message. @@ -1073,37 +1087,37 @@ In the compiler we maintain the invariant that all saturated applications of See #11714. -} -splitFunTy :: Type -> (Scaled Type, Type) +splitFunTy :: Type -> (Type, Type, Type) -- ^ Attempts to extract the argument and result types from a type, and -- panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (FunTy _ w arg res) = (Scaled w arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) +splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe -splitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) +{-# INLINE splitFunTy_maybe #-} +splitFunTy_maybe :: Type -> Maybe (Type, Type, Type) -- ^ Attempts to extract the argument and result types from a type -splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (FunTy _ w arg res) = Just (Scaled w arg, res) -splitFunTy_maybe _ = Nothing +splitFunTy_maybe ty + | FunTy _ w arg res <- coreFullView ty = Just (w, arg, res) + | otherwise = Nothing splitFunTys :: Type -> ([Scaled Type], Type) splitFunTys ty = split [] ty ty where - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + -- common case first split args _ (FunTy _ w arg res) = split ((Scaled w arg):args) res res + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' split args orig_ty _ = (reverse args, orig_ty) funResultTy :: Type -> Type -- ^ Extract the function result type and panic if that is not possible -funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (FunTy { ft_res = res }) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy ty + | FunTy { ft_res = res } <- coreFullView ty = res + | otherwise = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type -- ^ Extract the function argument type and panic if that is not possible -funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (FunTy { ft_arg = arg }) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy ty + | FunTy { ft_arg = arg } <- coreFullView ty = arg + | otherwise = pprPanic "funArgTy" (ppr ty) -- ^ Just like 'piResultTys' but for a single argument -- Try not to iterate 'piResultTy', because it's inefficient to substitute @@ -1116,19 +1130,15 @@ piResultTy ty arg = case piResultTy_maybe ty arg of piResultTy_maybe :: Type -> Type -> Maybe Type -- We don't need a 'tc' version, because -- this function behaves the same for Type and Constraint -piResultTy_maybe ty arg - | Just ty' <- coreView ty = piResultTy_maybe ty' arg +piResultTy_maybe ty arg = case coreFullView ty of + FunTy { ft_res = res } -> Just res - | FunTy { ft_res = res } <- ty - = Just res + ForAllTy (Bndr tv _) res + -> let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) - | ForAllTy (Bndr tv _) res <- ty - = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTCvSubst empty_subst tv arg) res) - - | otherwise - = Nothing + _ -> Nothing -- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) -- where f :: f_ty @@ -1154,15 +1164,15 @@ piResultTy_maybe ty arg piResultTys :: HasDebugCallStack => Type -> [Type] -> Type piResultTys ty [] = ty piResultTys ty orig_args@(arg:args) - | Just ty' <- coreView ty - = piResultTys ty' orig_args - | FunTy { ft_res = res } <- ty = piResultTys res args | ForAllTy (Bndr tv _) res <- ty = go (extendTCvSubst init_subst tv arg) res args + | Just ty' <- coreView ty + = piResultTys ty' orig_args + | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) where @@ -1172,15 +1182,15 @@ piResultTys ty orig_args@(arg:args) go subst ty [] = substTyUnchecked subst ty go subst ty all_args@(arg:args) - | Just ty' <- coreView ty - = go subst ty' all_args - | FunTy { ft_res = res } <- ty = go subst res args | ForAllTy (Bndr tv _) res <- ty = go (extendTCvSubst subst tv arg) res args + | Just ty' <- coreView ty + = go subst ty' all_args + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] = go init_subst (substTy subst ty) @@ -1234,58 +1244,11 @@ So again we must instantiate. The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. --------------------------------------- -Note [mkTyConApp and Type] - -Whilst benchmarking it was observed in #17292 that GHC allocated a lot -of `TyConApp` constructors. Upon further inspection a large number of these -TyConApp constructors were all duplicates of `Type` applied to no arguments. - -``` -(From a sample of 100000 TyConApp closures) -0x45f3523 - 28732 - `Type` -0x420b840702 - 9629 - generic type constructors -0x42055b7e46 - 9596 -0x420559b582 - 9511 -0x420bb15a1e - 9509 -0x420b86c6ba - 9501 -0x42055bac1e - 9496 -0x45e68fd - 538 - `TYPE ...` -``` - -Therefore in `mkTyConApp` we have a special case for `Type` to ensure that -only one `TyConApp 'Type []` closure is allocated during the course of -compilation. In order to avoid a potentially expensive series of checks in -`mkTyConApp` only this egregious case is special cased at the moment. - - --------------------------------------------------------------------- TyConApp ~~~~~~~~ -} --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon - , [w, _rep1,_rep2,ty1,ty2] <- tys - -- The FunTyCon (->) is always a visible one - = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } - - -- Note [mkTyConApp and Type] - | tycon == liftedTypeKindTyCon - = ASSERT2( null tys, ppr tycon $$ ppr tys ) - liftedTypeKindTyConApp - | otherwise - = TyConApp tycon tys - --- This is a single, global definition of the type `Type` --- Defined here so it is only allocated once. --- See Note [mkTyConApp and Type] -liftedTypeKindTyConApp :: Type -liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon [] - -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -1299,24 +1262,25 @@ tyConAppTyConPicky_maybe _ = Nothing -- | The same as @fst . splitTyConApp@ +{-# INLINE tyConAppTyCon_maybe #-} tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (FunTy {}) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing +tyConAppTyCon_maybe ty = case coreFullView ty of + TyConApp tc _ -> Just tc + FunTy {} -> Just funTyCon + _ -> Nothing tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) -- | The same as @snd . splitTyConApp@ tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (FunTy _ w arg res) - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - = Just [w, rep1, rep2, arg, res] -tyConAppArgs_maybe _ = Nothing +tyConAppArgs_maybe ty = case coreFullView ty of + TyConApp _ tys -> Just tys + FunTy _ w arg res + | Just rep1 <- getRuntimeRep_maybe arg + , Just rep2 <- getRuntimeRep_maybe res + -> Just [w, rep1, rep2, arg, res] + _ -> Nothing tyConAppArgs :: Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) @@ -1339,8 +1303,7 @@ splitTyConApp ty = case splitTyConApp_maybe ty of -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' -splitTyConApp_maybe ty = repSplitTyConApp_maybe ty +splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView -- | Split a type constructor application into its type constructor and -- applied types. Note that this may fail in the case of a 'FunTy' with an @@ -1398,9 +1361,9 @@ A casted type has its *kind* casted into something new. -} splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' -splitCastTy_maybe (CastTy ty co) = Just (ty, co) -splitCastTy_maybe _ = Nothing +splitCastTy_maybe ty + | CastTy ty' co <- coreFullView ty = Just (ty', co) + | otherwise = Nothing -- | Make a 'CastTy'. The Coercion must be nominal. Checks the -- Coercion for reflexivity, dropping it if it's reflexive. @@ -1543,41 +1506,6 @@ mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) -- covar is always Inferred, so all inputs should be tyvar mkForAllTys [ Bndr tv Required | tv <- tvs ] -mkLamType :: Var -> Type -> Type --- ^ Makes a @(->)@ type or an implicit forall type, depending --- on whether it is given a type variable or a term variable. --- This is used, for example, when producing the type of a lambda. --- Always uses Inferred binders. -mkLamTypes :: [Var] -> Type -> Type --- ^ 'mkLamType' for multiple type or value arguments - -mkLamTypes vs ty = foldr mkLamType ty vs - -mkLamType v body_ty - | isTyVar v - = ForAllTy (Bndr v Inferred) body_ty - - | isCoVar v - , v `elemVarSet` tyCoVarsOfType body_ty - = ForAllTy (Bndr v Required) body_ty - - | otherwise - = mkFunctionType arg_mult arg_ty body_ty - where - Scaled arg_mult arg_ty = varScaledType v - - -mkFunctionType :: Mult -> Type -> Type -> Type --- This one works out the AnonArgFlag from the argument type --- See GHC.Types.Var Note [AnonArgFlag] -mkFunctionType mult arg_ty res_ty - | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] - = ASSERT(eqType mult Many) - mkInvisFunTy mult arg_ty res_ty - - | otherwise - = mkVisFunTy mult arg_ty res_ty - -- | Given a list of type-level vars and the free vars of a result kind, -- makes TyCoBinders, preferring anonymous binders -- if the variable is, in fact, not dependent. @@ -1609,8 +1537,8 @@ mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) splitForAllTys :: Type -> ([TyCoVar], Type) splitForAllTys ty = split ty ty [] where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitForAllTys', but only splits a 'ForAllTy' if @argf_pred argf@ @@ -1620,9 +1548,9 @@ splitForAllTys ty = split ty ty [] splitSomeForAllTys :: (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type) splitSomeForAllTys argf_pred ty = split ty ty [] where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy tvb@(Bndr _ argf) ty) tvs | argf_pred argf = split ty ty (tvb:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Required' type @@ -1660,40 +1588,46 @@ splitForAllTysInvis ty = splitTyVarForAllTys :: Type -> ([TyVar], Type) splitTyVarForAllTys ty = split ty ty [] where - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool -isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' -isForAllTy (ForAllTy {}) = True -isForAllTy _ = False +isForAllTy ty + | ForAllTy {} <- coreFullView ty = True + | otherwise = False -- | Like `isForAllTy`, but returns True only if it is a tyvar binder isForAllTy_ty :: Type -> Bool -isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' -isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True -isForAllTy_ty _ = False +isForAllTy_ty ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False -- | Like `isForAllTy`, but returns True only if it is a covar binder isForAllTy_co :: Type -> Bool -isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' -isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True -isForAllTy_co _ = False +isForAllTy_co ty + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isCoVar tv + = True + + | otherwise = False -- | Is this a function or forall? isPiTy :: Type -> Bool -isPiTy ty | Just ty' <- coreView ty = isPiTy ty' -isPiTy (ForAllTy {}) = True -isPiTy (FunTy {}) = True -isPiTy _ = False +isPiTy ty = case coreFullView ty of + ForAllTy {} -> True + FunTy {} -> True + _ -> False -- | Is this a function? isFunTy :: Type -> Bool -isFunTy ty | Just ty' <- coreView ty = isFunTy ty' -isFunTy (FunTy {}) = True -isFunTy _ = False +isFunTy ty + | FunTy {} <- coreFullView ty = True + | otherwise = False -- | Take a forall type apart, or panics if that is not possible. splitForAllTy :: Type -> (TyCoVar, Type) @@ -1705,45 +1639,44 @@ splitForAllTy ty dropForAlls :: Type -> Type dropForAlls ty = go ty where - go ty | Just ty' <- coreView ty = go ty' go (ForAllTy _ res) = go res + go ty | Just ty' <- coreView ty = go ty' go res = res -- | Attempts to take a forall type apart, but only if it's a proper forall, -- with a named binder splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) - go _ = Nothing +splitForAllTy_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) + | otherwise = Nothing -- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_ty_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) - go _ = Nothing +splitForAllTy_ty_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isTyVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing -- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTy_co_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) - go _ = Nothing +splitForAllTy_co_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isCoVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing -- | Attempts to take a forall type apart; works with proper foralls and -- functions +{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) -splitPiTy_maybe ty = go ty - where - go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy bndr ty) = Just (Named bndr, ty) - go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}) - = Just (Anon af (mkScaled w arg), res) - go _ = Nothing +splitPiTy_maybe ty = case coreFullView ty of + ForAllTy bndr ty -> Just (Named bndr, ty) + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> Just (Anon af (mkScaled w arg), res) + _ -> Nothing -- | Takes a forall type apart, or panics splitPiTy :: Type -> (TyCoBinder, Type) @@ -1756,10 +1689,10 @@ splitPiTy ty splitPiTys :: Type -> ([TyCoBinder], Type) splitPiTys ty = split ty ty [] where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (Named b : bs) split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs = split res res (Anon af (Scaled w arg) : bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) -- | Like 'splitPiTys' but split off only /named/ binders @@ -1784,13 +1717,13 @@ invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) splitPiTysInvisible :: Type -> ([TyCoBinder], Type) splitPiTysInvisible ty = split ty ty [] where - split orig_ty ty bs - | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs | Bndr _ vis <- b , isInvisibleArgFlag vis = split res res (Named b : bs) split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res }) bs = split res res (Anon InvisArg (mkScaled mult arg) : bs) + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) @@ -2048,12 +1981,10 @@ buildSynTyCon name binders res_kind roles rhs -- levity polymorphic), and panics if the kind does not have the shape -- TYPE r. isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool -isLiftedType_maybe ty = go (getRuntimeRep ty) - where - go rr | Just rr' <- coreView rr = go rr' - | isLiftedRuntimeRep rr = Just True - | TyConApp {} <- rr = Just False -- Everything else is unlifted - | otherwise = Nothing -- levity polymorphic +isLiftedType_maybe ty = case coreFullView (getRuntimeRep ty) of + ty' | isLiftedRuntimeRep ty' -> Just True + TyConApp {} -> Just False -- Everything else is unlifted + _ -> Nothing -- levity polymorphic -- | See "Type#type_classification" for what an unlifted type is. -- Panics on levity polymorphic types; See 'mightBeUnliftedType' for @@ -2179,7 +2110,7 @@ isValidJoinPointType arity ty = tvs `disjointVarSet` tyCoVarsOfType ty | Just (t, ty') <- splitForAllTy_maybe ty = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, res_ty) <- splitFunTy_maybe ty + | Just (_, _, res_ty) <- splitFunTy_maybe ty = valid_under tvs (arity-1) res_ty | otherwise = False @@ -2309,11 +2240,14 @@ See Note [Unique Determinism] for more details. -} nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 + = EQ nonDetCmpType t1 t2 -- we know k1 and k2 have the same kind, because they both have kind *. = nonDetCmpTypeX rn_env t1 t2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) +{-# INLINE nonDetCmpType #-} nonDetCmpTypes :: [Type] -> [Type] -> Ordering nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 @@ -2382,8 +2316,8 @@ nonDetCmpTypeX env orig_t1 orig_t2 = | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - = go env w1 w2 `thenCmpTy` - go env s1 s2 `thenCmpTy` go env t1 t2 + = go env s1 s2 `thenCmpTy` go env t1 t2 `thenCmpTy` go env w1 w2 + -- Comparing multiplicities last because the test is usually true go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) @@ -2775,7 +2709,7 @@ occCheckExpand vs_to_avoid ty ; return (mkCoercionTy co') } ------------------ - go_var cxt v = updateVarTypeAndMultM (go cxt) v + go_var cxt v = updateVarTypeM (go cxt) v -- Works for TyVar and CoVar -- See Note [Occurrence checking: look inside kinds] @@ -3320,3 +3254,66 @@ be reified as: So the kind of G isn't ambiguous anymore due to the explicit kind annotation on its argument. See #8953 and test th/T8953. -} + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These functions would prefer to be in GHC.Core.Multiplicity, but +they some are used elsewhere in this module, and wanted to bring +their friends here with them. +-} + +unrestricted, linear, tymult :: a -> Scaled a + +-- | Scale a payload by Many +unrestricted = Scaled Many + +-- | Scale a payload by One +linear = Scaled One + +-- | Scale a payload by Many; used for type arguments in core +tymult = Scaled Many + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +pattern One :: Mult +pattern One <- (isOneDataConTy -> True) + where One = oneDataConTy + +pattern Many :: Mult +pattern Many <- (isManyDataConTy -> True) + where Many = manyDataConTy + +isManyDataConTy :: Mult -> Bool +isManyDataConTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` manyDataConKey +isManyDataConTy _ = False + +isOneDataConTy :: Mult -> Bool +isOneDataConTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` oneDataConKey +isOneDataConTy _ = False + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- this function to check whether it is safe to eta reduce an Id in CorePrep. It +-- is always safe to return 'True', because 'True' deactivates the optimisation. +isLinearType ty = case ty of + FunTy _ Many _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res + _ -> False diff --git a/compiler/GHC/Core/Type.hs-boot b/compiler/GHC/Core/Type.hs-boot index 1faf4304ab..bada997f3b 100644 --- a/compiler/GHC/Core/Type.hs-boot +++ b/compiler/GHC/Core/Type.hs-boot @@ -14,8 +14,6 @@ mkAppTy :: Type -> Type -> Type mkCastTy :: Type -> Coercion -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type -eqType :: Type -> Type -> Bool - coreView :: Type -> Maybe Type tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool @@ -23,7 +21,6 @@ isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) - -mkTyConApp :: TyCon -> [Type] -> Type +tyConAppTyCon_maybe :: Type -> Maybe TyCon partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 9748dd2753..65ded60520 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,7 +23,9 @@ module GHC.Core.Utils ( scaleAltsBy, -- * Properties of expressions - exprType, coreAltType, coreAltsType, isExprLevPoly, + exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, + mkFunctionType, + isExprLevPoly, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, @@ -151,6 +153,38 @@ coreAltsType :: [CoreAlt] -> Type coreAltsType (alt:_) = coreAltType alt coreAltsType [] = panic "corAltsType" +mkLamType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- Always uses Inferred binders. +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = mkForAllTy v Inferred body_ty + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + = mkForAllTy v Required body_ty + + | otherwise + = mkFunctionType (varMult v) (varType v) body_ty + +mkFunctionType :: Mult -> Type -> Type -> Type +-- This one works out the AnonArgFlag from the argument type +-- See GHC.Types.Var Note [AnonArgFlag] +mkFunctionType mult arg_ty res_ty + | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] + = ASSERT(eqType mult Many) + mkInvisFunTy mult arg_ty res_ty + + | otherwise + = mkVisFunTy mult arg_ty res_ty + +mkLamTypes vs ty = foldr mkLamType ty vs + -- | Is this expression levity polymorphic? This should be the -- same as saying (isKindLevPoly . typeKind . exprType) but -- much faster. @@ -237,7 +271,7 @@ applyTypeToArgs e op_ty args go op_ty [] = op_ty go op_ty (Type ty : args) = go_ty_args op_ty [ty] args go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args - go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + go op_ty (_ : args) | Just (_, _, res_ty) <- splitFunTy_maybe op_ty = go res_ty args go _ args = pprPanic "applyTypeToArgs" (panic_msg args) @@ -944,7 +978,7 @@ scaleAltsBy w alts = map scaleAlt alts scaleAlt (con, bndrs, rhs) = (con, map scaleBndr bndrs, rhs) scaleBndr :: CoreBndr -> CoreBndr - scaleBndr = scaleVarBy w + scaleBndr b = scaleVarBy w b {- ********************************************************************* @@ -2454,13 +2488,13 @@ tryEtaReduce bndrs body ok_arg bndr (Var v) co fun_ty | bndr == v , let mult = idMult bndr - , Just (Scaled fun_mult _, _) <- splitFunTy_maybe fun_ty + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort = let reflCo = mkRepReflCo (idType bndr) in Just (mkFunCo Representational (multToCo mult) reflCo co, []) ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (Scaled fun_mult _, _) <- splitFunTy_maybe fun_ty + , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty , bndr == v , fun_mult `eqType` idMult bndr = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) diff --git a/compiler/GHC/Core/Utils.hs-boot b/compiler/GHC/Core/Utils.hs-boot new file mode 100644 index 0000000000..6dab0d5963 --- /dev/null +++ b/compiler/GHC/Core/Utils.hs-boot @@ -0,0 +1,6 @@ +module GHC.Core.Utils where + +import GHC.Core.Multiplicity +import GHC.Core.Type + +mkFunctionType :: Mult -> Type -> Type -> Type |