[Git][ghc/ghc][wip/T18494] Kill off sc_mult and as_mult fields
Simon Peyton Jones
gitlab at gitlab.haskell.org
Fri Jul 24 16:44:39 UTC 2020
Simon Peyton Jones pushed to branch wip/T18494 at Glasgow Haskell Compiler / GHC
Commits:
4e3a0d55 by Simon Peyton Jones at 2020-07-24T17:44:03+01:00
Kill off sc_mult and as_mult fields
They are readily derivable from other fields, so this is more
efficient, and less error prone.
Fixes #18494
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1002,7 +1002,7 @@ simplExprF1 env (App fun arg) cont
, sc_hole_ty = hole'
, sc_cont = cont } }
_ ->
- -- crucially, these are /lazy/ bindings. They will
+ -- Crucially, sc_hole_ty is a /lazy/ binding. It 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
@@ -1010,13 +1010,10 @@ simplExprF1 env (App fun arg) cont
-- (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
- (m, _, _) = splitFunTy fun_ty
- in
simplExprF env fun $
ApplyToVal { sc_arg = arg, sc_env = env
, sc_hole_ty = substTy env (exprType fun)
- , sc_dup = NoDup, sc_cont = cont, sc_mult = m }
+ , sc_dup = NoDup, sc_cont = cont }
simplExprF1 env expr@(Lam {}) cont
= {-#SCC "simplExprF1-Lam" #-}
@@ -1321,8 +1318,8 @@ rebuild env expr cont
Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
-> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
- StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }
- -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont
+ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
+ -> rebuildCall env (addValArgTo fun expr fun_ty ) cont
StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
, sc_env = se, sc_cont = cont }
-> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
@@ -1414,7 +1411,7 @@ simplCast env body co0 cont0
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_dup = dup, sc_cont = tail, sc_mult = m })
+ , sc_dup = dup, sc_cont = tail })
| Just (co1, m_co2) <- pushCoValArg co
, let new_ty = coercionRKind co1
, not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg
@@ -1438,8 +1435,7 @@ simplCast env body co0 cont0
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail'
- , sc_hole_ty = coercionLKind co
- , sc_mult = m }) } }
+ , sc_hole_ty = coercionLKind co }) } }
addCoerce co cont
| isReflexiveCo co = return cont -- Having this at the end makes a huge
@@ -1975,17 +1971,18 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se
+ , sc_cont = cont, sc_hole_ty = fun_ty })
| fun `hasKey` runRWKey
, not (contIsStop cont) -- Don't fiddle around if the continuation is boring
, [ TyArg {}, TyArg {} ] <- rev_args
= do { s <- newId (fsLit "s") Many realWorldStatePrimTy
- ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ ; let (m,_,_) = splitFunTy fun_ty
+ env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
ty' = contResultType cont
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
, sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'
- , sc_mult = m }
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
-- cont' applies to s, then K
; body' <- simplExprC env' arg cont'
; let arg' = Lam s body'
@@ -1997,10 +1994,10 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
- = rebuildCall env (addValArgTo info' (m, arg) fun_ty) cont
+ = rebuildCall env (addValArgTo info' arg fun_ty) cont
-- Strict arguments
| str
@@ -2009,7 +2006,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = info', sc_cci = cci_strict
, sc_dup = Simplified, sc_fun_ty = fun_ty
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Note [Shadowing]
-- Lazy arguments
@@ -2020,7 +2017,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
(mkLazyArgStop arg_ty cci_lazy)
- ; rebuildCall env (addValArgTo info' (m, arg') fun_ty) cont }
+ ; rebuildCall env (addValArgTo info' arg' fun_ty) cont }
where
info' = info { ai_strs = strs, ai_discs = discs }
arg_ty = funArgTy fun_ty
@@ -2243,8 +2240,7 @@ trySeqRules in_env scrut rhs cont
, TyArg { as_arg_ty = rhs_ty
, as_hole_ty = res2_ty }
, ValArg { as_arg = no_cast_scrut
- , as_hole_ty = res3_ty
- , as_mult = Many } ]
+ , as_hole_ty = res3_ty } ]
-- The multiplicity of the scrutiny above is Many because the type
-- of seq requires that its first argument is unrestricted. The
-- typing rule of case also guarantees it though. In a more
@@ -2253,7 +2249,9 @@ trySeqRules in_env scrut rhs cont
-- the case (held in the case binder) instead.
rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
, sc_env = in_env, sc_cont = cont
- , sc_hole_ty = res4_ty, sc_mult = Many }
+ , sc_hole_ty = res4_ty }
+
+ -- TODO: what should this comment now say?
-- The multiplicity in sc_mult above is the
-- multiplicity of the second argument of seq. Since
-- seq's type, as it stands, imposes that its second
@@ -3318,7 +3316,7 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
, sc_cont = mkBoringStop res_ty } ) }
mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
- , sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m })
+ , sc_cont = cont, sc_fun_ty = fun_ty })
-- See Note [Duplicating StrictArg]
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
= do { (floats1, cont') <- mkDupableCont env cont
@@ -3329,7 +3327,6 @@ mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
, sc_cont = cont'
, sc_cci = cci
, sc_fun_ty = fun_ty
- , sc_mult = m
, sc_dup = OkToDup} ) }
mkDupableCont env (ApplyToTy { sc_cont = cont
@@ -3340,7 +3337,7 @@ mkDupableCont env (ApplyToTy { sc_cont = cont
mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
, sc_env = se, sc_cont = cont
- , sc_hole_ty = hole_ty, sc_mult = mult })
+ , sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
@@ -3359,7 +3356,7 @@ mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
-- has turned arg'' into a fresh variable
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup, sc_cont = cont'
- , sc_hole_ty = hole_ty, sc_mult = mult }) }
+ , sc_hole_ty = hole_ty }) }
mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
, sc_env = se, sc_cont = cont })
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -124,8 +124,7 @@ data SimplCont
-- See Note [The hole type in ApplyToTy/Val]
, sc_arg :: InExpr -- The argument,
, sc_env :: StaticEnv -- see Note [StaticEnv invariant]
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ]
{ sc_arg_ty :: OutType -- Argument type
@@ -158,8 +157,7 @@ data SimplCont
, sc_fun_ty :: OutType -- Type of the function (f e1 .. en),
-- presumably (arg_ty -> res_ty)
-- where res_ty is expected by sc_cont
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| TickIt -- (TickIt t K)[e] = K[ tick t e ]
(Tickish Id) -- Tick tickish <hole>
@@ -278,23 +276,22 @@ data ArgInfo
}
data ArgSpec
- = ValArg { as_mult :: Mult
- , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
+ = ValArg { as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
, as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)
| TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy
, as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah)
| CastBy OutCoercion -- Cast by this; c.f. CastIt
instance Outputable ArgSpec where
- ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg
+ ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
ppr (CastBy c) = text "CastBy" <+> ppr c
-addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo
-addValArgTo ai (w, arg) hole_ty = ai { ai_args = arg_spec : ai_args ai
- , ai_rules = decRules (ai_rules ai) }
+addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
+addValArgTo ai arg hole_ty = ai { ai_args = arg_spec : ai_args ai
+ , ai_rules = decRules (ai_rules ai) }
where
- arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+ arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty }
addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo
addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai
@@ -317,9 +314,9 @@ pushSimplifiedArgs env (arg : args) k
= case arg of
TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
-> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
- ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+ ValArg { as_arg = arg, as_hole_ty = hole_ty }
-> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
- , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w }
+ , sc_hole_ty = hole_ty, sc_cont = rest }
CastBy c -> CastIt c rest
where
rest = pushSimplifiedArgs env args k
@@ -418,7 +415,7 @@ contHoleType (TickIt _ k) = contHoleType k
contHoleType (CastIt co _) = coercionLKind co
contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
= perhapsSubstTy dup se (idType b)
-contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty
+contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty
contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]
contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val]
contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
@@ -436,12 +433,14 @@ contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
contHoleScaling :: SimplCont -> Mult
contHoleScaling (Stop _ _) = One
contHoleScaling (CastIt _ k) = contHoleScaling k
-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
-contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =
- w `mkMultMul` contHoleScaling k
-contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (Select { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })
+ = w `mkMultMul` contHoleScaling k
+ where
+ (w, _, _) = splitFunTy fun_ty
contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k
contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k
contHoleScaling (TickIt _ k) = contHoleScaling k
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e3a0d55c0eba5d53c89a0eb9f021b2f4e55384e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e3a0d55c0eba5d53c89a0eb9f021b2f4e55384e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200724/946b9c21/attachment-0001.html>
More information about the ghc-commits
mailing list