[Git][ghc/ghc][wip/simplifier-tweaks] 2 commits: Move T18730 to perf/compiler where it belongs
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Jul 8 10:56:44 UTC 2023
Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC
Commits:
d277c9f8 by Simon Peyton Jones at 2023-07-08T11:55:11+01:00
Move T18730 to perf/compiler where it belongs
- - - - -
a4a1b31a by Simon Peyton Jones at 2023-07-08T11:55:54+01:00
Try removing the too_many_occs idea
Maybe other things now cover this adequately; if not we should know
exactly why we need it.
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- testsuite/tests/perf/compiler/all.T
- − testsuite/tests/simplCore/should_compile/T18730.hs
- − testsuite/tests/simplCore/should_compile/T18730_A.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -263,9 +263,7 @@ tryUnfolding logger opts !case_depth !inline_depth id lone_variable arg_infos
small_enough = adjusted_size <= unfoldingUseThreshold opts
discount = computeDiscount arg_discounts res_discount arg_infos cont_info
- extra_doc = vcat [ text "case depth =" <+> int case_depth
- , text "inline depth =" <+> int inline_depth
- , text "depth based penalty =" <+> int depth_penalty
+ extra_doc = vcat [ text "depth based penalty =" <+> int depth_penalty
, text "discounted size =" <+> int adjusted_size ]
where
-- Unpack the UnfoldingCache lazily because it may not be needed, and all
@@ -282,6 +280,8 @@ tryUnfolding logger opts !case_depth !inline_depth id lone_variable arg_infos
, text "is exp:" <+> ppr is_exp
, text "is work-free:" <+> ppr is_wf
, text "guidance" <+> ppr guidance
+ , text "case depth =" <+> int case_depth
+ , text "inline depth =" <+> int inline_depth
, extra_doc
, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -3999,7 +3999,7 @@ if this applies recursive to the next `case` inwards, and so on, the net
effect is that we can get an exponential number of calls to $j1a and $j1b, and
an exponential number of inlinings (since each is done independently).
-This hit #15360 (not a complicated program) badly. Out brutal solution is this:
+This hit #15360 (not a complicated program!) badly. Our simple solution is this:
when a join point is born, we don't give it an unfolding. So we end up with
$j1a x = e1
$j1b y = e2
@@ -4007,9 +4007,9 @@ when a join point is born, we don't give it an unfolding. So we end up with
$j2b x = ...$j1a ... $j1b...
... and so on...
-Now we are into Note [Avoiding exponential inlining], which is still
-a challenge. But at least we have a chance. If we add inlinings at birth
-we never get that chance.
+Now we are into Note [Avoiding exponential inlining], which is still a
+challenge. But at least we have a chance. If we add inlinings at birth we
+never get that chance.
Note [Duplicating alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4396,19 +4396,21 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
= simplStableUnfolding env bind_cxt id rhs_ty arity unf
| isExitJoinId id
= return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify
- | isJoinId id
- , too_many_occs (idOccInfo id)
- = return noUnfolding
+-- | isJoinId id
+-- , too_many_occs (idOccInfo id)
+-- = return noUnfolding
| otherwise
= -- Otherwise, we end up retaining all the SimpleEnv
let !opts = seUnfoldingOpts env
in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs
+{-
where
-- ToDo: document this
too_many_occs (ManyOccs {}) = True
too_many_occs (OneOcc { occ_n_br = n }) = n > 10
too_many_occs IAmDead = False
too_many_occs (IAmALoopBreaker {}) = False
+-}
-------------------
mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -202,6 +202,14 @@ test('CoOpt_Singletons',
#########
+# Moved from simplCore/should_compile
+test('T18730', normal,
+ [ only_ways(['optasm']),
+ collect_compiler_stats('bytes allocated',1)
+ , extra_files(['T8730_aux.hs'])
+ ],
+ ['T18730_A', '-v0 -O'])
+
test ('LargeRecord',
[ only_ways(['normal']),
collect_compiler_stats('bytes allocated',1)
=====================================
testsuite/tests/simplCore/should_compile/T18730.hs deleted
=====================================
@@ -1,26 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -funfolding-case-scaling=5 #-}
-
-module T18730 where
-
-import T18730_A (Gen)
-
-genFields :: Gen [(String, Int)]
-genFields =
- mapM
- (\(f, g) -> (f,) <$> g)
- [ ("field", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- , ("field_10", genIntField)
- ]
-
-genIntField :: Gen Int
-genIntField = pure 0
=====================================
testsuite/tests/simplCore/should_compile/T18730_A.hs deleted
=====================================
@@ -1,50 +0,0 @@
-module T18730_A where
-
-import Control.Monad (ap)
-import Data.Word
-import Data.Bits
-
-newtype Gen a = MkGen
- { -- | Run the generator on a particular seed.
- -- If you just want to get a random value out, consider using 'generate'.
- unGen :: QCGen -> Int -> a
- }
-
-instance Functor Gen where
- fmap f (MkGen h) =
- MkGen (\r n -> f (h r n))
-
-instance Applicative Gen where
- pure x =
- MkGen (\_ _ -> x)
- (<*>) = ap
-
-instance Monad Gen where
- return = pure
-
- MkGen m >>= k =
- MkGen
- ( \r n ->
- case split r of
- (r1, r2) ->
- let MkGen m' = k (m r1 n)
- in m' r2 n
- )
-
- (>>) = (*>)
-
-data QCGen = QCGen !Word64 !Word64
-
-split :: QCGen -> (QCGen, QCGen)
-split (QCGen seed gamma) =
- (QCGen seed'' gamma, QCGen seed' (mixGamma seed''))
- where
- seed' = seed + gamma
- seed'' = seed' + gamma
-
--- This piece appears to be critical
-mixGamma :: Word64 -> Word64
-mixGamma z0 =
- if z0 >= 24
- then z0
- else z0 `xor` 0xaaaaaaaaaaaaaaaa
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -341,7 +341,6 @@ test('T18603', normal, compile, ['-dcore-lint -O'])
# T18649 should /not/ generate a specialisation rule
test('T18649', normal, compile, ['-O -ddump-rules -Wno-simplifiable-class-constraints'])
-test('T18730', normal, multimod_compile, ['T18730_A', '-dcore-lint -O'])
test('T18747A', normal, compile, [''])
test('T18747B', normal, compile, [''])
test('T18815', only_ways(['optasm']), makefile_test, ['T18815'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b3e1e33a38f0b88f701e5c7be5398acbe4b57a25...a4a1b31a7f7a6e39f211a43ff5f8298a27fcd895
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b3e1e33a38f0b88f701e5c7be5398acbe4b57a25...a4a1b31a7f7a6e39f211a43ff5f8298a27fcd895
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/20230708/14ac4d15/attachment-0001.html>
More information about the ghc-commits
mailing list