[commit: ghc] ghc-8.0: Fix binary-trees regression from unnecessary floating in CorePrep. (47d589e)
git at git.haskell.org
git at git.haskell.org
Mon Sep 5 20:31:00 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/47d589ef52ded1ab3f81994f6567dac666e08587/ghc
>---------------------------------------------------------------
commit 47d589ef52ded1ab3f81994f6567dac666e08587
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date: Tue Aug 30 16:55:58 2016 -0400
Fix binary-trees regression from unnecessary floating in CorePrep.
In the previous patch, I handled lazy @(Int -> Int) f x
correctly, but failed to handle lazy @Int (f x) (we need
to collect arguments in f x).
Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
Test Plan: validate
Reviewers: simonpj, austin, bgamari, nomeata
Reviewed By: nomeata
Subscribers: simonmar, thomie
Differential Revision: https://phabricator.haskell.org/D2471
(cherry picked from commit 83b326cda759cfd4c538595cf38ee23eb81a4c76)
>---------------------------------------------------------------
47d589ef52ded1ab3f81994f6567dac666e08587
compiler/coreSyn/CorePrep.hs | 44 ++++++++++++++++------
testsuite/tests/simplCore/should_compile/all.T | 1 +
testsuite/tests/simplCore/should_compile/par01.hs | 10 +++++
.../tests/simplCore/should_compile/par01.stderr | 33 ++++++++++++++++
4 files changed, 76 insertions(+), 12 deletions(-)
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index e2f2812..a3c70fd 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -671,13 +671,8 @@ cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs because of saturating primops
cpeApp top_env expr
= do { let (terminal, args, depth) = collect_args expr
- ; (head, app, floats) <- cpe_app top_env terminal args depth
-
- -- Now deal with the function
- ; case head of
- Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
- ; return (floats, sat_app) }
- _other -> return (floats, app) }
+ ; cpe_app top_env terminal args depth
+ }
where
-- We have a nested data structure of the form
@@ -705,10 +700,24 @@ cpeApp top_env expr
-> CoreExpr
-> [CpeArg]
-> Int
- -> UniqSM (Maybe Id, CpeApp, Floats)
+ -> UniqSM (Floats, CpeRhs)
cpe_app env (Var f) (CpeArg Type{} : CpeArg arg : args) depth
| f `hasKey` lazyIdKey -- Replace (lazy a) with a, and
- = cpe_app env arg args (depth - 1)
+ -- Consider the code:
+ --
+ -- lazy (f x) y
+ --
+ -- We need to make sure that we need to recursively collect arguments on
+ -- "f x", otherwise we'll float "f x" out (it's not a variable) and
+ -- end up with this awful -ddump-prep:
+ --
+ -- case f x of f_x {
+ -- __DEFAULT -> f_x y
+ -- }
+ --
+ -- rather than the far superior "f x y". Test case is par01.
+ = let (terminal, args', depth') = collect_args arg
+ in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
cpe_app env (Var f) [CpeArg _runtimeRep at Type{}, CpeArg _type at Type{}, CpeArg arg] 1
| f `hasKey` runRWKey
-- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
@@ -726,7 +735,7 @@ cpeApp top_env expr
-- cpe_ExprIsTrivial). But note that we need the type of the
-- expression, not the id.
; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
- ; return (hd, app, floats) }
+ ; mb_saturate hd app floats depth }
where
stricts = case idStrictness v of
StrictSig (DmdType _ demands _)
@@ -739,16 +748,27 @@ cpeApp top_env expr
-- Here, we can't evaluate the arg strictly, because this
-- partial application might be seq'd
+ -- We inlined into something that's not a var and has no args.
+ -- Bounce it back up to cpeRhsE.
+ cpe_app env fun [] _ = cpeRhsE env fun
+
-- N-variable fun, better let-bind it
- cpe_app env fun args _
+ cpe_app env fun args depth
= do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
-- The evalDmd says that it's sure to be evaluated,
-- so we'll end up case-binding it
; (app, floats) <- rebuild_app args fun' ty fun_floats []
- ; return (Nothing, app, floats) }
+ ; mb_saturate Nothing app floats depth }
where
ty = exprType fun
+ -- Saturate if necessary
+ mb_saturate head app floats depth =
+ case head of
+ Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
+ ; return (floats, sat_app) }
+ _other -> return (floats, app)
+
-- Deconstruct and rebuild the application, floating any non-atomic
-- arguments to the outside. We collect the type of the expression,
-- the head of the application, and the number of actual value arguments,
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 8708548..c276834 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -236,3 +236,4 @@ test('T12212', normal, compile, ['-O'])
test('T12076', extra_clean(['T12076a.hi', 'T12076a.o']), multimod_compile, ['T12076', '-v0'])
test('T12076lit', normal, compile, ['-O'])
test('T12076sat', normal, compile, ['-O'])
+test('par01', only_ways(['optasm']), compile, ['-ddump-prep -dsuppress-uniques -O2'])
diff --git a/testsuite/tests/simplCore/should_compile/par01.hs b/testsuite/tests/simplCore/should_compile/par01.hs
new file mode 100644
index 0000000..e67fb13
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/par01.hs
@@ -0,0 +1,10 @@
+module Par01 where
+
+import GHC.Conc
+
+-- The smoking gun in -ddump-prep is:
+-- case Par01.depth d of sat { __DEFAULT -> sat }
+-- this should never happen!
+
+depth :: Int -> Int
+depth d = d `par` depth d
diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr
new file mode 100644
index 0000000..8ec409d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/par01.stderr
@@ -0,0 +1,33 @@
+
+==================== CorePrep ====================
+Result size of CorePrep = {terms: 18, types: 8, coercions: 0}
+
+Rec {
+-- RHS size: {terms: 7, types: 3, coercions: 0}
+Par01.depth [Occ=LoopBreaker] :: GHC.Types.Int -> GHC.Types.Int
+[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>, Unf=OtherCon []]
+Par01.depth =
+ \ (d :: GHC.Types.Int) ->
+ case GHC.Prim.par# @ GHC.Types.Int d of _ [Occ=Dead] { __DEFAULT ->
+ Par01.depth d
+ }
+end Rec }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+Par01.$trModule2 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs, Str=DmdType m1, Unf=OtherCon []]
+Par01.$trModule2 = GHC.Types.TrNameS "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+Par01.$trModule1 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs, Str=DmdType m1, Unf=OtherCon []]
+Par01.$trModule1 = GHC.Types.TrNameS "Par01"#
+
+-- RHS size: {terms: 3, types: 0, coercions: 0}
+Par01.$trModule :: GHC.Types.Module
+[GblId, Caf=NoCafRefs, Str=DmdType m, Unf=OtherCon []]
+Par01.$trModule =
+ GHC.Types.Module Par01.$trModule2 Par01.$trModule1
+
+
+
More information about the ghc-commits
mailing list