Commit 6cb84c46 authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Ben Gamari

Various performance improvements

This implements several general performance improvements to GHC,
to offset the effect of the linear types change.

General optimisations:
- Add a `coreFullView` function which iterates `coreView` on the
  head. This avoids making function recursive solely because the
  iterate `coreView` themselves. As a consequence, this functions can
  be inlined, and trigger case-of-known constructor (_e.g._
  `kindRep_maybe`, `isLiftedRuntimeRep`, `isMultiplicityTy`,
  `getTyVar_maybe`, `splitAppTy_maybe`, `splitFunType_maybe`,
  `tyConAppTyCon_maybe`). The common pattern about all these functions
  is that they are almost always used as views, and immediately
  consumed by a case expression. This commit also mark them asx `INLINE`.
- In `subst_ty` add a special case for nullary `TyConApp`, which avoid
  allocations altogether.
- Use `mkTyConApp` in `subst_ty` for the general `TyConApp`. This
  required quite a bit of module shuffling.
  case. `myTyConApp` enforces crucial sharing, which was lost during
  substitution. See also !2952 .
- Make `subst_ty` stricter.
- In `eqType` (specifically, in `nonDetCmpType`), add a special case,
  tested first, for the very common case of nullary `TyConApp`.
  `nonDetCmpType` has been made `INLINE` otherwise it is actually a
  regression. This is similar to the optimisations in !2952.

Linear-type specific optimisations:
- Use `tyConAppTyCon_maybe` instead of the more complex `eqType` in
  the definition of the pattern synonyms `One` and `Many`.
- Break the `hs-boot` cycles between `Multiplicity.hs` and `Type.hs`:
  `Multiplicity` now import `Type` normally, rather than from the
  `hs-boot`. This way `tyConAppTyCon_maybe` can inline properly in the
  `One` and `Many` pattern synonyms.
- Make `updateIdTypeAndMult` strict in its type and multiplicity
- The `scaleIdBy` gets a specialised definition rather than being an
  alias to `scaleVarBy`
- `splitFunTy_maybe` is given the type `Type -> Maybe (Mult, Type,
  Type)` instead of `Type -> Maybe (Scaled Type, Type)`
- Remove the `MultMul` pattern synonym in favour of a view `isMultMul`
  because pattern synonyms appear not to inline well.
- in `eqType`, in a `FunTy`, compare multiplicities last: they are
  almost always both `Many`, so it helps failing faster.
- Cache `manyDataConTy` in `mkTyConApp`, to make sure that all the
  instances of `TyConApp ManyDataConTy []` are physically the same.

This commit has been authored by
* Richard Eisenberg
* Krzysztof Gogolewski
* Arnaud Spiwack

Metric Decrease:
    haddock.base
    T12227
    T12545
    T12990
    T1969
    T3064
    T5030
    T9872b

Metric Increase:
    haddock.base
    haddock.Cabal
    haddock.compiler
    T12150
    T12234
    T12425
    T12707
    T13035
    T13056
    T15164
    T16190
    T18304
    T1969
    T3064
    T3294
    T5631
    T5642
    T5837
    T6048
    T9020
    T9233
    T9675
    T9872a
    T9961
    WWRec
parent 40fa237e
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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 )
......
......@@ -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)
......
......@@ -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
......
......@@ -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),
......
......@@ -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)
......@@ -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 $$
......
......@@ -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]
......
......@@ -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) ->
......
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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 )
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
{-# 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
......
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
......@@ -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