Commit 6de966f1 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

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.
parent 04eb0d6c
...@@ -81,11 +81,16 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds ...@@ -81,11 +81,16 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
(final_usage, occ_anald_binds) = go init_env binds (final_usage, occ_anald_binds) = go init_env binds
(_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
imp_rule_edges imp_rule_edges
(flattenBinds occ_anald_binds) (flattenBinds binds)
initial_uds initial_uds
-- It's crucial to re-analyse the glommed-together bindings -- It's crucial to re-analyse the glommed-together bindings
-- so that we establish the right loop breakers. Otherwise -- so that we establish the right loop breakers. Otherwise
-- we can easily create an infinite loop (#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 initial_uds = addManyOccsSet emptyDetails
(rulesFreeVars imp_rules) (rulesFreeVars imp_rules)
......
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
(<*>) = (<.>)
{-# 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
-- 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)
...@@ -312,3 +312,5 @@ test('T17409', ...@@ -312,3 +312,5 @@ test('T17409',
normal, normal,
makefile_test, ['T17409']) makefile_test, ['T17409'])
test('T17429', normal, compile, ['-dcore-lint -O2']) test('T17429', normal, compile, ['-dcore-lint -O2'])
test('T17722', normal, multimod_compile, ['T17722B', '-dcore-lint -O2 -v0'])
test('T17724', normal, compile, ['-dcore-lint -O2'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment