Commit 517d03e4 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix an asymptotic bug in the occurrence analyser

Trac #12425 and #12234 showed up a major and long-standing
bug in the occurrence analyser, whereby it could generate
explonentially large program!

There's a lot of commentary on #12425; and it's all described
in Note [Loop breakers, node scoring, and stability]

I did quite a lot of refactoring to make the code comprehensibe
again (its structure had bit-rotted rather), so the patch
looks bigger than it really is.

Hurrah!

I did a nofib run to check that I hadn't inadertently ruined
anything:

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
          fluid          -0.3%     -1.5%      0.01      0.01     +0.0%
         parser          -0.9%     +0.6%      0.04      0.04     +0.0%
         prolog          -0.1%     +1.2%      0.00      0.00     +0.0%

--------------------------------------------------------------------------------
            Min          -0.9%     -1.5%     -8.6%     -8.7%     +0.0%
            Max          +0.1%     +1.2%     +7.7%     +7.8%     +2.4%
 Geometric Mean          -0.2%     -0.0%     -0.2%     -0.3%     +0.0%

I checked what happened in 'prolog'.  It seems that we have a
recursive data structure something like this

   f :: [blah]
   f x = build (\cn.  ...g...  )

   g :: [blah2]
   g y = ....(foldr k z (f y))....

If we inline 'f' into 'g' we get better fusion than the other
way round, but we don't have any way to spot that at the moment.
(I wonder if we could do worker/wrapper for functions returning
a 'build'?)  It was happening before by a fluke.

Anyway I decided to accept this; it's relatively rare I think.
parent 90c5af47
...@@ -57,7 +57,7 @@ module CoreSyn ( ...@@ -57,7 +57,7 @@ module CoreSyn (
maybeUnfoldingTemplate, otherCons, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, hasStableCoreUnfolding_maybe, isStableUnfolding,
isClosedUnfolding, hasSomeUnfolding, isClosedUnfolding, hasSomeUnfolding,
isBootUnfolding, isBootUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource, canUnfold, neverUnfoldGuidance, isStableSource,
...@@ -1256,18 +1256,6 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr ...@@ -1256,18 +1256,6 @@ expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
expandUnfolding_maybe _ = Nothing expandUnfolding_maybe _ = Nothing
hasStableCoreUnfolding_maybe :: Unfolding -> Maybe Bool
-- Just True <=> has stable inlining, very keen to inline (eg. INLINE pragma)
-- Just False <=> has stable inlining, open to inlining it (eg. INLINABLE pragma)
-- Nothing <=> not stable, or cannot inline it anyway
hasStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
| isStableSource src
= case guide of
UnfWhen {} -> Just True
UnfIfGoodArgs {} -> Just False
UnfNever -> Nothing
hasStableCoreUnfolding_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
isCompulsoryUnfolding _ = False isCompulsoryUnfolding _ = False
......
This diff is collapsed.
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{- # OPTIONS_GHC -O1 #-}
module T12234 () where
import Prelude (Eq)
data ExprF rT = ExprF rT rT deriving Eq
newtype Expr = Expr (Fix ExprF) deriving Eq
newtype Fix fT = In (fT (Fix fT))
deriving instance Eq (f (Fix f)) => Eq (Fix f)
{-# LANGUAGE KindSignatures #-}
module T12425 where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Lazy (StateT(..))
data Result a m b = RecurseOnly (Maybe (CondT a m b))
| KeepAndRecurse b (Maybe (CondT a m b))
instance Monad m => Functor (Result a m) where
fmap f (RecurseOnly l) = RecurseOnly (liftM (fmap f) l)
fmap f (KeepAndRecurse a l) = KeepAndRecurse (f a) (liftM (fmap f) l)
{-# INLINE fmap #-}
newtype CondT a m b = CondT (StateT a m (Result a m b))
instance Monad m => Functor (CondT a m) where
fmap f (CondT g) = CondT (liftM (fmap f) g)
{-# INLINE fmap #-}
instance Monad m => Applicative (CondT a m) where
pure = undefined
(<*>) = undefined
instance Monad m => Monad (CondT a m) where
return = undefined
(>>=) = undefined
-- liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
...@@ -872,3 +872,24 @@ test('T12227', ...@@ -872,3 +872,24 @@ test('T12227',
compile, compile,
# Use `-M1G` to prevent memory thrashing with ghc-8.0.1. # Use `-M1G` to prevent memory thrashing with ghc-8.0.1.
['-O2 -ddump-hi -ddump-to-file +RTS -M1G']) ['-O2 -ddump-hi -ddump-to-file +RTS -M1G'])
test('T12425',
[ only_ways(['optasm']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 125831400, 5),
# initial: 125831400
]),
],
compile,
[''])
test('T12234',
[ only_ways(['optasm']),
compiler_stats_num_field('bytes allocated',
[(wordsize(64), 72958288, 5),
# initial: 72958288
]),
],
compile,
[''])
...@@ -6,10 +6,10 @@ Rule fired: Class op fmap ...@@ -6,10 +6,10 @@ Rule fired: Class op fmap
Rule fired: Class op fmap Rule fired: Class op fmap
Rule fired: Class op fmap Rule fired: Class op fmap
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op <$ Rule fired: Class op fmap
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op fmap Rule fired: Class op <$
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op <$ Rule fired: Class op <$
...@@ -41,18 +41,18 @@ Rule fired: SPEC $c<*> @ 'Z ...@@ -41,18 +41,18 @@ Rule fired: SPEC $c<*> @ 'Z
Rule fired: SPEC $c*> @ 'Z Rule fired: SPEC $c*> @ 'Z
Rule fired: SPEC $c<* @ 'Z Rule fired: SPEC $c<* @ 'Z
Rule fired: SPEC $fApplicativeShape @ 'Z Rule fired: SPEC $fApplicativeShape @ 'Z
Rule fired: SPEC $fApplicativeShape @ 'Z
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op fmap Rule fired: Class op fmap
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op <$ Rule fired: Class op <$
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: SPEC $fApplicativeShape @ 'Z
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op fmap Rule fired: Class op <$
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative
Rule fired: Class op <$ Rule fired: Class op fmap
Rule fired: Class op <*> Rule fired: Class op <*>
Rule fired: SPEC $c*> @ 'Z Rule fired: SPEC $c*> @ 'Z
Rule fired: SPEC $c<* @ 'Z Rule fired: SPEC $c<* @ 'Z
......
...@@ -555,3 +555,4 @@ test('T12734', normal, compile, ['']) ...@@ -555,3 +555,4 @@ test('T12734', normal, compile, [''])
test('T12734a', normal, compile_fail, ['']) test('T12734a', normal, compile_fail, [''])
test('T12763', normal, compile, ['']) test('T12763', normal, compile, [''])
test('T12797', normal, compile, ['']) test('T12797', normal, compile, [''])
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