Fix a performance issue with -fprint-expanded-synonyms

The type synonym expander was doing redundant work by looking at same
types again and again. This patch fixes the loop code when both of the
types can be expanded, to do `O(min(n, m))` comparisons and `O(n + m)`
expansions, where `n` is expansions of the first type and `m` is
expansions of the second type.

Reported by sjcjoosten in T10547.

Test Plan:
Added a regression test that was taking several minutes to type check
before this patch.

Reviewers: bgamari, simonpj, austin, ezyang

Reviewed By: bgamari, simonpj, austin, ezyang

Subscribers: simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D2198

GHC Trac Issues: #10547

4 files changed, 226 insertions, 79 deletions

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 878a3ea821..cdd77f1112 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -55,7 +55,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import FV ( fvVarList, unionFV )
 
 import Control.Monad    ( when )
-import Data.List        ( partition, mapAccumL, nub, sortBy )
+import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
 import qualified Data.Set as Set
 
 #if __GLASGOW_HASKELL__ > 710
@@ -1731,108 +1731,146 @@ harder to understand. The whole point here is to make the difference in expected
 and found types clearer.
 
 `expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
-only as much as necessary. It should work like this:
+only as much as necessary. Given two types t1 and t2:
 
-Given two types t1 and t2:
-
-  * If they're already same, it shouldn't expand any type synonyms and
-    just return.
+  * If they're already same, it just returns the types.
 
   * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
-    type constructors), it should expand C1 and C2 if they're different type
-    synonyms. Then it should continue doing same thing on expanded types. If C1
-    and C2 are same, then we should apply same procedure to arguments of C1
-    and argument of C2 to make them as similar as possible.
+    type constructors), it expands C1 and C2 if they're different type synonyms.
+    Then it recursively does the same thing on expanded types. If C1 and C2 are
+    same, then it applies the same procedure to arguments of C1 and arguments of
+    C2 to make them as similar as possible.
 
     Most important thing here is to keep number of synonym expansions at
-    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is
-    `T (T5, T3, Bool)` where T5 = T4, T4 = T3, ..., T1 = X, we should return
-    `T (T3, T3, Int)` and `T (T3, T3, Bool)`.
-
-In the implementation, we just search in all possible solutions for a solution
-that does minimum amount of expansions. This leads to a complex algorithm: If
-we have two synonyms like X_m = X_{m-1} = .. X and Y_n = Y_{n-1} = .. Y, where
-X and Y are rigid types, we expand m * n times. But in practice it's not a
-problem because deeply nested synonyms with no intervening rigid type
-constructors are vanishingly rare.
-
+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
+    `T (T3, T3, Bool)`.
+
+  * Otherwise types don't have same shapes and so the difference is clearly
+    visible. It doesn't do any expansions and show these types.
+
+Note that we only expand top-layer type synonyms. Only when top-layer
+constructors are the same we start expanding inner type synonyms.
+
+Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
+respectively. If their type-synonym-expanded forms will meet at some point (i.e.
+will have same shapes according to `sameShapes` function), it's possible to find
+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
+comparisons. We first collect all the top-layer expansions of t1 and t2 in two
+lists, then drop the prefix of the longer list so that they have same lengths.
+Then we search through both lists in parallel, and return the first pair of
+types that have same shapes. Inner types of these two types with same shapes
+are then expanded using the same algorithm.
+
+In case they don't meet, we return the last pair of types in the lists, which
+has top-layer type synonyms completely expanded. (in this case the inner types
+are not expanded at all, as the current form already shows the type error)
 -}
 
--- | Expand type synonyms in given types only enough to make them as equal as
+-- | Expand type synonyms in given types only enough to make them as similar as
 -- possible. Returned types are the same in terms of used type synonyms.
 --
 -- To expand all synonyms, see 'Type.expandTypeSynonyms'.
+--
+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
+-- some examples of how this should work.
 expandSynonymsToMatch :: Type -> Type -> (Type, Type)
 expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
   where
-    (_, ty1_ret, ty2_ret) = go 0 ty1 ty2
+    (ty1_ret, ty2_ret) = go ty1 ty2
 
-    -- | Returns (number of synonym expansions done to make types similar,
-    --            type synonym expanded version of first type,
+    -- | Returns (type synonym expanded version of first type,
     --            type synonym expanded version of second type)
-    --
-    -- Int argument is number of synonym expansions done so far.
-    go :: Int -> Type -> Type -> (Int, Type, Type)
-    go exps t1 t2
+    go :: Type -> Type -> (Type, Type)
+    go t1 t2
       | t1 `pickyEqType` t2 =
         -- Types are same, nothing to do
-        (exps, t1, t2)
+        (t1, t2)
 
-    go exps t1@(TyConApp tc1 tys1) t2@(TyConApp tc2 tys2)
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       | tc1 == tc2 =
         -- Type constructors are same. They may be synonyms, but we don't
         -- expand further.
-        let (exps', tys1', tys2') = unzip3 $ zipWith (go 0) tys1 tys2
-         in (exps + sum exps', TyConApp tc1 tys1', TyConApp tc2 tys2')
-      | otherwise =
-        -- Try to expand type constructors
-        case (coreView t1, coreView t2) of
-          -- When only one of the constructors is a synonym, we just
-          -- expand it and continue search
-          (Just t1', Nothing) ->
-            go (exps + 1) t1' t2
-          (Nothing, Just t2') ->
-            go (exps + 1) t1 t2'
-          (Just t1', Just t2') ->
-            -- Both constructors are synonyms, but they may be synonyms of
-            -- each other. We just search for minimally expanded solution.
-            -- See Note [Expanding type synonyms to make types similar].
-            let sol1@(exp1, _, _) = go (exps + 1) t1' t2
-                sol2@(exp2, _, _) = go (exps + 1) t1 t2'
-             in if exp1 < exp2 then sol1 else sol2
-          (Nothing, Nothing) ->
-            -- None of the constructors are synonyms, nothing to do
-            (exps, t1, t2)
-
-    go exps t1@TyConApp{} t2
-      | Just t1' <- coreView t1 = go (exps + 1) t1' t2
-      | otherwise               = (exps, t1, t2)
-
-    go exps t1 t2@TyConApp{}
-      | Just t2' <- coreView t2 = go (exps + 1) t1 t2'
-      | otherwise               = (exps, t1, t2)
-
-    go exps (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
-      let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
-          (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
-       in (exps + exps1 + exps2, mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
-
-    go exps (ForAllTy (Anon t1_1) t1_2) (ForAllTy (Anon t2_1) t2_2) =
-      let (exps1, t1_1', t2_1') = go 0 t1_1 t2_1
-          (exps2, t1_2', t2_2') = go 0 t1_2 t2_2
-       in (exps + exps1 + exps2, mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
-
-    go exps (ForAllTy (Named tv1 vis1) t1) (ForAllTy (Named tv2 vis2) t2) =
+        let (tys1', tys2') =
+              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')
+
+    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
+
+    go (ForAllTy (Anon t1_1) t1_2) (ForAllTy (Anon t2_1) t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
+
+    go (ForAllTy (Named tv1 vis1) t1) (ForAllTy (Named tv2 vis2) t2) =
       -- NOTE: We may have a bug here, but we just can't reproduce it easily.
       -- See D1016 comments for details and our attempts at producing a test
       -- case. Short version: We probably need RnEnv2 to really get this right.
-      let (exps1, t1', t2') = go exps t1 t2
-       in (exps1, ForAllTy (Named tv1 vis1) t1', ForAllTy (Named tv2 vis2) t2')
-
-    go exps (CastTy ty1 _) ty2 = go exps ty1 ty2
-    go exps ty1 (CastTy ty2 _) = go exps ty1 ty2
-
-    go exps t1 t2 = (exps, t1, t2)
+      let (t1', t2') = go t1 t2
+       in (ForAllTy (Named tv1 vis1) t1', ForAllTy (Named tv2 vis2) t2')
+
+    go (CastTy ty1 _) ty2 = go ty1 ty2
+    go ty1 (CastTy ty2 _) = go ty1 ty2
+
+    go t1 t2 =
+      -- See Note [Expanding type synonyms to make types similar] for how this
+      -- works
+      let
+        t1_exp_tys = t1 : tyExpansions t1
+        t2_exp_tys = t2 : tyExpansions t2
+        t1_exps    = length t1_exp_tys
+        t2_exps    = length t2_exp_tys
+        dif        = abs (t1_exps - t2_exps)
+      in
+        followExpansions $
+          zipEqual "expandSynonymsToMatch.go"
+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)
+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)
+
+    -- | Expand the top layer type synonyms repeatedly, collect expansions in a
+    -- list. The list does not include the original type.
+    --
+    -- Example, if you have:
+    --
+    --   type T10 = T9
+    --   type T9  = T8
+    --   ...
+    --   type T0  = Int
+    --
+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
+    --
+    -- This only expands the top layer, so if you have:
+    --
+    --   type M a = Maybe a
+    --
+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
+    tyExpansions :: Type -> [Type]
+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t)
+
+    -- | Drop the type pairs until types in a pair look alike (i.e. the outer
+    -- constructors are the same).
+    followExpansions :: [(Type, Type)] -> (Type, Type)
+    followExpansions [] = pprPanic "followExpansions" empty
+    followExpansions [(t1, t2)]
+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees
+      | otherwise        = (t1, t2) -- the difference is already visible
+    followExpansions ((t1, t2) : tss)
+      -- Traverse subtrees when the outer shapes are the same
+      | sameShapes t1 t2 = go t1 t2
+      -- Otherwise follow the expansions until they look alike
+      | otherwise = followExpansions tss
+
+    sameShapes :: Type -> Type -> Bool
+    sameShapes AppTy{}              AppTy{}              = True
+    sameShapes (TyConApp tc1 _)     (TyConApp tc2 _)     = tc1 == tc2
+    sameShapes (ForAllTy Anon{} _)  (ForAllTy Anon{} _)  = True
+    sameShapes (ForAllTy Named{} _) (ForAllTy Named{} _) = True
+    sameShapes (CastTy ty1 _)       ty2                  = sameShapes ty1 ty2
+    sameShapes ty1                  (CastTy ty2 _)       = sameShapes ty1 ty2
+    sameShapes _                    _                    = False
 
 sameOccExtra :: TcType -> TcType -> SDoc
 -- See Note [Disambiguating (X ~ X) errors]
diff --git a/testsuite/tests/perf/compiler/T10547.hs b/testsuite/tests/perf/compiler/T10547.hs
new file mode 100644
index 0000000000..5501b3df8e
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T10547.hs
@@ -0,0 +1,90 @@
+-- Reported by sjcjoosten in T10547, this was taking forever becuase of a bug in
+-- the implementation. See bottom of the file for some notes.
+
+module Test where
+
+type T12 = T11
+type T11 = T10
+type T10 = T9
+type T9  = T8
+type T8  = T7
+type T7  = T6
+type T6  = T5
+type T5  = T4
+type T4  = T3
+type T3  = T2
+type T2  = T1
+type T1  = T0
+type T0  = Int
+
+type S12 = S11
+type S11 = S10
+type S10 = S9
+type S9  = S8
+type S8  = S7
+type S7  = S6
+type S6  = S5
+type S5  = S4
+type S4  = S3
+type S3  = S2
+type S2  = S1
+type S1  = S0
+type S0  = Int
+
+test :: (T12, Char) -> (S12, Bool) -> Int
+test a b = const 1 (f a b)
+
+f :: (a, b) -> (a, b) -> (a, b)
+f a _ = a
+
+-- 5416fad, before the fix:
+--
+--    16,990,408,080 bytes allocated in the heap
+--        49,762,144 bytes copied during GC
+--         4,295,384 bytes maximum residency (5 sample(s))
+--           186,272 bytes maximum slop
+--                12 MB total memory in use (0 MB lost due to fragmentation)
+--
+--                                       Tot time (elapsed)  Avg pause  Max pause
+--    Gen  0     26929 colls,     0 par    0.779s   0.779s     0.0000s    0.0009s
+--    Gen  1         5 colls,     0 par    0.040s   0.040s     0.0080s    0.0099s
+--
+--    TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
+--
+--    SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
+--
+--    INIT    time    0.001s  (  0.001s elapsed)
+--    MUT     time    3.409s  (  3.409s elapsed)
+--    GC      time    0.819s  (  0.819s elapsed)
+--    EXIT    time    0.008s  (  0.012s elapsed)
+--    Total   time    4.256s  (  4.240s elapsed)
+--
+--    Alloc rate    4,984,597,832 bytes per MUT second
+--
+--    Productivity  80.7% of total user, 81.1% of total elapsed
+--
+-- After the fix:
+--
+--        39,165,544 bytes allocated in the heap
+--        19,516,400 bytes copied during GC
+--         4,460,568 bytes maximum residency (5 sample(s))
+--           244,640 bytes maximum slop
+--                11 MB total memory in use (0 MB lost due to fragmentation)
+--
+--                                       Tot time (elapsed)  Avg pause  Max pause
+--    Gen  0        44 colls,     0 par    0.009s   0.009s     0.0002s    0.0007s
+--    Gen  1         5 colls,     0 par    0.040s   0.040s     0.0080s    0.0099s
+--
+--    TASKS: 4 (1 bound, 3 peak workers (3 total), using -N1)
+--
+--    SPARKS: 0 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)
+--
+--    INIT    time    0.001s  (  0.001s elapsed)
+--    MUT     time    0.009s  (  0.009s elapsed)
+--    GC      time    0.049s  (  0.049s elapsed)
+--    EXIT    time    0.008s  (  0.012s elapsed)
+--    Total   time    0.096s  (  0.070s elapsed)
+--
+--    Alloc rate    4,570,081,011 bytes per MUT second
+--
+--    Productivity  48.2% of total user, 65.9% of total elapsed
diff --git a/testsuite/tests/perf/compiler/T10547.stderr b/testsuite/tests/perf/compiler/T10547.stderr
new file mode 100644
index 0000000000..f0935d55f0
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T10547.stderr
@@ -0,0 +1,11 @@
+
+T10547.hs:35:25:
+     Couldn't match type ‘Bool’ with ‘Char’
+      Expected type: (T12, Char)
+        Actual type: (S12, Bool)
+      Type synonyms expanded:
+      Expected type: (Int, Char)
+        Actual type: (Int, Bool)
+     In the second argument of ‘f’, namely ‘b’
+      In the second argument of ‘const’, namely ‘(f a b)’
+      In the expression: const 1 (f a b)
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index e3c4b31476..a39e6fa2c8 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -809,3 +809,11 @@ test('T10370',
      ],
      compile,
      [''])
+
+test('T10547',
+     [ compiler_stats_num_field('bytes allocated',
+          [(wordsize(64), 39165544, 20),
+          ]),
+     ],
+     compile_fail,
+     ['-fprint-expanded-synonyms'])