[commit: ghc] master: Improve wrapTicks performance with lots of redundant source notes (2912231)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/29122312cc7b8f9890eb53f92d76ecdd8ded24ee/ghc

>---------------------------------------------------------------

commit 29122312cc7b8f9890eb53f92d76ecdd8ded24ee
Author: Peter Wortmann <Peter.Wortmann at googlemail.com>
Date:   Sat Feb 4 15:14:31 2017 -0500

    Improve wrapTicks performance with lots of redundant source notes
    
    The old version had O(n^3) performance for n non-overlapping source
    notes and let floats each, which is exactly what happens with -g if we
    compile a list literal of length n.
    
    The idea here is simply to establish early which source notes will
    actually survive (e.g. use a left fold). The new code should be O(n) for
    list literals.
    
    Reviewers: austin, dfeuer, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D3037
    
    GHC Trac Issues: #11095


>---------------------------------------------------------------

29122312cc7b8f9890eb53f92d76ecdd8ded24ee
 compiler/coreSyn/CorePrep.hs | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 74de5af..ab64449 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -1565,11 +1565,20 @@ newVar ty
 
 -- | Like wrapFloats, but only wraps tick floats
 wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
-wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
-  where (floats1, expr') = foldrOL go (nilOL, expr) floats0
-        go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
-                                   (mapOL (wrap t) fs, mkTick t e)
-        go other         (fs, e) = (other `consOL` fs, e)
+wrapTicks (Floats flag floats0) expr =
+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0
+        -- Deeply nested constructors will produce long lists of
+        -- redundant source note floats here. We need to eliminate
+        -- those early, as relying on mkTick to spot it after the fact
+        -- can yield O(n^3) complexity [#11095]
+        go (floats, ticks) (FloatTick t)
+          = ASSERT(tickishPlace t == PlaceNonLam)
+            (floats, if any (flip tickishContains t) ticks
+                     then ticks else t:ticks)
+        go (floats, ticks) f
+          = (foldr wrap f (reverse ticks):floats, ticks)
+
         wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)
         wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
         wrap _ other              = pprPanic "wrapTicks: unexpected float!"