Simplify uniqAway

This does two things:

 * Eliminate all uses of Unique.deriveUnique, which was quite easy to
   mis-use and extremely subtle.

 * Rename the previous "derived unique" notion to "local unique". This
   is possible because the only places where `uniqAway` can be safely
   used are those where local uniqueness (with respect to some
   InScopeSet) is sufficient.

 * Rework the implementation of VarEnv.uniqAway, as discussed in #17462.
   This should make the operation significantly more efficient than its
   previous iterative implementation..

Metric Decrease:
    T9872c
    T12227
    T9233
    T14683
    T5030
    T12545
    hie002

Metric Increase:
    T9961

8 files changed, 84 insertions, 60 deletions

diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index 0031074a0b..cbae06d1ca 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -33,8 +33,8 @@ module Unique (
         getKey,                         -- Used in Var, UniqFM, Name only!
         mkUnique, unpkUnique,           -- Used in BinIface only
         eqUnique, ltUnique,
+        incrUnique,
 
-        deriveUnique,                   -- Ditto
         newTagUnique,                   -- Used in CgCase
         initTyVarUnique,
         initExitJoinUnique,
@@ -64,7 +64,12 @@ module Unique (
         -- *** From TyCon name uniques
         tyConRepNameUnique,
         -- *** From DataCon name uniques
-        dataConWorkerUnique, dataConTyRepNameUnique
+        dataConWorkerUnique, dataConTyRepNameUnique,
+
+        -- ** Local uniques
+        -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which
+        -- has rather peculiar needs. See Note [Local uniques].
+        mkLocalUnique, minLocalUnique, maxLocalUnique
     ) where
 
 #include "HsVersions.h"
@@ -119,7 +124,6 @@ getKey          :: Unique -> Int                -- for Var
 
 incrUnique   :: Unique -> Unique
 stepUnique   :: Unique -> Int -> Unique
-deriveUnique :: Unique -> Int -> Unique
 newTagUnique :: Unique -> Char -> Unique
 
 mkUniqueGrimily = MkUnique
@@ -130,10 +134,14 @@ getKey (MkUnique x) = x
 incrUnique (MkUnique i) = MkUnique (i + 1)
 stepUnique (MkUnique i) n = MkUnique (i + n)
 
--- deriveUnique uses an 'X' tag so that it won't clash with
--- any of the uniques produced any other way
--- SPJ says: this looks terribly smelly to me!
-deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
+mkLocalUnique :: Int -> Unique
+mkLocalUnique i = mkUnique 'X' i
+
+minLocalUnique :: Unique
+minLocalUnique = mkLocalUnique 0
+
+maxLocalUnique :: Unique
+maxLocalUnique = mkLocalUnique uniqueMask
 
 -- newTagUnique changes the "domain" of a unique to a different char
 newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
@@ -344,7 +352,7 @@ Allocation of unique supply characters:
         v,t,u : for renumbering value-, type- and usage- vars.
         B:   builtin
         C-E: pseudo uniques     (used in native-code generator)
-        X:   uniques derived by deriveUnique
+        X:   uniques from mkLocalUnique
         _:   unifiable tyvars   (above)
         0-9: prelude things below
              (no numbers left any more..)
@@ -443,3 +451,4 @@ mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)
 
 initExitJoinUnique :: Unique
 initExitJoinUnique = mkUnique 's' 0
+
diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs
index 0daaaea0d1..4c23b1f141 100644
--- a/compiler/basicTypes/VarEnv.hs
+++ b/compiler/basicTypes/VarEnv.hs
@@ -54,6 +54,7 @@ module VarEnv (
         getInScopeVars, lookupInScope, lookupInScope_Directly,
         unionInScope, elemInScopeSet, uniqAway,
         varSetInScope,
+        unsafeGetFreshLocalUnique,
 
         -- * The RnEnv2 type
         RnEnv2,
@@ -74,6 +75,7 @@ module VarEnv (
     ) where
 
 import GhcPrelude
+import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM
 
 import OccName
 import Var
@@ -97,7 +99,7 @@ import Outputable
 -- | A set of variables that are in scope at some point
 -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides
 -- the motivation for this abstraction.
-data InScopeSet = InScope VarSet {-# UNPACK #-} !Int
+newtype InScopeSet = InScope VarSet
         -- Note [Lookups in in-scope set]
         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         -- We store a VarSet here, but we use this for lookups rather than just
@@ -105,13 +107,9 @@ data InScopeSet = InScope VarSet {-# UNPACK #-} !Int
         -- version of the variable (e.g. with an informative unfolding), so this
         -- lookup is useful (see, for instance, Note [In-scope set as a
         -- substitution]).
-        --
-        -- The Int is a kind of hash-value used by uniqAway
-        -- For example, it might be the size of the set
-        -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
 
 instance Outputable InScopeSet where
-  ppr (InScope s _) =
+  ppr (InScope s) =
     text "InScope" <+>
     braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s)))
                       -- It's OK to use nonDetEltsUniqSet here because it's
@@ -120,76 +118,94 @@ instance Outputable InScopeSet where
                       -- the output is overwhelming
 
 emptyInScopeSet :: InScopeSet
-emptyInScopeSet = InScope emptyVarSet 1
+emptyInScopeSet = InScope emptyVarSet
 
 getInScopeVars ::  InScopeSet -> VarSet
-getInScopeVars (InScope vs _) = vs
+getInScopeVars (InScope vs) = vs
 
 mkInScopeSet :: VarSet -> InScopeSet
-mkInScopeSet in_scope = InScope in_scope 1
+mkInScopeSet in_scope = InScope in_scope
 
 extendInScopeSet :: InScopeSet -> Var -> InScopeSet
-extendInScopeSet (InScope in_scope n) v
-   = InScope (extendVarSet in_scope v) (n + 1)
+extendInScopeSet (InScope in_scope) v
+   = InScope (extendVarSet in_scope v)
 
 extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet
-extendInScopeSetList (InScope in_scope n) vs
-   = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs)
-                    (n + length vs)
+extendInScopeSetList (InScope in_scope) vs
+   = InScope $ foldl' extendVarSet in_scope vs
 
 extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet
-extendInScopeSetSet (InScope in_scope n) vs
-   = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs)
+extendInScopeSetSet (InScope in_scope) vs
+   = InScope (in_scope `unionVarSet` vs)
 
 delInScopeSet :: InScopeSet -> Var -> InScopeSet
-delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n
+delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v)
 
 elemInScopeSet :: Var -> InScopeSet -> Bool
-elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope
+elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope
 
 -- | Look up a variable the 'InScopeSet'.  This lets you map from
 -- the variable's identity (unique) to its full value.
 lookupInScope :: InScopeSet -> Var -> Maybe Var
-lookupInScope (InScope in_scope _) v  = lookupVarSet in_scope v
+lookupInScope (InScope in_scope) v  = lookupVarSet in_scope v
 
 lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
-lookupInScope_Directly (InScope in_scope _) uniq
+lookupInScope_Directly (InScope in_scope) uniq
   = lookupVarSet_Directly in_scope uniq
 
 unionInScope :: InScopeSet -> InScopeSet -> InScopeSet
-unionInScope (InScope s1 _) (InScope s2 n2)
-  = InScope (s1 `unionVarSet` s2) n2
+unionInScope (InScope s1) (InScope s2)
+  = InScope (s1 `unionVarSet` s2)
 
 varSetInScope :: VarSet -> InScopeSet -> Bool
-varSetInScope vars (InScope s1 _) = vars `subVarSet` s1
+varSetInScope vars (InScope s1) = vars `subVarSet` s1
+
+{-
+Note [Local uniques]
+~~~~~~~~~~~~~~~~~~~~
+Sometimes one must create conjure up a unique which is unique in a particular
+context (but not necessarily globally unique). For instance, one might need to
+create a fresh local identifier which does not shadow any of the locally
+in-scope variables.  For this we purpose we provide 'uniqAway'.
+
+'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique'
+operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To
+ensure that we do not conflict with uniques allocated by future allocations
+from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are
+allocated into a dedicated region of the unique space (namely the X tag).
+
+Note that one must be quite carefully when using uniques generated in this way
+since they are only locally unique. In particular, two successive calls to
+'uniqAway' on the same 'InScopeSet' will produce the same unique.
+ -}
 
 -- | @uniqAway in_scope v@ finds a unique that is not used in the
--- in-scope set, and gives that to v.
+-- in-scope set, and gives that to v. See Note [Local uniques].
 uniqAway :: InScopeSet -> Var -> Var
 -- It starts with v's current unique, of course, in the hope that it won't
--- have to change, and thereafter uses a combination of that and the hash-code
--- found in the in-scope set
+-- have to change, and thereafter uses the successor to the last derived unique
+-- found in the in-scope set.
 uniqAway in_scope var
   | var `elemInScopeSet` in_scope = uniqAway' in_scope var      -- Make a new one
   | otherwise                     = var                         -- Nothing to do
 
 uniqAway' :: InScopeSet -> Var -> Var
 -- This one *always* makes up a new variable
-uniqAway' (InScope set n) var
-  = try 1
-  where
-    orig_unique = getUnique var
-    try k
-          | debugIsOn && (k > 1000)
-          = pprPanic "uniqAway loop:" msg
-          | uniq `elemVarSetByKey` set = try (k + 1)
-          | k > 3
-          = pprTraceDebug "uniqAway:" msg
-            setVarUnique var uniq
-          | otherwise = setVarUnique var uniq
-          where
-            msg  = ppr k <+> text "tries" <+> ppr var <+> int n
-            uniq = deriveUnique orig_unique (n * k)
+uniqAway' in_scope var
+  = setVarUnique var (unsafeGetFreshLocalUnique in_scope)
+
+-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the
+-- given 'InScopeSet'. This must be used very carefully since one can very easily
+-- introduce non-unique 'Unique's this way. See Note [Local uniques].
+unsafeGetFreshLocalUnique :: InScopeSet -> Unique
+unsafeGetFreshLocalUnique (InScope set)
+  | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set)
+  , let uniq' = mkLocalUnique uniq
+  , not $ uniq' `ltUnique` minLocalUnique
+  = incrUnique uniq'
+
+  | otherwise
+  = minLocalUnique
 
 {-
 ************************************************************************
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 2acb2a0019..3bcc8670ff 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -2092,6 +2092,7 @@ errorIdKey                    = mkPreludeMiscIdUnique  5
 foldrIdKey                    = mkPreludeMiscIdUnique  6
 recSelErrorIdKey              = mkPreludeMiscIdUnique  7
 seqIdKey                      = mkPreludeMiscIdUnique  8
+absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique  9
 eqStringIdKey                 = mkPreludeMiscIdUnique 10
 noMethodBindingErrorIdKey     = mkPreludeMiscIdUnique 11
 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12
@@ -2107,7 +2108,6 @@ voidPrimIdKey                 = mkPreludeMiscIdUnique 21
 typeErrorIdKey                = mkPreludeMiscIdUnique 22
 divIntIdKey                   = mkPreludeMiscIdUnique 23
 modIntIdKey                   = mkPreludeMiscIdUnique 24
-absentSumFieldErrorIdKey      = mkPreludeMiscIdUnique 9
 
 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
     returnIOIdKey, newStablePtrIdKey,
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index c87bd353c0..620f24c680 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -64,7 +64,6 @@ import FastString
 import qualified ErrUtils as Err
 import ErrUtils( Severity(..) )
 import UniqSupply
-import NameEnv         ( mapNameEnv, filterNameEnv )
 import MonadUtils
 import NameCache
 import NameEnv
diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index b491948cd9..168cc0fc40 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -50,7 +50,6 @@ import CoAxiom
 import VarSet
 import VarEnv
 import Name
-import PrelNames ( eqPrimTyConKey )
 import UniqDFM
 import Outputable
 import Maybes
@@ -1772,9 +1771,8 @@ coreFlattenCo :: TvSubstEnv -> FlattenEnv
 coreFlattenCo subst env co
   = (env2, mkCoVarCo covar)
   where
-    fresh_name    = mkFlattenFreshCoName
     (env1, kind') = coreFlattenTy subst env (coercionType co)
-    covar         = uniqAway (fe_in_scope env1) (mkCoVar fresh_name kind')
+    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'
     -- Add the covar to the FlattenEnv's in-scope set.
     -- See Note [Flattening], wrinkle 2A.
     env2          = updateInScopeSet env1 (flip extendInScopeSet covar)
@@ -1827,6 +1825,8 @@ mkFlattenFreshTyName :: Uniquable a => a -> Name
 mkFlattenFreshTyName unq
   = mkSysTvName (getUnique unq) (fsLit "flt")
 
-mkFlattenFreshCoName :: Name
-mkFlattenFreshCoName
-  = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc")
+mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar
+mkFlattenFreshCoVar in_scope kind
+  = let uniq = unsafeGetFreshLocalUnique in_scope
+        name = mkSystemVarName uniq (fsLit "flc")
+    in mkCoVar name kind
diff --git a/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout b/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout
index 51fa405556..33199d9331 100644
--- a/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout
+++ b/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout
@@ -1,4 +1,4 @@
-["TH module annotation","addTopDecls module annotation","Module annotation"]
+["addTopDecls module annotation","TH module annotation","Module annotation"]
 ["Value annotation"]
 ["TH Value annotation","addTopDecls value annotation"]
 ["Type annotation"]
diff --git a/testsuite/tests/annotations/should_compile/th/annth_make.stdout b/testsuite/tests/annotations/should_compile/th/annth_make.stdout
index 51fa405556..33199d9331 100644
--- a/testsuite/tests/annotations/should_compile/th/annth_make.stdout
+++ b/testsuite/tests/annotations/should_compile/th/annth_make.stdout
@@ -1,4 +1,4 @@
-["TH module annotation","addTopDecls module annotation","Module annotation"]
+["addTopDecls module annotation","TH module annotation","Module annotation"]
 ["Value annotation"]
 ["TH Value annotation","addTopDecls value annotation"]
 ["Type annotation"]
diff --git a/testsuite/tests/annotations/should_run/annrun01.stdout b/testsuite/tests/annotations/should_run/annrun01.stdout
index b57394b563..46df141776 100644
--- a/testsuite/tests/annotations/should_run/annrun01.stdout
+++ b/testsuite/tests/annotations/should_run/annrun01.stdout
@@ -4,7 +4,7 @@ Loading Targets
 Finding Module
 Getting Module Info
 Showing Details For Module
-([10],[],["Rock!!!!","Annotations","Module"],[])
+([10],[],["Module","Annotations","Rock!!!!"],[])
 Showing Details For Exports
 ([],[Just True],["Type Annotation"],[Annrun01_Help.Baz])
 ([],[],[],[])