Commit 78b67ad0 authored by Ben Gamari's avatar Ben Gamari 🐢 Committed by Marge Bot

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
parent 25019d18
......@@ -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
......@@ -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
{-
************************************************************************
......
......@@ -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,
......
......@@ -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
......
......@@ -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
["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"]
......
["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"]
......
......@@ -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])
([],[],[],[])
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment