diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2019-02-08 17:49:28 +0100 |
---|---|---|
committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2019-02-08 18:48:43 +0100 |
commit | 139d4cd1815a979fe7b86cc7dd25036cb6787b80 (patch) | |
tree | fa38ed0584bbf2d053d439839e140afcb33580d3 | |
parent | 2b90356d26b4699227816ad9424e766eccdb6c36 (diff) | |
download | haskell-139d4cd1815a979fe7b86cc7dd25036cb6787b80.tar.gz |
Disable binder swap in OccurAnal (Trac #16288)
-rw-r--r-- | compiler/coreSyn/CoreUnfold.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/dependent/should_compile/dynamic-paper.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T16288A.hs | 17 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T16288B.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T16288C.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
6 files changed, 45 insertions, 7 deletions
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 11c2a7533e..9b97e95098 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -47,7 +47,7 @@ import GhcPrelude import DynFlags import CoreSyn import PprCore () -- Instances -import OccurAnal ( occurAnalyseExpr ) +import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) import CoreOpt import CoreArity ( manifestArity ) import CoreUtils @@ -101,7 +101,7 @@ mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops = DFunUnfolding { df_bndrs = bndrs , df_con = con - , df_args = map occurAnalyseExpr ops } + , df_args = map occurAnalyseExpr_NoBinderSwap ops } -- see Trac #16288 -- See Note [Occurrence analysis of unfoldings] mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding @@ -311,7 +311,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr guidance - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, -- see Trac #16288 -- See Note [Occurrence analysis of unfoldings] uf_src = src, uf_is_top = top_lvl, @@ -330,7 +330,7 @@ mkUnfolding :: DynFlags -> UnfoldingSource -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it mkUnfolding dflags src is_top_lvl is_bottoming expr - = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, -- see Trac #16288 -- See Note [Occurrence analysis of unfoldings] uf_src = src, uf_is_top = is_top_lvl, @@ -342,7 +342,7 @@ mkUnfolding dflags src is_top_lvl is_bottoming expr where is_top_bottoming = is_top_lvl && is_bottoming guidance = calcUnfoldingGuidance dflags is_top_bottoming expr - -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] {- diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr index 3ba4db2219..a170d29c46 100644 --- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr +++ b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr @@ -1,5 +1,5 @@ Simplifier ticks exhausted - When trying UnfoldingDone delta1 + When trying UnfoldingDone delta To increase the limit, use -fsimpl-tick-factor=N (default 100). If you need to increase the limit substantially, please file a @@ -12,4 +12,4 @@ Simplifier ticks exhausted simplifier non-termination has been judged acceptable. To see detailed counts use -ddump-simpl-stats - Total ticks: 140004 + Total ticks: 140007 diff --git a/testsuite/tests/simplCore/should_compile/T16288A.hs b/testsuite/tests/simplCore/should_compile/T16288A.hs new file mode 100644 index 0000000000..c6a52bff33 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T16288A.hs @@ -0,0 +1,17 @@ +module T16288A where + +import T16288C + +data License + +class Pretty a where + pretty :: a -> Doc + +instance Pretty License where + pretty _ = pretV + +bar :: (Pretty a) => a -> Doc +bar w = foo (pretty (u w w w w)) + +u :: a -> a -> a -> a -> a +u = u diff --git a/testsuite/tests/simplCore/should_compile/T16288B.hs b/testsuite/tests/simplCore/should_compile/T16288B.hs new file mode 100644 index 0000000000..c1a98d2e3a --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T16288B.hs @@ -0,0 +1,7 @@ +module T16288B where + +import T16288A +import T16288C + +bar2 :: License -> Doc +bar2 = bar diff --git a/testsuite/tests/simplCore/should_compile/T16288C.hs b/testsuite/tests/simplCore/should_compile/T16288C.hs new file mode 100644 index 0000000000..5efbb2ee34 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T16288C.hs @@ -0,0 +1,13 @@ +module T16288C where + +data Doc = Empty | Beside Doc + +hcat :: Doc -> Doc +hcat Empty = Empty +hcat xs = hcat xs + +pretV = hcat Empty + +foo :: Doc -> Doc +foo Empty = hcat Empty +foo val = Beside val diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 06b5e48447..779b09175e 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -299,3 +299,4 @@ test('T15631', normal, makefile_test, ['T15631']) test('T15673', normal, compile, ['-O']) +test('T16288', normal, multimod_compile, ['T16288B', '-O -dcore-lint -v0']) |