diff options
68 files changed, 617 insertions, 565 deletions
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 37d47e735d..8d4b576993 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -161,7 +161,6 @@ import GHC.Core.DataCon import {-# SOURCE #-} GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Class ( Class, mkClass ) -import GHC.Core.Multiplicity import GHC.Types.Name.Reader import GHC.Types.Name as Name import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) 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 diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 5c6b034360..a24fc52c69 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -29,7 +29,6 @@ import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id -import GHC.Types.Var ( updateVarTypeButNotMult ) import GHC.Types.ForeignCall import GHC.Driver.Types import GHC.Core.Utils @@ -38,7 +37,6 @@ import GHC.Core.Ppr import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Core.FVs -import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon @@ -710,7 +708,7 @@ protectNNLJoinPointBind x rhs@(fvs, _) protectNNLJoinPointId :: Id -> Id protectNNLJoinPointId x = ASSERT( isNNLJoinPoint x ) - updateVarTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x + updateIdTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x {- Ticked Expressions diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index e846e29ecf..e4139139a8 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -33,7 +33,6 @@ import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Types.Literal import GHC.Core.Coercion import GHC.Tc.Utils.Env @@ -917,11 +916,11 @@ cpeApp top_env expr (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, []) - (arg_ty, res_ty) = + (_, arg_ty, res_ty) = case splitFunTy_maybe fun_ty of Just as -> as Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr) - (fs, arg') <- cpeArg top_env ss1 arg (scaledThing arg_ty) + (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 ty2 = coercionRKind co diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 9297d1e4a0..af67088e51 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -43,7 +43,6 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl -import GHC.Core.Multiplicity import GHC.Builtin.Names import GHC.Builtin.Types.Prim import GHC.Core.Coercion diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index dd4b76f945..f904bc2616 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -1267,8 +1267,8 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) ; mkTrApp <- dsLookupGlobalId mkTrAppName -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). -- TypeRep a -> TypeRep b -> TypeRep (a b) - ; let (Scaled _ k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, - -- since it's a kind + ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, + -- since it's a kind ; let expr = mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) [ e1, e2 ] -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr @@ -1276,7 +1276,7 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) } ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) - | Just (Scaled m t1,t2) <- splitFunTy_maybe ty + | Just (m,t1,t2) <- splitFunTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 ; em <- getRep evm m diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index 05b1ce73fe..be8a2236d1 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -30,7 +30,6 @@ import GHC.Driver.Session import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.HsToCore.Match import GHC.Builtin.Names diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index eb8f865aa1..3052ff18af 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -39,7 +39,6 @@ import GHC.Core import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.DataCon -import GHC.Core.Multiplicity import GHC.Tc.Utils.Zonk ( shortCutLit ) import GHC.Tc.Utils.TcType import GHC.Types.Name @@ -149,7 +148,7 @@ warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () warnAboutIdentities dflags (Var conv_fn) type_of_conv | wopt Opt_WarnIdentities dflags , idName conv_fn `elem` conversionNames - , Just (Scaled _ arg_ty, res_ty) <- splitFunTy_maybe type_of_conv + , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (Reason Opt_WarnIdentities) (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index 4e96ce35f7..67667ab90f 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -57,7 +57,6 @@ import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.HsToCore.Utils (isTrueLHsExpr) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index db1975e807..c16a1f1d95 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -68,7 +68,6 @@ import GHC.Utils.Monad hiding (foldlM) import GHC.HsToCore.Monad hiding (foldlM) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv -import GHC.Core.Multiplicity import Control.Monad (guard, mzero, when) import Control.Monad.Trans.Class (lift) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 709a3a1698..d29afc5b8d 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -66,7 +66,6 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Core.Coercion import GHC.Builtin.Types.Prim import GHC.Builtin.Types @@ -142,7 +141,7 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _) = return (unLoc var) +selectMatchVar _w (AsPat _ var _) = ASSERT( isManyDataConTy _w ) (return (unLoc var)) selectMatchVar w other_pat = newSysLocalDsNoLP w (hsPatType other_pat) {- Note [Localise pattern binders] @@ -371,7 +370,7 @@ mkDataConCase var ty alts@(alt1 :| _) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) - let rep_ids' = map (scaleIdBy (idMult var)) rep_ids + let rep_ids' = map (scaleVarBy (idMult var)) rep_ids -- Upholds the invariant that the binders of a case expression -- must be scaled by the case multiplicity. See Note [Case -- expression invariants] in CoreSyn. diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 1b0eb0d604..060a27297f 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -78,7 +78,6 @@ import GHC.Data.FastString import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps import GHC.Fingerprint -import GHC.Core.Multiplicity import qualified GHC.Data.BooleanFormula as BF import Control.Monad diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index e33c8329d4..3755d8d84f 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -63,7 +63,6 @@ import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon -import GHC.Core.Multiplicity ( irrelevantMult ) import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type import GHC.Types.RepType @@ -1101,9 +1100,9 @@ findMatchingInstances ty = do k -> Constraint where k is the type of the queried type. -} try_cls ies cls - | Just (arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) , tcIsConstraintKind res_kind - , Type.typeKind ty `eqType` irrelevantMult arg_kind + , Type.typeKind ty `eqType` arg_kind , (matches, _, _) <- lookupInstEnv True ies cls [ty] = matches | otherwise diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index debcc68f29..f3a6122144 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -1264,8 +1264,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') ppr tv, equals, ppr ty_v] go ty_v r -- FunTy inductive case - | Just (Scaled w1 l1,l2) <- splitFunTy_maybe l - , Just (Scaled w2 r1,r2) <- splitFunTy_maybe r + | Just (w1,l1,l2) <- splitFunTy_maybe l + , Just (w2,r1,r2) <- splitFunTy_maybe r , w1 `eqType` w2 = do r2' <- go l2 r2 r1' <- go l1 r1 @@ -1334,8 +1334,8 @@ isMonomorphicOnNonPhantomArgs ty , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] = all isMonomorphicOnNonPhantomArgs concrete_args - | Just (ty1, ty2) <- splitFunTy_maybe ty - = all isMonomorphicOnNonPhantomArgs [scaledThing ty1,ty2] + | Just (_, ty1, ty2) <- splitFunTy_maybe ty + = all isMonomorphicOnNonPhantomArgs [ty1,ty2] | otherwise = isMonomorphic ty tyConPhantomTyVars :: TyCon -> [TyVar] diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 21097cc59f..dcfa0ce644 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -34,7 +34,7 @@ import GHC.Utils.Outputable import GHC.Data.OrdList import GHC.Stg.Subst import GHC.Stg.Syntax -import GHC.Core.Type +import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Types.Var.Env diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 3e5d2f3101..e78a58894d 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -220,7 +220,6 @@ import GHC.Builtin.Types import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Types.Var.Env -import GHC.Core.Multiplicity ( pattern Many ) import Data.Bifunctor (second) import Data.Maybe (mapMaybe) diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index a1af9166fe..3ccfb83cf7 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -40,7 +40,6 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index 17eff9a74b..f110b8c7f2 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -41,7 +41,6 @@ import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Ppr (pprTyVars) import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Tc.Solver import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor, checkConstraints) diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 2edce28eac..ebfe1e3003 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -462,7 +462,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = -- into [m, a] unwrapTypeVars :: Type -> [TyCoVarBinder] unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, unfunned) -> unwrapTypeVars unfunned + Just (_, _, unfunned) -> unwrapTypeVars unfunned _ -> [] where (vars, unforalled) = splitForAllVarBndrs t holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index fecd8b9b2e..d0da974326 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -88,7 +88,6 @@ import GHC.Core.TyCo.Ppr import GHC.Tc.Errors ( reportAllUnsolved ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder ) -import GHC.Core.Multiplicity import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Name.Reader( lookupLocalRdrOcc ) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 49de48cebd..723c07ec50 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -28,7 +28,6 @@ import GHC.Tc.Utils.Unify( buildImplicationFor ) import GHC.Tc.Types.Evidence( mkTcCoVarCo ) import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) -import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Types.Var( EvVar ) import GHC.Types.Var.Set diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 642e303442..f2f4065bc0 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -32,7 +32,6 @@ import GHC.Builtin.Names import GHC.Types.Id import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) import GHC.Types.Name ( Name, pprDefinedAt ) @@ -423,7 +422,7 @@ matchTypeable clas [k,t] -- clas = Typeable | k `eqType` typeNatKind = doTyLit knownNatClassName t | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret + | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt @@ -431,8 +430,8 @@ matchTypeable clas [k,t] -- clas = Typeable matchTypeable _ _ = return NoInstance -- | Representation for a type @ty@ of the form @arg -> ret@. -doFunTy :: Class -> Type -> Scaled Type -> Type -> TcM ClsInstResult -doFunTy clas ty (Scaled mult arg_ty) ret_ty +doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult +doFunTy clas ty mult arg_ty ret_ty = return $ OneInst { cir_new_theta = preds , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index a7b3d83e09..bed5779a8d 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -34,7 +34,6 @@ import GHC.Types.Id import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.DataCon -import GHC.Core.Multiplicity import GHC.Unit.Module import GHC.Hs import GHC.Driver.Session diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs index 79b42d29d5..cf0255b6c5 100644 --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -2526,7 +2526,7 @@ unify_derived loc role orig_ty1 orig_ty2 go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) = do { unify_derived loc role s1 s2 ; unify_derived loc role t1 t2 - ; unify_derived loc role w1 w2 } + ; unify_derived loc Nominal w1 w2 } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2, tys1 `equalLength` tys2 , isInjectiveTyCon tc1 role diff --git a/compiler/GHC/Tc/Solver/Flatten.hs b/compiler/GHC/Tc/Solver/Flatten.hs index 48249caa5c..2c3f020f68 100644 --- a/compiler/GHC/Tc/Solver/Flatten.hs +++ b/compiler/GHC/Tc/Solver/Flatten.hs @@ -39,8 +39,6 @@ import Data.Foldable ( foldrM ) import Control.Arrow ( first ) -import GHC.Core.Multiplicity - {- Note [The flattening story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1180,7 +1178,7 @@ flatten_one (TyConApp tc tys) flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) = do { (xi1,co1) <- flatten_one ty1 ; (xi2,co2) <- flatten_one ty2 - ; (xi3,co3) <- flatten_one mult + ; (xi3,co3) <- setEqRel NomEq $ flatten_one mult ; role <- getRole ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 } , mkFunCo role co3 co1 co2) } @@ -1921,12 +1919,14 @@ Flatten using the fun-eqs first. split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) split_pi_tys' ty = split ty ty where - split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' + -- put common cases first split _ (ForAllTy b res) = let (bs, ty, _) = split res res in (Named b : bs, ty, True) split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) = let (bs, ty, named) = split res res in (Anon af (mkScaled w arg) : bs, ty, named) + + split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index a4a56c0a14..edf7456b2c 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -824,9 +824,9 @@ swizzleTcTyConBndrs tc_infos swizzle_var :: Var -> Var swizzle_var v | Just nm <- lookupVarEnv swizzle_env v - = updateVarTypeAndMult swizzle_ty (v `setVarName` nm) + = updateVarType swizzle_ty (v `setVarName` nm) | otherwise - = updateVarTypeAndMult swizzle_ty v + = updateVarType swizzle_ty v (map_type, _, _, _) = mapTyCo swizzleMapper swizzle_ty ty = runIdentity (map_type ty) @@ -4563,7 +4563,7 @@ checkValidRoles tc >> check_ty_roles env Nominal ty2 check_ty_roles env role (FunTy _ w ty1 ty2) - = check_ty_roles env role w + = check_ty_roles env Nominal w >> check_ty_roles env role ty1 >> check_ty_roles env role ty2 diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index b49e81ddd2..a9557a2351 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -600,7 +600,7 @@ irType = go lcls' = extendVarSet lcls tv ; markNominal lcls (tyVarKind tv) ; go lcls' ty } - go lcls (FunTy _ w arg res) = go lcls w >> go lcls arg >> go lcls res + go lcls (FunTy _ w arg res) = markNominal lcls w >> go lcls arg >> go lcls res go _ (LitTy {}) = return () -- See Note [Coercions in role inference] go lcls (CastTy ty _) = go lcls ty diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 55c0ad4e67..eebe9eb8ed 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -113,7 +113,6 @@ import GHC.Data.Bag import GHC.Data.List.SetOps import GHC.Utils.Error import GHC.Data.Maybe( MaybeErr(..), orElse ) -import GHC.Core.Multiplicity import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Misc ( HasDebugCallStack ) diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index c33c335ac7..d2afbfb4ca 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -127,7 +127,6 @@ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair import GHC.Types.Unique.Set -import GHC.Core.Multiplicity import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Basic ( TypeOrKind(..) ) @@ -2040,7 +2039,7 @@ zonkImplication implic@(Implic { ic_skols = skols , ic_info = info' }) } zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = updateVarTypeAndMultM zonkTcType var +zonkEvVar var = updateIdTypeAndMultM zonkTcType var zonkWC :: WantedConstraints -> TcM WantedConstraints @@ -2315,7 +2314,7 @@ tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } ---------------- tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = updateVarTypeAndMult (tidyType env) var +tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ---------------- tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index f06cdd7d31..da6e71547f 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -200,7 +200,6 @@ import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr import GHC.Core.Class -import GHC.Core.Multiplicity import GHC.Types.Var import GHC.Types.ForeignCall import GHC.Types.Var.Set @@ -869,7 +868,7 @@ anyRewritableTyVar ignore_cos role pred ty go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg go rl bvs (FunTy _ w arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || - go rl bvs arg || go rl bvs res || go rl bvs w + go rl bvs arg || go rl bvs res || go NomEq bvs w where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 res_rep = getRuntimeRep res go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index a6711abcc1..75f4e83979 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -622,7 +622,7 @@ tc_sub_type unify inst_orig ctxt ty_actual ty_expected where possibly_poly ty | isForAllTy ty = True - | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res + | Just (_, _, res) <- splitFunTy_maybe ty = possibly_poly res | otherwise = False -- NB *not* tcSplitFunTy, because here we want -- to decompose type-class arguments too @@ -746,7 +746,8 @@ to a UserTypeCtxt of GenSigCtxt. Why? -- only produce trivial evidence, then this check would happen in the constraint -- solver. tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper -tcSubMult origin (MultMul w1 w2) w_expected = +tcSubMult origin w_actual w_expected + | Just (w1, w2) <- isMultMul w_actual = do { w1 <- tcSubMult origin w1 w_expected ; w2 <- tcSubMult origin w2 w_expected ; return (w1 <.> w2) } diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 05eb4d9ba4..6dd6026841 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -402,7 +402,7 @@ zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar -- Works for dictionaries and coercions -- Does not extend the ZonkEnv zonkEvBndr env var - = updateVarTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var + = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var {- zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm @@ -583,7 +583,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , (L loc bind@(FunBind { fun_id = (L mloc mono_id) , fun_matches = ms , fun_ext = co_fn })) <- lbind - = do { new_mono_id <- updateVarTypeAndMultM (zonkTcTypeToTypeX env) mono_id + = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 010100e98e..ac903fa021 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -49,14 +49,14 @@ module GHC.Types.Id ( -- ** Modifying an Id setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult, - updateIdTypeAndMult, updateIdTypeAndMultM, + updateIdTypeButNotMult, updateIdTypeAndMult, updateIdTypeAndMultM, setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, - transferPolyIdInfo, scaleIdBy, + transferPolyIdInfo, scaleIdBy, scaleVarBy, -- ** Predicates on Ids isImplicitId, isDeadBinder, @@ -135,7 +135,8 @@ import GHC.Types.Var( Id, CoVar, JoinId, InId, InVar, OutId, OutVar, idInfo, idDetails, setIdDetails, globaliseId, - isId, isLocalId, isGlobalId, isExportedId ) + isId, isLocalId, isGlobalId, isExportedId, + setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) import qualified GHC.Types.Var as Var import GHC.Core.Type @@ -201,10 +202,14 @@ idScaledType :: Id -> Scaled Type idScaledType id = Scaled (idMult id) (idType id) scaleIdBy :: Mult -> Id -> Id -scaleIdBy = Var.scaleVarBy +scaleIdBy m id = setIdMult id (m `mkMultMul` idMult id) -setIdMult :: Id -> Mult -> Id -setIdMult = Var.setVarMult +-- | Like 'scaleIdBy', but skips non-Ids. Useful for scaling +-- a mixed list of ids and tyvars. +scaleVarBy :: Mult -> Var -> Var +scaleVarBy m id + | isId id = scaleIdBy m id + | otherwise = id setIdName :: Id -> Name -> Id setIdName = Var.setVarName @@ -217,12 +222,6 @@ setIdUnique = Var.setVarUnique setIdType :: Id -> Type -> Id setIdType id ty = seqType ty `seq` Var.setVarType id ty -updateIdTypeAndMult :: (Type -> Type) -> Id -> Id -updateIdTypeAndMult = Var.updateVarTypeAndMult - -updateIdTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id -updateIdTypeAndMultM = Var.updateVarTypeAndMultM - setIdExported :: Id -> Id setIdExported = Var.setIdExported diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index dfc9cfc0dd..8baa5750f1 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -5,7 +5,8 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms #-} +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, + PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -46,19 +47,18 @@ module GHC.Types.Var ( -- ** Taking 'Var's apart varName, varUnique, varType, varMult, varMultMaybe, - varScaledType, -- ** Modifying 'Var's setVarName, setVarUnique, setVarType, - scaleVarBy, setVarMult, - updateVarTypeButNotMult, - updateVarTypeAndMult, updateVarTypeAndMultM, + updateVarType, updateVarTypeM, -- ** Constructing, taking apart, modifying 'Id's mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, idInfo, idDetails, lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, + setIdExported, setIdNotExported, setIdMult, + updateIdTypeButNotMult, + updateIdTypeAndMult, updateIdTypeAndMultM, -- ** Predicates isId, isTyVar, isTcTyVar, @@ -97,13 +97,12 @@ module GHC.Types.Var ( import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) -import GHC.Core.Multiplicity - +import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , mkUniqueGrimily, nonDetCmpUnique ) @@ -385,6 +384,10 @@ instance HasOccName Var where varUnique :: Var -> Unique varUnique var = mkUniqueGrimily (realUnique var) +varMultMaybe :: Id -> Maybe Mult +varMultMaybe (Id { varMult = mult }) = Just mult +varMultMaybe _ = Nothing + setVarUnique :: Var -> Unique -> Var setVarUnique var uniq = var { realUnique = getKey uniq, @@ -395,42 +398,39 @@ setVarName var new_name = var { realUnique = getKey (getUnique new_name), varName = new_name } -setVarType :: Id -> Type -> Id +setVarType :: Var -> Type -> Var setVarType id ty = id { varType = ty } -updateVarTypeButNotMult :: (Type -> Type) -> Id -> Id -updateVarTypeButNotMult f id = id { varType = f (varType id) } - -updateVarTypeAndMult :: (Type -> Type) -> Id -> Id -updateVarTypeAndMult f id = let id' = id { varType = f (varType id) } - in case varMultMaybe id' of - Just w -> setVarMult id' (f w) - Nothing -> id' - -updateVarTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id -updateVarTypeAndMultM f id = do { ty' <- f (varType id) - ; let id' = setVarType id ty' - ; case varMultMaybe id of - Just w -> do w' <- f w - return $ setVarMult id' w' - Nothing -> return id' - } - -varMultMaybe :: Id -> Maybe Mult -varMultMaybe (Id { varMult = mult }) = Just mult -varMultMaybe _ = Nothing - -varScaledType :: Id -> Scaled Kind -varScaledType var = Scaled (varMult var) (varType var) - -scaleVarBy :: Mult -> Id -> Id -scaleVarBy m id@(Id { varMult = w }) = - id { varMult = m `mkMultMul` w } -scaleVarBy _ id = id - -setVarMult :: Id -> Mult -> Id -setVarMult id r | isId id = id { varMult = r } - | otherwise = pprPanic "setVarMult" (ppr id <+> ppr r) +-- | Update a 'Var's type. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarType :: (Type -> Type) -> Var -> Var +updateVarType upd var + | debugIsOn + = case var of + Id { id_details = details } -> ASSERT( isCoVarDetails details ) + result + _ -> result + | otherwise + = result + where + result = var { varType = upd (varType var) } + +-- | Update a 'Var's type monadically. Does not update the /multiplicity/ +-- stored in an 'Id', if any. Because of the possibility for +-- abuse, ASSERTs that there is no multiplicity to update. +updateVarTypeM :: Monad m => (Type -> m Type) -> Var -> m Var +updateVarTypeM upd var + | debugIsOn + = case var of + Id { id_details = details } -> ASSERT( isCoVarDetails details ) + result + _ -> result + | otherwise + = result + where + result = do { ty' <- upd (varType var) + ; return (var { varType = ty' }) } {- ********************************************************************* * * @@ -548,7 +548,7 @@ where isPredTy is defined in GHC.Core.Type, and sees if t1's kind is Constraint. See GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence] -GHC.Core.Type.mkFunctionType :: Type -> Type -> Type +GHC.Core.Utils.mkFunctionType :: Mult -> Type -> Type -> Type uses isPredTy to decide the AnonArgFlag for the FunTy. The term (Lam b e), and coercion (FunCo co1 co2) don't carry @@ -766,7 +766,7 @@ idDetails other = pprPanic "idDetails" (ppr other) -- Ids, because "GHC.Types.Id" uses 'mkGlobalId' etc with different types mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkGlobalVar details name ty info - = mk_id name Many ty GlobalId details info + = mk_id name manyDataConTy ty GlobalId details info -- There is no support for linear global variables yet. They would require -- being checked at link-time, which can be useful, but is not a priority. @@ -776,16 +776,16 @@ mkLocalVar details name w ty info mkCoVar :: Name -> Type -> CoVar -- Coercion variables have no IdInfo -mkCoVar name ty = mk_id name Many ty (LocalId NotExported) coVarDetails vanillaIdInfo +mkCoVar name ty = mk_id name manyDataConTy ty (LocalId NotExported) coVarDetails vanillaIdInfo -- | Exported 'Var's will not be removed as dead code mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkExportedLocalVar details name ty info - = mk_id name Many ty (LocalId Exported) details info + = mk_id name manyDataConTy ty (LocalId Exported) details info -- There is no support for exporting linear variables. See also [mkGlobalVar] mk_id :: Name -> Mult -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name w ty scope details info +mk_id name !w ty scope details info = Id { varName = name, realUnique = getKey (nameUnique name), varMult = w, @@ -817,6 +817,33 @@ setIdNotExported :: Id -> Id setIdNotExported id = ASSERT( isLocalId id ) id { idScope = LocalId NotExported } +----------------------- +updateIdTypeButNotMult :: (Type -> Type) -> Id -> Id +updateIdTypeButNotMult f id = id { varType = f (varType id) } + + +updateIdTypeAndMult :: (Type -> Type) -> Id -> Id +updateIdTypeAndMult f id@(Id { varType = ty + , varMult = mult }) + = id { varType = ty' + , varMult = mult' } + where + !ty' = f ty + !mult' = f mult +updateIdTypeAndMult _ other = pprPanic "updateIdTypeAndMult" (ppr other) + +updateIdTypeAndMultM :: Monad m => (Type -> m Type) -> Id -> m Id +updateIdTypeAndMultM f id@(Id { varType = ty + , varMult = mult }) + = do { !ty' <- f ty + ; !mult' <- f mult + ; return (id { varType = ty', varMult = mult' }) } +updateIdTypeAndMultM _ other = pprPanic "updateIdTypeAndMultM" (ppr other) + +setIdMult :: Id -> Mult -> Id +setIdMult id r | isId id = id { varMult = r } + | otherwise = pprPanic "setIdMult" (ppr id <+> ppr r) + {- ************************************************************************ * * diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot index 6ea03efd91..78c748f7ec 100644 --- a/compiler/GHC/Types/Var.hs-boot +++ b/compiler/GHC/Types/Var.hs-boot @@ -1,14 +1,13 @@ module GHC.Types.Var where import GHC.Prelude () - -- We compile this module with -XNoImplicitPrelude (for some - -- reason), so if there are no imports it does not seem to - -- depend on anything. But it does! We must, for example, - -- compile GHC.Types in the ghc-prim library first. - -- So this otherwise-unnecessary import tells the build system - -- that this module depends on GHC.Prelude, which ensures - -- that GHC.Type is built first. + -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports + -- it does not seem to depend on anything. But it does! We must, for + -- example, compile GHC.Types in the ghc-prim library first. So this + -- otherwise-unnecessary import tells the build system that this module + -- depends on GhcPrelude, which ensures that GHC.Type is built first. data ArgFlag data AnonArgFlag data Var +type TyVar = Var diff --git a/testsuite/tests/codeGen/should_fail/T13233.hs b/testsuite/tests/codeGen/should_fail/T13233.hs index 42a30522f2..f24fc03bfb 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.hs +++ b/testsuite/tests/codeGen/should_fail/T13233.hs @@ -3,20 +3,19 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE LinearTypes #-} module Bug where import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# ) class Foo (a :: TYPE rep) where - bar :: forall rep2 (b :: TYPE rep2). (a #-> a #-> b) -> a #-> a #-> b + bar :: forall rep2 (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b -baz :: forall rep (a :: TYPE rep). Foo a => a #-> a #-> (# a, a #) +baz :: forall rep (a :: TYPE rep). Foo a => a -> a -> (# a, a #) baz = bar (#,#) obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep) (a :: TYPE rep1) (b :: TYPE rep2). - a #-> b #-> (# a, b #)) -> () + a -> b -> (# a, b #)) -> () obscure _ = () quux :: () diff --git a/testsuite/tests/codeGen/should_fail/T13233.stderr b/testsuite/tests/codeGen/should_fail/T13233.stderr index 1bbe161967..6f1636e544 100644 --- a/testsuite/tests/codeGen/should_fail/T13233.stderr +++ b/testsuite/tests/codeGen/should_fail/T13233.stderr @@ -1,11 +1,11 @@ -T13233.hs:23:16: error: +T13233.hs:22:16: error: A levity-polymorphic type is not allowed here: Type: a Kind: TYPE rep1 When trying to create a variable of type: a -T13233.hs:28:10: error: +T13233.hs:27:10: error: Cannot use function with levity-polymorphic arguments: mkWeak# :: a -> b |