Commit c89bd681 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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)
parent eae703aa
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-} -}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
-- | -- |
-- #name_types# -- #name_types#
...@@ -798,6 +798,29 @@ type TidyOccEnv = UniqFM Int ...@@ -798,6 +798,29 @@ type TidyOccEnv = UniqFM Int
* When looking for a renaming for "foo2" we strip off the "2" and start * 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. 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 type TidyOccEnv = UniqFM Int -- The in-scope OccNames
...@@ -814,24 +837,32 @@ initTidyOccEnv = foldl add emptyUFM ...@@ -814,24 +837,32 @@ initTidyOccEnv = foldl add emptyUFM
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName env occ@(OccName occ_sp fs) tidyOccName env occ@(OccName occ_sp fs)
= case lookupUFM env fs of = case lookupUFM env fs of
Just n -> find n Nothing -> (addToUFM env fs 1, occ) -- Desired OccName is free
Nothing -> (addToUFM env fs 1, occ) Just {} -> case lookupUFM env base1 of
Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
Just n -> find 1 n
where where
base :: String -- Drop trailing digits (see Note [TidyOccEnv]) 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 = case lookupUFM env new_fs of
Just n' -> find (n1 `max` n') Just {} -> find (k+1 :: Int) (n+k)
-- The max ensures that n increases, avoiding loops -- By using n+k, the n arguemt to find goes
Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1, -- 1, add 1, add 2, add 3, etc which
OccName occ_sp new_fs) -- moves at quadratic speed through a dense patch
-- We update only the beginning and end of the
-- chain that find explores; it's a little harder to Nothing -> (if k>5 then pprTrace "tidyOccName" (ppr k $$ ppr occ $$ ppr new_fs)
-- update the middle and there's no real need. else \x -> x)
(new_env, OccName occ_sp new_fs)
where where
n1 = n+1
new_fs = mkFastString (base ++ show n) 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]
{- {-
************************************************************************ ************************************************************************
......
...@@ -328,8 +328,6 @@ cloneMetaTyVar tv ...@@ -328,8 +328,6 @@ cloneMetaTyVar tv
; return (mkTcTyVar name' (tyVarKind tv) details') } ; return (mkTcTyVar name' (tyVarKind tv) details') }
mkTcTyVarName :: Unique -> FastString -> Name 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 mkTcTyVarName uniq str = mkSysTvName uniq str
-- Works for both type and kind variables -- Works for both type and kind variables
......
...@@ -868,6 +868,8 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar ...@@ -868,6 +868,8 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar
-- System Names are for unification variables; -- System Names are for unification variables;
-- when we tidy them we give them a trailing "0" (or 1 etc) -- 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 -- 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") occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
| otherwise = occ | otherwise = occ
......
+ = (_t1::Num a => a -> a -> a) + = (_t1::Num a => a -> a -> a)
print = (_t2::Show a1 => a1 -> IO ()) print = (_t2::Show a1 => a1 -> IO ())
log = (_t3::Floating a2 => a2 -> a2) log = (_t3::Floating a2 => a2 -> a2)
head = (_t4::[a3] -> a3) head = (_t4::[a4] -> a4)
tail = (_t5::[a4] -> [a4]) tail = (_t5::[a7] -> [a7])
fst = (_t6::(a5, b) -> a5) fst = (_t6::(a11, b) -> a11)
T7848.hs:6:57: T7848.hs:6:57: error:
Occurs check: cannot construct the infinite type: Occurs check: cannot construct the infinite type:
t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2 t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2
Relevant bindings include Relevant bindings include
y :: forall t3. t3 -> t -> t1 -> A -> A -> A -> A -> t2 y :: forall t4. t4 -> t -> t1 -> A -> A -> A -> A -> t2
(bound at T7848.hs:8:9) (bound at T7848.hs:8:9)
(&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9) (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9)
z :: t1 (bound at T7848.hs:6:12) z :: t1 (bound at T7848.hs:6:12)
(&) :: t1 (bound at T7848.hs:6:8) (&) :: t1 (bound at T7848.hs:6:8)
(+) :: t (bound at T7848.hs:6:3) (+) :: t (bound at T7848.hs:6:3)
x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)
In the expression: y In the expression: y
In an equation for ‘x’: In an equation for ‘x’:
x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
= y = y
where where
infixl 3 `y` infixl 3 `y`
y _ = (&) y _ = (&)
{-# INLINE (&) #-} {-# INLINE (&) #-}
{-# SPECIALIZE (&) :: a #-} {-# SPECIALIZE (&) :: a #-}
(&) = x (&) = x
T7848.hs:10:9: T7848.hs:10:9: error:
Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’ Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’
with actual type ‘a’ with actual type ‘a’
‘a’ is a rigid type variable bound by ‘a’ is a rigid type variable bound by
the type signature for: (&) :: a at T7848.hs:10:9 the type signature for: (&) :: a at T7848.hs:10:9
Relevant bindings include Relevant bindings include
z :: t1 (bound at T7848.hs:6:12) z :: t1 (bound at T7848.hs:6:12)
(&) :: t1 (bound at T7848.hs:6:8) (&) :: t1 (bound at T7848.hs:6:8)
(+) :: t (bound at T7848.hs:6:3) (+) :: t (bound at T7848.hs:6:3)
x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1)
In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-} In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-}
In an equation for ‘x’: In an equation for ‘x’:
x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
= y = y
where where
infixl 3 `y` infixl 3 `y`
y _ = (&) y _ = (&)
{-# INLINE (&) #-} {-# INLINE (&) #-}
{-# SPECIALIZE (&) :: a #-} {-# SPECIALIZE (&) :: a #-}
(&) = x (&) = x
...@@ -20,20 +20,20 @@ fun1 [InlPrag=NOINLINE] :: Foo -> () ...@@ -20,20 +20,20 @@ fun1 [InlPrag=NOINLINE] :: Foo -> ()
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>]
fun1 = \ (x :: Foo) -> case x of _ [Occ=Dead] { __DEFAULT -> () } fun1 = \ (x :: Foo) -> case x of _ [Occ=Dead] { __DEFAULT -> () }
T7360.fun4 :: () T7360.fun5 :: ()
[GblId, [GblId,
Str=DmdType, Str=DmdType,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] 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, [GblId,
Caf=NoCafRefs, Caf=NoCafRefs,
Str=DmdType m, Str=DmdType m,
Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
T7360.fun3 = I# 0# T7360.fun4 = I# 0#
fun2 :: forall a. [a] -> ((), Int) fun2 :: forall a. [a] -> ((), Int)
[GblId, [GblId,
...@@ -43,17 +43,17 @@ fun2 :: forall a. [a] -> ((), Int) ...@@ -43,17 +43,17 @@ fun2 :: forall a. [a] -> ((), Int)
WorkFree=True, Expandable=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) -> Tmpl= \ (@ a) (x [Occ=Once!] :: [a]) ->
(T7360.fun4, (T7360.fun5,
case x of wild { case x of wild {
[] -> T7360.fun3; [] -> T7360.fun4;
: _ [Occ=Dead] _ [Occ=Dead] -> : _ [Occ=Dead] _ [Occ=Dead] ->
case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 } case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 }
})}] })}]
fun2 = fun2 =
\ (@ a) (x :: [a]) -> \ (@ a) (x :: [a]) ->
(T7360.fun4, (T7360.fun5,
case x of wild { case x of wild {
[] -> T7360.fun3; [] -> T7360.fun4;
: ds ds1 -> : ds ds1 ->
case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 } case GHC.List.$wlenAcc @ a wild 0# of ww2 { __DEFAULT -> I# ww2 }
}) })
......
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