[Git][ghc/ghc][wip/T23083] 5 commits: JS: fix implementation of forceBool to use JS backend syntax
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Mar 13 14:35:10 UTC 2023
Sebastian Graf pushed to branch wip/T23083 at Glasgow Haskell Compiler / GHC
Commits:
047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00
JS: fix implementation of forceBool to use JS backend syntax
- - - - -
559a4804 by Sebastian Graf at 2023-03-13T07:31:23-04:00
Simplifier: `countValArgs` should not count Type args (#23102)
I observed miscompilations while working on !10088 caused by this.
Fixes #23102.
Metric Decrease:
T10421
- - - - -
c63f7179 by Sebastian Graf at 2023-03-13T15:07:39+01:00
WorkWrap: Relax "splitFun" warning for join points (#23113)
- - - - -
4e4d74ce by Sebastian Graf at 2023-03-13T15:07:48+01:00
Simplify: Simplification of arguments in a single function
The Simplifier had a function `simplArg` that wasn't called in `rebuildCall`,
which seems to be the main way to simplify args. Hence I consolidated the code
path to call `simplArg`, too, renaming to `simplLazyArg`.
- - - - -
191b6fd8 by Sebastian Graf at 2023-03-13T15:34:59+01:00
CorePrep: Eta expand arguments (#23083)
Previously, we'd only eta expand let bindings and lambdas,
now we'll also eta expand arguments such as in T23083:
```hs
g f h = f (h `seq` (h $))
```
Unless `-fpedantic-bottoms` is set, we'll now transform to
```hs
g f h = f (\eta -> h eta)
```
in CorePrep.
See the new `Note [Eta expansion of arguments in CorePrep]` for the details.
Fixes #23083.
- - - - -
13 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Config/CoreToStg/Prep.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- + testsuite/tests/javascript/T23101.hs
- + testsuite/tests/javascript/T23101.stdout
- + testsuite/tests/javascript/all.T
- + testsuite/tests/simplCore/should_compile/T23083.hs
- + testsuite/tests/simplCore/should_compile/T23083.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -1517,7 +1517,7 @@ rebuild env expr cont
ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag
, sc_cont = cont, sc_hole_ty = fun_ty }
-- See Note [Avoid redundant simplification]
- -> do { (_, _, arg') <- simplArg env dup_flag fun_ty se arg
+ -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg
; rebuild env (App expr arg') cont }
completeBindX :: SimplEnv
@@ -1633,7 +1633,6 @@ simplCast env body co0 cont0
, sc_hole_ty = coercionLKind co }) }
-- NB! As the cast goes past, the
-- type of the hole changes (#16312)
-
-- (f |> co) e ===> (f (e |> co1)) |> co2
-- where co :: (s1->s2) ~ (t1->t2)
-- co1 :: t1 ~ s1
@@ -1652,7 +1651,7 @@ simplCast env body co0 cont0
-- See Note [Avoiding exponential behaviour]
MCo co1 ->
- do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg
+ do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg
-- When we build the ApplyTo we can't mix the OutCoercion
-- 'co' with the InExpr 'arg', so we simplify
-- to make it all consistent. It's a bit messy.
@@ -1678,16 +1677,18 @@ simplCast env body co0 cont0
-- See Note [Representation polymorphism invariants] in GHC.Core
-- test: typecheck/should_run/EtaExpandLevPoly
-simplArg :: SimplEnv -> DupFlag
- -> OutType -- Type of the function applied to this arg
- -> StaticEnv -> CoreExpr -- Expression with its static envt
- -> SimplM (DupFlag, StaticEnv, OutExpr)
-simplArg env dup_flag fun_ty arg_env arg
+simplLazyArg :: SimplEnv -> DupFlag
+ -> OutType -- Type of the function applied to this arg
+ -> Maybe ArgInfo
+ -> StaticEnv -> CoreExpr -- Expression with its static envt
+ -> SimplM (DupFlag, StaticEnv, OutExpr)
+simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg
| isSimplified dup_flag
= return (dup_flag, arg_env, arg)
| otherwise
= do { let arg_env' = arg_env `setInScopeFromE` env
- ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty))
+ ; let arg_ty = funArgTy fun_ty
+ ; arg' <- simplExprC arg_env' arg (mkLazyArgStop arg_ty mb_arg_info)
; return (Simplified, zapSubstEnv arg_env', arg') }
-- Return a StaticEnv that includes the in-scope set from 'env',
-- because arg' may well mention those variables (#20639)
@@ -2281,12 +2282,8 @@ rebuildCall env fun_info
-- There is no benefit (unlike in a let-binding), and we'd
-- have to be very careful about bogus strictness through
-- floating a demanded let.
- = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
- (mkLazyArgStop arg_ty fun_info)
+ = do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
- where
- arg_ty = funArgTy fun_ty
-
---------- No further useful info, revert to generic rebuild ------------
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
@@ -3723,7 +3720,7 @@ mkDupableContWithDmds env dmds
do { let (dmd:cont_dmds) = dmds -- Never fails
; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont
; let env' = env `setInScopeFromF` floats1
- ; (_, se', arg') <- simplArg env' dup hole_ty se arg
+ ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg
; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'
; let all_floats = floats1 `addLetFloats` let_floats2
; return ( all_floats
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -461,8 +461,9 @@ mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont
-- See Note [RHS of lets] in GHC.Core.Unfold
mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd)
-mkLazyArgStop :: OutType -> ArgInfo -> SimplCont
-mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd
+mkLazyArgStop :: OutType -> Maybe ArgInfo -> SimplCont
+mkLazyArgStop ty Nothing = mkBoringStop ty
+mkLazyArgStop ty (Just fun_info) = Stop ty (lazyArgContext fun_info) arg_sd
where
arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
@@ -553,7 +554,7 @@ countArgs _ = 0
countValArgs :: SimplCont -> Int
-- Count value arguments only
-countValArgs (ApplyToTy { sc_cont = cont }) = 1 + countValArgs cont
+countValArgs (ApplyToTy { sc_cont = cont }) = countValArgs cont
countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont
countValArgs (CastIt _ cont) = countValArgs cont
countValArgs _ = 0
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -758,9 +758,11 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]
splitFun ww_opts fn_id rhs
| Just (arg_vars, body) <- collectNValBinders_maybe (length wrap_dmds) rhs
- = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
+ = warnPprTrace (if isJoinId fn_id
+ then not (wrap_dmds `lengthAtMost` (arityInfo fn_info))
+ else not (wrap_dmds `lengthIs` (arityInfo fn_info)))
"splitFun"
- (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
+ (ppr fn_id <+> (ppr (arityInfo fn_info) $$ ppr wrap_dmds $$ ppr cpr)) $
do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr
; case mb_stuff of
Nothing -> -- No useful wrapper; leave the binding alone
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -406,7 +406,7 @@ coreToStgExpr expr@(App _ _)
-- rep might not be equal to rep2
-> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr))
- _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)
+ _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr app_head $$ ppr expr)
where
(app_head, args, ticks) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1491,12 +1491,26 @@ cpeArg env dmd arg
; if okCpeArg arg2
then do { v <- newVar arg_ty
- ; let arg3 = cpeEtaExpand (exprArity arg2) arg2
+ ; let ao = cp_arityOpts (cpe_config env)
+ -- See Note [Eta expansion of arguments in CorePrep]
+ ; let arg3 | Just at <- exprEtaExpandArity ao arg2
+ , not (is_join arg2)
+ -- See Note [Eta expansion for join points]
+ -- Eta expanding the join point would
+ -- introduce crap that we can't generate
+ -- code for
+ = cpeEtaExpand (arityTypeArity at) arg2
+ | otherwise
+ = arg2
arg_float = mkFloat env dmd is_unlifted v arg3
; return (addFloat floats2 arg_float, varToCoreExpr v) }
else return (floats2, arg2)
}
+is_join :: CoreExpr -> Bool
+is_join (Let bs _) = isJoinBind bs
+is_join _ = False
+
{-
Note [Floating unlifted arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1614,6 +1628,36 @@ and now we do NOT want eta expansion to give
Instead GHC.Core.Opt.Arity.etaExpand gives
f = /\a -> \y -> let s = h 3 in g s y
+Note [Eta expansion of arguments in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We eta expand arguments in here, in CorePrep, rather than in the Simplifier, and
+do so based on 'exprEtaExpandArity' rather than the cheaper 'exprArity' analysis
+we do on let RHSs and lambdas. The reason for the latter is that the Simplifier
+has already run the more costly analysis on lambdas and let RHSs and eta
+expanded accordingly, while it does not try to eta expand arguments at all.
+
+So why eta expand arguments in CorePrep rather than in the Simplifier?
+There are two reasons why eta expansion of arguments is useful
+
+ 1. In expressions like @f (h `seq` (g $))@ (from T23083) eta expanding the
+ argument to @f (\x -> h `seq` (g $ x))@ allows us to save allocation of a
+ closure and have a faster call sequence; a code-gen matter.
+
+ 2. The eta expansion to @f (\x -> h `seq` (g $ x))@ gives rise to another
+ opportunity: We could inline ($), saving call overhead and perhaps turning
+ an unknown call into a known call. In general, there could be further
+ simplification based on the structure of the concrete argument `x`.
+ Whether we should inline in the PAP `(g $)` (thus solving this problem
+ independently of (1)) is discussed in #22886.
+
+To profit from (1), it is enough to eta expand in CorePrep, while (2) shows
+that in some rare cases as above, eta expansion of arguments may enable
+further simplification. CorePrep would not allow to exploit (2), while eta
+expansion in the Simplifier would.
+
+Alas, trying to eta expand arguments in every round of the Simplifier is costly
+(!10088 measured a geom. mean of +2.0% regression in ghc/alloc perf, regressing
+as much as 27.2%), so we only exploit (1) for now.
-}
cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
@@ -1977,6 +2021,9 @@ data CorePrepConfig = CorePrepConfig
, cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr)
-- ^ Convert some numeric literals (Integer, Natural) into their final
-- Core form.
+
+ , cp_arityOpts :: !ArityOpts
+ -- ^ Configuration for arity analysis ('exprEtaExpandArity').
}
data CorePrepEnv
@@ -1987,6 +2034,7 @@ data CorePrepEnv
-- enabled we instead produce an 'error' expression to catch
-- the case where a function we think should bottom
-- unexpectedly returns.
+
, cpe_env :: IdEnv CoreExpr -- Clone local Ids
-- ^ This environment is used for three operations:
--
=====================================
compiler/GHC/Driver/Config/CoreToStg/Prep.hs
=====================================
@@ -9,6 +9,7 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Core.Lint
+import GHC.Driver.Config.Core.Opt.Arity
import GHC.Tc.Utils.Env
import GHC.Types.Var
import GHC.Utils.Outputable ( alwaysQualify )
@@ -17,14 +18,16 @@ import GHC.CoreToStg.Prep
initCorePrepConfig :: HscEnv -> IO CorePrepConfig
initCorePrepConfig hsc_env = do
+ let dflags = hsc_dflags hsc_env
convertNumLit <- do
- let platform = targetPlatform $ hsc_dflags hsc_env
+ let platform = targetPlatform dflags
home_unit = hsc_home_unit hsc_env
lookup_global = lookupGlobal hsc_env
mkConvertNumLiteral platform home_unit lookup_global
return $ CorePrepConfig
{ cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env
, cp_convertNumLit = convertNumLit
+ , cp_arityOpts = initArityOpts dflags
}
initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -639,7 +639,7 @@ jsResultWrapper result_ty
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do
-- result_id <- newSysLocalDs boolTy
ccall_uniq <- newUnique
- let forceBool e = mkJsCall ccall_uniq (fsLit "$r = !(!$1)") [e] boolTy
+ let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy
return
(Just intPrimTy, \e -> forceBool e)
=====================================
testsuite/tests/javascript/T23101.hs
=====================================
@@ -0,0 +1,22 @@
+
+foreign import javascript "(($1) => { return $1; })"
+ bool_id :: Bool -> Bool
+
+foreign import javascript "(($1) => { return !$1; })"
+ bool_not :: Bool -> Bool
+
+foreign import javascript "(($1) => { console.log($1); })"
+ bool_log :: Bool -> IO ()
+
+main :: IO ()
+main = do
+ bool_log True
+ bool_log False
+ bool_log (bool_id True)
+ bool_log (bool_id False)
+ bool_log (bool_not True)
+ bool_log (bool_not False)
+ print (bool_id True)
+ print (bool_id False)
+ print (bool_not True)
+ print (bool_not False)
=====================================
testsuite/tests/javascript/T23101.stdout
=====================================
@@ -0,0 +1,10 @@
+true
+false
+true
+false
+false
+true
+True
+False
+False
+True
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -0,0 +1,4 @@
+# These are JavaScript-specific tests
+setTestOpts(when(not(js_arch()),skip))
+
+test('T23101', normal, compile_and_run, [''])
=====================================
testsuite/tests/simplCore/should_compile/T23083.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T23083 where
+
+g :: ((Integer -> Integer) -> Integer) -> (Integer -> Integer) -> Integer
+g f h = f (h `seq` (h $))
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -0,0 +1,42 @@
+
+==================== CorePrep ====================
+Result size of CorePrep = {terms: 27, types: 24, coercions: 0, joins: 0/1}
+
+-- RHS size: {terms: 12, types: 13, coercions: 0, joins: 0/1}
+T23083.g :: ((GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) -> (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer
+[GblId, Arity=2, Str=<1C(1,L)><ML>, Unf=OtherCon []]
+T23083.g
+ = \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) ->
+ let {
+ sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer
+ [LclId]
+ sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> GHC.Base.$ @GHC.Types.LiftedRep @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in
+ f sat
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T23083.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule3 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T23083.$trModule3 = GHC.Types.TrNameS T23083.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T23083.$trModule2 = "T23083"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T23083.$trModule1 = GHC.Types.TrNameS T23083.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T23083.$trModule :: GHC.Types.Module
+[GblId, Unf=OtherCon []]
+T23083.$trModule = GHC.Types.Module T23083.$trModule3 T23083.$trModule1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -477,3 +477,4 @@ test('T23012', normal, compile, ['-O'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
test('T23026', normal, compile, ['-O'])
+test('T23083', [ grep_errmsg(r'eta.+::.+Integer') ], compile, ['-O -ddump-prep -dsuppress-uniques -dppr-cols=99999'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0492a3a73e990adb93cc93b19e4f964161a0528f...191b6fd8f03c2cf70823b97a39955f67a83e58e1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0492a3a73e990adb93cc93b19e4f964161a0528f...191b6fd8f03c2cf70823b97a39955f67a83e58e1
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/20230313/7db47005/attachment-0001.html>
More information about the ghc-commits
mailing list