summaryrefslogtreecommitdiff
path: root/compiler/GHC/Core/Opt
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Core/Opt')
-rw-r--r--compiler/GHC/Core/Opt/Arity.hs17
-rw-r--r--compiler/GHC/Core/Opt/CSE.hs29
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs26
-rw-r--r--compiler/GHC/Core/Opt/Exitify.hs1
-rw-r--r--compiler/GHC/Core/Opt/FloatIn.hs6
-rw-r--r--compiler/GHC/Core/Opt/SetLevels.hs3
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs14
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs1
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Monad.hs3
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs2
-rw-r--r--compiler/GHC/Core/Opt/StaticArgs.hs1
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs8
12 files changed, 45 insertions, 66 deletions
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
View Lorry Controller Status