From f5835fb60062a793a6d85e7aa98938d2727c0829 Mon Sep 17 00:00:00 2001 From: Andreas Klebinger Date: Thu, 6 Feb 2020 15:11:21 +0100 Subject: Fix #17724 by having occAnal preserve used bindings. It sometimes happened that occAnal would remove bindings as dead code by relying on bindings to be in dependency order. The fix was contributed by SPJ. --- compiler/simplCore/OccurAnal.hs | 9 ++- .../tests/simplCore/should_compile/T17722A.hs | 20 ++++++ .../tests/simplCore/should_compile/T17722B.hs | 73 ++++++++++++++++++++++ testsuite/tests/simplCore/should_compile/T17724.hs | 26 ++++++++ testsuite/tests/simplCore/should_compile/all.T | 2 + 5 files changed, 128 insertions(+), 2 deletions(-) create mode 100644 testsuite/tests/simplCore/should_compile/T17722A.hs create mode 100644 testsuite/tests/simplCore/should_compile/T17722B.hs create mode 100644 testsuite/tests/simplCore/should_compile/T17724.hs diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 8b6bc2eed2..f56832cbd3 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -79,11 +79,16 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds (final_usage, occ_anald_binds) = go init_env binds (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel imp_rule_edges - (flattenBinds occ_anald_binds) + (flattenBinds binds) initial_uds -- It's crucial to re-analyse the glommed-together bindings -- so that we establish the right loop breakers. Otherwise - -- we can easily create an infinite loop (Trac #9583 is an example) + -- we can easily create an infinite loop (#9583 is an example) + -- + -- Also crucial to re-analyse the /original/ bindings + -- in case the first pass accidentally discarded as dead code + -- a binding that was actually needed (albeit before its + -- definition site). #17724 threw this up. initial_uds = addManyOccsSet emptyDetails (rulesFreeVars imp_rules) diff --git a/testsuite/tests/simplCore/should_compile/T17722A.hs b/testsuite/tests/simplCore/should_compile/T17722A.hs new file mode 100644 index 0000000000..2a37163afa --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17722A.hs @@ -0,0 +1,20 @@ +module T17722A (Validation(..)) where + +data Validation e a + = Failure e + | Success a + +instance Functor (Validation e) where + fmap _ (Failure e) = Failure e + fmap f (Success a) = Success (f a) + +(<.>) :: Semigroup e => Validation e (t -> a) -> Validation e t -> Validation e a +Failure e1 <.> b = Failure $ case b of + Failure e2 -> e1 <> e2 + Success _ -> e1 +Success _ <.> Failure e = Failure e +Success f <.> Success x = Success (f x) + +instance Semigroup e => Applicative (Validation e) where + pure = Success + (<*>) = (<.>) diff --git a/testsuite/tests/simplCore/should_compile/T17722B.hs b/testsuite/tests/simplCore/should_compile/T17722B.hs new file mode 100644 index 0000000000..ffcf5c9203 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17722B.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module T17722B (setHelper) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Void (Void) +import qualified Data.Foldable +import qualified Data.List +import qualified Data.Sequence +import qualified Data.Text + +import T17722A + +data Expr s a + = App (Expr s a) (Expr s a) + | List + | ListLit (Maybe (Expr s a)) (Seq (Expr s a)) + +data Src + +type Extractor s a = Validation (ExtractErrors s a) + +typeError :: Expr s a -> Expr s a -> Extractor s a b +typeError expected actual = + Failure . ExtractErrors . pure . TypeMismatch $ InvalidDecoder expected actual + +extractError :: Text -> Extractor s a b +extractError = Failure . ExtractErrors . pure . ExtractError + +newtype ExtractErrors s a = ExtractErrors (NonEmpty (ExtractError s a)) + deriving Semigroup + +data ExtractError s a = + TypeMismatch (InvalidDecoder s a) + | ExtractError Text + +data InvalidDecoder s a = InvalidDecoder (Expr s a) (Expr s a) + +data Decoder a = Decoder + (Expr Src Void -> Extractor Src Void a) + (Expr Src Void) + +setHelper :: (Eq a, Foldable t, Show a) + => (t a -> Int) + -> ([a] -> t a) + -> Decoder a + -> Decoder (t a) +setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut + where + extractOut (ListLit _ es) = case traverse extractIn es of + Success vSeq + | sameSize -> Success vSet + | otherwise -> extractError err + where + vList = Data.Foldable.toList vSeq + vSet = toSet vList + sameSize = size vSet == Data.Sequence.length vSeq + duplicates = vList Data.List.\\ Data.Foldable.toList vSet + err | length duplicates == 1 = + "One duplicate element in the list: " + <> (Data.Text.pack $ show $ head duplicates) + | otherwise = Data.Text.pack $ unwords + [ show $ length duplicates + , "duplicates were found in the list, including" + , show $ head duplicates + ] + Failure f -> Failure f + extractOut expr = typeError expectedOut expr + + expectedOut = App List expectedIn diff --git a/testsuite/tests/simplCore/should_compile/T17724.hs b/testsuite/tests/simplCore/should_compile/T17724.hs new file mode 100644 index 0000000000..a514a7f305 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17724.hs @@ -0,0 +1,26 @@ +-- The CSE pass implicitly requires bindings to be in argument order +-- or things can go wrong. This was the case in this example. +-- This code is extracted from containers' sequence-benchmarks and the gauge +-- package. +{-# language ExistentialQuantification #-} + +module T17724 where + +import Control.Exception (evaluate) + +data Benchmarkable = forall a . + Benchmarkable + { allocEnv :: Int -> IO a + , runRepeatedly :: a -> Int -> IO () + } + +a, b :: Benchmarkable +a = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500) +b = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100) + +nf :: (a -> b) -> a -> Benchmarkable +nf f0 x0 = Benchmarkable (const (return ())) (const (go f0 x0)) + where go f x n + | n <= 0 = return () + | otherwise = evaluate (f x) >> go f x (n-1) + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 0d4d363563..90d6f140a6 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -332,3 +332,5 @@ test('T16978A', normal, compile, ['-O']) test('T16979a', normal, compile, ['-O']) test('T16979b', normal, compile, ['-O']) test('T17429', normal, compile, ['-dcore-lint -O2']) +test('T17722', normal, multimod_compile, ['T17722B', '-dcore-lint -O2 -v0']) +test('T17724', normal, compile, ['-dcore-lint -O2']) -- cgit v1.2.1