Improve wrapTicks performance with lots of redundant source notes
authorPeter Wortmann <Peter.Wortmann@googlemail.com>
Sat, 4 Feb 2017 20:14:31 +0000 (15:14 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sat, 4 Feb 2017 21:16:50 +0000 (16:16 -0500)
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

compiler/coreSyn/CorePrep.hs

index 74de5af..ab64449 100644 (file)
@@ -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!"