Fix quadratic behaviour in tidyOccName

In the test program from comment:3 of Trac #10370, it turned out
that 25% of all compile time was going in OccName.tidyOccName!

It was all becuase the algorithm for finding an unused OccName
had a quadratic case.

This patch fixes it.  THe effect is pretty big:

Before:
	total time  =       34.30 secs   (34295 ticks @ 1000 us, 1 processor)
	total alloc = 15,496,011,168 bytes  (excludes profiling overheads)

After
	total time  =       25.41 secs   (25415 ticks @ 1000 us, 1 processor)
	total alloc = 11,812,744,816 bytes  (excludes profiling overheads)

6 files changed, 100 insertions, 69 deletions

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index 989f81478e..3ea3aa4105 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -3,7 +3,7 @@
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 -}
 
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
 
 -- |
 -- #name_types#
@@ -798,6 +798,29 @@ type TidyOccEnv = UniqFM Int
 
 * When looking for a renaming for "foo2" we strip off the "2" and start
   with "foo".  Otherwise if we tidy twice we get silly names like foo23.
+
+  However, if it started with digits at the end, we always make a name
+  with digits at the end, rather than shortening "foo2" to just "foo",
+  even if "foo" is unused.  Reasons:
+     - Plain "foo" might be used later
+     - We use trailing digits to subtly indicate a unification variable
+       in typechecker error message; see TypeRep.tidyTyVarBndr
+
+We have to take care though! Consider a machine-generated module (Trac #10370)
+  module Foo where
+     a1 = e1
+     a2 = e2
+     ...
+     a2000 = e2000
+Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,
+we have to do a linear search to find a free one, "a20001".  That might just be
+acceptable once.  But if we now come across "a8" again, we don't want to repeat
+that search.
+
+So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for
+starting the search; and we make sure to update the starting point for "a"
+after we allocate a new one.
+
 -}
 
 type TidyOccEnv = UniqFM Int    -- The in-scope OccNames
@@ -814,24 +837,32 @@ initTidyOccEnv = foldl add emptyUFM
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
-        Just n  -> find n
-        Nothing -> (addToUFM env fs 1, occ)
+      Nothing -> (addToUFM env fs 1, occ)   -- Desired OccName is free
+      Just {} -> case lookupUFM env base1 of
+                   Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
+                   Just n  -> find 1 n
   where
     base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
-    base = dropWhileEndLE isDigit (unpackFS fs)
+    base  = dropWhileEndLE isDigit (unpackFS fs)
+    base1 = mkFastString (base ++ "1")
 
-    find n
+    find !k !n
       = case lookupUFM env new_fs of
-          Just n' -> find (n1 `max` n')
-                     -- The max ensures that n increases, avoiding loops
-          Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1,
-                      OccName occ_sp new_fs)
-                     -- We update only the beginning and end of the
-                     -- chain that find explores; it's a little harder to
-                     -- update the middle and there's no real need.
+          Just {} -> find (k+1 :: Int) (n+k)
+                       -- By using n+k, the n arguemt to find goes
+                       --    1, add 1, add 2, add 3, etc which
+                       -- moves at quadratic speed through a dense patch
+
+          Nothing -> (if k>5 then pprTrace "tidyOccName" (ppr k $$ ppr occ $$ ppr new_fs)
+                             else \x -> x)
+                     (new_env, OccName occ_sp new_fs)
        where
-         n1 = n+1
          new_fs = mkFastString (base ++ show n)
+         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
+                     -- Update:  base_fs, so that next time we'll start whwere we left off
+                     --          new_fs,  so that we know it is taken
+                     -- If they are the same (n==1), the former wins
+                     -- See Note [TidyOccEnv]
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index a5d55555bc..ed05e55a70 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -328,8 +328,6 @@ cloneMetaTyVar tv
         ; return (mkTcTyVar name' (tyVarKind tv) details') }
 
 mkTcTyVarName :: Unique -> FastString -> Name
--- Make sure that fresh TcTyVar names finish with a digit
--- leaving the un-cluttered names free for user names
 mkTcTyVarName uniq str = mkSysTvName uniq str
 
 -- Works for both type and kind variables
diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs
index 527bfda02e..b37ca62d59 100644
--- a/compiler/types/TypeRep.hs
+++ b/compiler/types/TypeRep.hs
@@ -868,6 +868,8 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar
     -- System Names are for unification variables;
     -- when we tidy them we give them a trailing "0" (or 1 etc)
     -- so that they don't take precedence for the un-modified name
+    -- Plus, indicating a unification variable in this way is a
+    -- helpful clue for users
     occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
          | otherwise         = occ
 
diff --git a/testsuite/tests/ghci.debugger/scripts/print027.stdout b/testsuite/tests/ghci.debugger/scripts/print027.stdout
index 5db21839ae..3117eace87 100644
--- a/testsuite/tests/ghci.debugger/scripts/print027.stdout
+++ b/testsuite/tests/ghci.debugger/scripts/print027.stdout
@@ -1,6 +1,6 @@
 + = (_t1::Num a => a -> a -> a)
 print = (_t2::Show a1 => a1 -> IO ())
 log = (_t3::Floating a2 => a2 -> a2)
-head = (_t4::[a3] -> a3)
-tail = (_t5::[a4] -> [a4])
-fst = (_t6::(a5, b) -> a5)
+head = (_t4::[a4] -> a4)
+tail = (_t5::[a7] -> [a7])
+fst = (_t6::(a11, b) -> a11)
diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr
index 84eba86ba8..311146dc16 100644
--- a/testsuite/tests/parser/should_fail/T7848.stderr
+++ b/testsuite/tests/parser/should_fail/T7848.stderr
@@ -1,43 +1,43 @@
-

-T7848.hs:6:57:

-    Occurs check: cannot construct the infinite type:

-      t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2

-    Relevant bindings include

-      y :: forall t3. t3 -> t -> t1 -> A -> A -> A -> A -> t2

-        (bound at T7848.hs:8:9)

-      (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9)

-      z :: t1 (bound at T7848.hs:6:12)

-      (&) :: t1 (bound at T7848.hs:6:8)

-      (+) :: t (bound at T7848.hs:6:3)

-      x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)

-    In the expression: y

-    In an equation for ‘x’:

-        x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)

-          = y

-          where

-              infixl 3 `y`

-              y _ = (&)

-              {-# INLINE (&) #-}

-              {-# SPECIALIZE (&) :: a #-}

-              (&) = x

-

-T7848.hs:10:9:

-    Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’

-                with actual type ‘a’

-      ‘a’ is a rigid type variable bound by

-          the type signature for: (&) :: a at T7848.hs:10:9

-    Relevant bindings include

-      z :: t1 (bound at T7848.hs:6:12)

-      (&) :: t1 (bound at T7848.hs:6:8)

-      (+) :: t (bound at T7848.hs:6:3)

-      x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)

-    In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-}

-    In an equation for ‘x’:

-        x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)

-          = y

-          where

-              infixl 3 `y`

-              y _ = (&)

-              {-# INLINE (&) #-}

-              {-# SPECIALIZE (&) :: a #-}

-              (&) = x

+
+T7848.hs:6:57: error:
+    Occurs check: cannot construct the infinite type:
+      t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2
+    Relevant bindings include
+      y :: forall t4. t4 -> t -> t1 -> A -> A -> A -> A -> t2
+        (bound at T7848.hs:8:9)
+      (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9)
+      z :: t1 (bound at T7848.hs:6:12)
+      (&) :: t1 (bound at T7848.hs:6:8)
+      (+) :: t (bound at T7848.hs:6:3)
+      x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)
+    In the expression: y
+    In an equation for ‘x’:
+        x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
+          = y
+          where
+              infixl 3 `y`
+              y _ = (&)
+              {-# INLINE (&) #-}
+              {-# SPECIALIZE (&) :: a #-}
+              (&) = x
+
+T7848.hs:10:9: error:
+    Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’
+                with actual type ‘a’
+      ‘a’ is a rigid type variable bound by
+          the type signature for: (&) :: a at T7848.hs:10:9
+    Relevant bindings include
+      z :: t1 (bound at T7848.hs:6:12)
+      (&) :: t1 (bound at T7848.hs:6:8)
+      (+) :: t (bound at T7848.hs:6:3)
+      x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)
+    In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-}
+    In an equation for ‘x’:
+        x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
+          = y
+          where
+              infixl 3 `y`
+              y _ = (&)
+              {-# INLINE (&) #-}
+              {-# SPECIALIZE (&) :: a #-}
+              (&) = x
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index dcd562444e..ec3c4b08fb 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -20,20 +20,20 @@ fun1 [InlPrag=NOINLINE] :: Foo -> ()
 [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
 fun1 = \ (x :: Foo) -> case x of _ [Occ=Dead] { __DEFAULT -> () }
 
-T7360.fun4 :: ()
+T7360.fun5 :: ()
 [GblId,
  Str=DmdType,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
          WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}]
-T7360.fun4 = fun1 T7360.Foo1
+T7360.fun5 = fun1 T7360.Foo1
 
-T7360.fun3 :: Int
+T7360.fun4 :: Int
 [GblId,
  Caf=NoCafRefs,
  Str=DmdType m,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
-T7360.fun3 = I# 0#
+T7360.fun4 = I# 0#
 
 fun2 :: forall a. [a] -> ((), Int)
 [GblId,
@@ -43,17 +43,17 @@ fun2 :: forall a. [a] -> ((), Int)
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
-                 (T7360.fun4,
+                 (T7360.fun5,
                   case x of wild {
-                    [] -> T7360.fun3;
+                    [] -> T7360.fun4;
                     : _ [Occ=Dead] _ [Occ=Dead] ->
                       case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 }
                   })}]
 fun2 =
   \ (@ a) (x :: [a]) ->
-    (T7360.fun4,
+    (T7360.fun5,
      case x of wild {
-       [] -> T7360.fun3;
+       [] -> T7360.fun4;
        : ds ds1 ->
          case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 }
      })