[Git][ghc/ghc][master] Kill off sc_mult and as_mult fields
Marge Bot
gitlab at gitlab.haskell.org
Wed Jul 29 19:07:54 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bbc51916 by Simon Peyton Jones at 2020-07-29T15:07:47-04: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
=====================================
@@ -1004,7 +1004,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
@@ -1012,17 +1012,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.
- --
- -- But the (exprType fun) is repeated, to push it into two
- -- separate, rarely used, thunks; rather than always alloating
- -- a shared thunk. Makes a small efficiency difference
- 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" #-}
@@ -1327,8 +1320,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
@@ -1420,7 +1413,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
@@ -1444,8 +1437,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
@@ -1981,17 +1973,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_id, 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_id `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'
@@ -2002,10 +1995,10 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
rebuildCall env fun_info
(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 fun_info (m, arg) fun_ty) cont
+ = rebuildCall env (addValArgTo fun_info arg fun_ty) cont
-- Strict arguments
| isStrictArgInfo fun_info
@@ -2014,7 +2007,7 @@ rebuildCall env fun_info
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
, sc_dup = Simplified
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Note [Shadowing]
-- Lazy arguments
@@ -2025,7 +2018,7 @@ rebuildCall env fun_info
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
(mkLazyArgStop arg_ty (lazyArgContext fun_info))
- ; rebuildCall env (addValArgTo fun_info (m, arg') fun_ty) cont }
+ ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
where
arg_ty = funArgTy fun_ty
@@ -2233,24 +2226,10 @@ trySeqRules in_env scrut rhs cont
, as_hole_ty = res2_ty }
, ValArg { as_arg = no_cast_scrut
, as_dmd = seqDmd
- , as_hole_ty = res3_ty
- , as_mult = Many } ]
- -- 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
- -- general world, where the first argument of seq would have
- -- affine multiplicity, then we could use the multiplicity of
- -- the case (held in the case binder) instead.
+ , as_hole_ty = res3_ty } ]
rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
, sc_env = in_env, sc_cont = cont
- , sc_hole_ty = res4_ty, sc_mult = Many }
- -- 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
- -- argument be unrestricted, so is
- -- sc_mult. However, a more precise typing rule,
- -- for seq, would be to have it be linear. In which
- -- case, sc_mult should be 1.
+ , sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
@@ -3304,7 +3283,7 @@ mkDupableContWithDmds env _
mkDupableContWithDmds env _
(StrictArg { sc_fun = fun, sc_cont = cont
- , sc_fun_ty = fun_ty, sc_mult = m })
+ , sc_fun_ty = fun_ty })
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
| thumbsUpPlanA cont
= -- Use Plan A of Note [Duplicating StrictArg]
@@ -3318,18 +3297,17 @@ mkDupableContWithDmds env _
, StrictArg { sc_fun = fun { ai_args = args' }
, sc_cont = cont'
, sc_fun_ty = fun_ty
- , sc_mult = m
, sc_dup = OkToDup} ) }
| otherwise
= -- Use Plan B of Note [Duplicating StrictArg]
-- K[ f a b <> ] --> join j x = K[ f a b x ]
-- j <>
- do { let arg_ty = funArgTy fun_ty
- rhs_ty = contResultType cont
- ; arg_bndr <- newId (fsLit "arg") m arg_ty -- ToDo: check this linearity argument
+ do { let rhs_ty = contResultType cont
+ (m,arg_ty,_) = splitFunTy fun_ty
+ ; arg_bndr <- newId (fsLit "arg") m arg_ty
; let env' = env `addNewInScopeIds` [arg_bndr]
- ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont
+ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
thumbsUpPlanA (StrictArg {}) = False
@@ -3349,7 +3327,7 @@ mkDupableContWithDmds env dmds
mkDupableContWithDmds env dmds
(ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
- , sc_cont = cont, sc_hole_ty = hole_ty, sc_mult = mult })
+ , sc_cont = cont, sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
@@ -3369,7 +3347,7 @@ mkDupableContWithDmds env dmds
-- 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 }) }
mkDupableContWithDmds env _
(Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
@@ -3439,7 +3417,6 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
, sc_fun = arg_info
, sc_fun_ty = idType join_bndr
, sc_cont = mkBoringStop res_ty
- , sc_mult = Many -- ToDo: check this!
} ) }
mkDupableAlt :: Platform -> OutId
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -125,8 +125,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
@@ -160,8 +159,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>
@@ -282,8 +280,7 @@ data ArgInfo
}
data ArgSpec
- = ValArg { as_mult :: Mult
- , as_dmd :: Demand -- Demand placed on this argument
+ = ValArg { as_dmd :: Demand -- Demand placed on this argument
, as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
, as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)
@@ -300,16 +297,15 @@ instance Outputable ArgInfo where
, text "args =" <+> ppr args ])
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
+addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
+addValArgTo ai arg hole_ty
| ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai
-- Pop the top demand and and discounts off
- , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty
- , as_mult = w, as_dmd = dmd }
+ , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }
= ai { ai_args = arg_spec : ai_args ai
, ai_dmds = dmds
, ai_discs = discs
@@ -345,9 +341,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
@@ -446,7 +442,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 })
@@ -464,12 +460,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/bbc5191640761ca9773abc898c077363b7beb4e7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbc5191640761ca9773abc898c077363b7beb4e7
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/20200729/c7c59f0a/attachment-0001.html>
More information about the ghc-commits
mailing list