[Git][ghc/ghc][wip/T13253] Further wibbles
Simon Peyton Jones
gitlab at gitlab.haskell.org
Fri Jul 24 13:56:06 UTC 2020
Simon Peyton Jones pushed to branch wip/T13253 at Glasgow Haskell Compiler / GHC
Commits:
1cfa23cd by Simon Peyton Jones at 2020-07-24T14:55:32+01:00
Further wibbles
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Types/Demand.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1011,12 +1011,16 @@ 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 fun_ty
+ , sc_hole_ty = substTy env (exprType fun)
, sc_dup = NoDup, sc_cont = cont, sc_mult = m }
simplExprF1 env expr@(Lam {}) cont
@@ -1975,9 +1979,9 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
---------- The runRW# rule. Do this after absorbing all arguments ------
-- 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 })
+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 })
- | fun `hasKey` runRWKey
+ | 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
@@ -1991,25 +1995,24 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args })
; body' <- simplExprC env' arg cont'
; let arg' = Lam s body'
rr' = getRuntimeRep ty'
- call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg']
+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
; return (emptyFloats env, call') }
-rebuildCall env info@(ArgInfo { ai_encl = encl_rules
- , ai_dmds = dmd:_, ai_discs = disc:_ })
+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 })
-- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
- = rebuildCall env (addValArgTo info (m, arg) fun_ty) cont
+ = rebuildCall env (addValArgTo fun_info (m, arg) fun_ty) cont
-- Strict arguments
- | isStrictDmd dmd || isUnliftedType arg_ty
+ | isStrictArgInfo fun_info
, sm_case_case (getMode env)
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setInScopeFromE` env) arg
- (StrictArg { sc_fun = info, sc_cci = cci_strict
- , sc_dup = Simplified, sc_fun_ty = fun_ty
+ (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
+ , sc_dup = Simplified
, sc_cont = cont, sc_mult = m })
-- Note [Shadowing]
@@ -2020,26 +2023,11 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
-- have to be very careful about bogus strictness through
-- 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 }
+ (mkLazyArgStop arg_ty (lazyArgContext fun_info))
+ ; rebuildCall env (addValArgTo fun_info (m, arg') fun_ty) cont }
where
arg_ty = funArgTy fun_ty
- -- Use this for lazy arguments
- cci_lazy | encl_rules = RuleArgCtxt
- | disc > 0 = DiscArgCtxt -- Be keener here
- | otherwise = BoringCtxt -- Nothing interesting
-
- -- ..and this for strict arguments
- cci_strict | encl_rules = RuleArgCtxt
- | disc > 0 = DiscArgCtxt
- | otherwise = RhsCtxt
- -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we
- -- want to be a bit more eager to inline g, because it may
- -- expose an eval (on x perhaps) that can be eliminated or
- -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
- -- It's worth an 18% improvement in allocation for this
- -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
---------- No further useful info, revert to generic rebuild ------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
@@ -3311,10 +3299,10 @@ mkDupableContWithDmds env _
; let join_body = wrapFloats floats1 join_inner
res_ty = contResultType cont
- ; mkDupableStrictBind env RhsCtxt bndr' join_body res_ty }
+ ; mkDupableStrictBind env bndr' join_body res_ty }
mkDupableContWithDmds env _
- (StrictArg { sc_fun = fun, sc_cci = cci, sc_cont = cont
+ (StrictArg { sc_fun = fun, sc_cont = cont
, sc_fun_ty = fun_ty, sc_mult = m })
-- See Note [Duplicating StrictArg]
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
@@ -3328,7 +3316,6 @@ mkDupableContWithDmds env _
; return ( foldl' addLetFloats floats1 floats_s
, StrictArg { sc_fun = fun { ai_args = args' }
, sc_cont = cont'
- , sc_cci = cci
, sc_fun_ty = fun_ty
, sc_mult = m
, sc_dup = OkToDup} ) }
@@ -3341,7 +3328,7 @@ mkDupableContWithDmds env _
; arg_bndr <- newId (fsLit "arg") m arg_ty -- ToDo: check this linearity argument
; let env' = env `addNewInScopeIds` [arg_bndr]
; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont
- ; mkDupableStrictBind env' cci arg_bndr (wrapFloats floats join_rhs) rhs_ty }
+ ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
ok_cont (StrictArg {}) = False
ok_cont (CastIt _ k) = ok_cont k
@@ -3425,9 +3412,9 @@ mkDupableContWithDmds env _
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_cont = mkBoringStop (contResultType cont) } ) }
-mkDupableStrictBind :: SimplEnv -> CallCtxt -> OutId -> OutExpr -> OutType
+mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
-> SimplM (SimplFloats, SimplCont)
-mkDupableStrictBind env cci arg_bndr join_rhs res_ty
+mkDupableStrictBind env arg_bndr join_rhs res_ty
| exprIsDupable (targetPlatform (seDynFlags env)) join_rhs
= return (emptyFloats env
, StrictBind { sc_bndr = arg_bndr, sc_bndrs = []
@@ -3451,7 +3438,7 @@ mkDupableStrictBind env cci arg_bndr join_rhs res_ty
, sc_fun_ty = idType join_bndr
, sc_cont = mkBoringStop res_ty
, sc_mult = Many -- ToDo: check this!
- , sc_cci = cci } ) }
+ } ) }
mkDupableAlt :: Platform -> OutId
-> JoinFloats -> OutAlt
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Core.Opt.Simplify.Utils (
ArgInfo(..), ArgSpec(..), mkArgInfo,
addValArgTo, addCastTo, addTyArgTo,
argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
+ isStrictArgInfo, lazyArgContext,
abstractFloats,
@@ -156,7 +157,6 @@ data SimplCont
-- plus demands and discount flags for *this* arg
-- and further args
-- So ai_dmds and ai_discs are never empty
- , sc_cci :: CallCtxt -- Whether *this* argument position is interesting
, sc_fun_ty :: OutType -- Type of the function (f e1 .. en),
-- presumably (arg_ty -> res_ty)
-- where res_ty is expected by sc_cont
@@ -325,6 +325,12 @@ addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai
addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }
+isStrictArgInfo :: ArgInfo -> Bool
+-- True if the function is strict in the next argument
+isStrictArgInfo (ArgInfo { ai_dmds = dmds })
+ | dmd:_ <- dmds = isStrictDmd dmd
+ | otherwise = False
+
argInfoAppArgs :: [ArgSpec] -> [OutExpr]
argInfoAppArgs [] = []
argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast
@@ -512,10 +518,11 @@ mkArgInfo env fun rules n_val_args call_cont
, ai_dmds = vanilla_dmds
, ai_discs = vanilla_discounts }
| otherwise
- = ArgInfo { ai_fun = fun, ai_args = []
+ = ArgInfo { ai_fun = fun
+ , ai_args = []
, ai_rules = fun_rules
, ai_encl = interestingArgContext rules call_cont
- , ai_dmds = arg_dmds
+ , ai_dmds = add_type_strictness (idType fun) arg_dmds
, ai_discs = arg_discounts }
where
fun_rules = mkFunRules rules
@@ -555,30 +562,32 @@ mkArgInfo env fun rules n_val_args call_cont
<+> ppr n_val_args <+> ppr demands )
vanilla_dmds -- Not enough args, or no strictness
-{-
- add_type_str :: Type -> [Bool] -> [Bool]
+ add_type_strictness :: Type -> [Demand] -> [Demand]
-- If the function arg types are strict, record that in the 'strictness bits'
-- No need to instantiate because unboxed types (which dominate the strict
-- types) can't instantiate type variables.
- -- add_type_str is done repeatedly (for each call);
+ -- add_type_strictness is done repeatedly (for each call);
-- might be better once-for-all in the function
-- But beware primops/datacons with no strictness
- add_type_str _ [] = []
- add_type_str fun_ty all_strs@(str:strs)
+ add_type_strictness fun_ty dmds
+ | null dmds = []
+
+ | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
+ = add_type_strictness fun_ty' dmds -- Look through foralls
+
| 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
+ , dmd : rest_dmds <- dmds
+ , let dmd' = case isLiftedType_maybe arg_ty of
+ Just False -> strictenDmd dmd
+ _ -> dmd
+ = dmd' : add_type_strictness fun_ty' rest_dmds
-- If the type is levity-polymorphic, we can't know whether it's
-- strict. isLiftedType_maybe will return Just False only when
-- we're sure the type is unlifted.
- | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
- = add_type_str fun_ty' all_strs -- Look through foralls
-
| otherwise
- = all_strs
--}
+ = dmds
{- Note [Unsaturated functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -667,6 +676,26 @@ This made a small compile-time perf improvement in perf/compiler/T6048,
and it looks plausible to me.
-}
+lazyArgContext :: ArgInfo -> CallCtxt
+-- Use this for lazy arguments
+lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })
+ | encl_rules = RuleArgCtxt
+ | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here
+ | otherwise = BoringCtxt -- Nothing interesting
+
+strictArgContext :: ArgInfo -> CallCtxt
+strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })
+-- Use this for strict arguments
+ | encl_rules = RuleArgCtxt
+ | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here
+ | otherwise = RhsCtxt
+ -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we
+ -- want to be a bit more eager to inline g, because it may
+ -- expose an eval (on x perhaps) that can be eliminated or
+ -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
+ -- It's worth an 18% improvement in allocation for this
+ -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
+
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
-- See Note [Interesting call context]
interestingCallContext env cont
@@ -683,7 +712,7 @@ interestingCallContext env cont
-- motivation to inline. See Note [Cast then apply]
-- in GHC.Core.Unfold
- interesting (StrictArg { sc_cci = cci }) = cci
+ interesting (StrictArg { sc_fun = fun }) = strictArgContext fun
interesting (StrictBind {}) = BoringCtxt
interesting (Stop _ cci) = cci
interesting (TickIt _ k) = interesting k
@@ -733,16 +762,13 @@ interestingArgContext rules call_cont
go (Select {}) = False
go (ApplyToVal {}) = False -- Shouldn't really happen
go (ApplyToTy {}) = False -- Ditto
- go (StrictArg { sc_cci = cci }) = interesting cci
+ go (StrictArg { sc_fun = fun }) = ai_encl fun
go (StrictBind {}) = False -- ??
go (CastIt _ c) = go c
- go (Stop _ cci) = interesting cci
+ go (Stop _ RuleArgCtxt) = True
+ go (Stop _ _) = False
go (TickIt _ c) = go c
- interesting RuleArgCtxt = True
- interesting _ = False
-
-
{- Note [Interesting arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An argument is interesting if it deserves a discount for unfoldings
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -1285,14 +1285,14 @@ splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty)
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException = lubDmdType exnDmdType
-strictenDmd :: Demand -> CleanDemand
+strictenDmd :: Demand -> Demand
strictenDmd (JD { sd = s, ud = u})
= JD { sd = poke_s s, ud = poke_u u }
where
- poke_s Lazy = HeadStr
- poke_s (Str s) = s
- poke_u Abs = UHead
- poke_u (Use _ u) = u
+ poke_s Lazy = Str HeadStr
+ poke_s s = s
+ poke_u Abs = useTop
+ poke_u u = u
-- Deferring and peeling
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cfa23cd991315275214e36d5819d8791b31e323
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1cfa23cd991315275214e36d5819d8791b31e323
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/b15dd019/attachment-0001.html>
More information about the ghc-commits
mailing list