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 @@
(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]
{-
************************************************************************
......
......@@ -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
......
......@@ -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
......
+ = (_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)
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
......@@ -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 }
})
......
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