[commit: ghc] wip/T12382: tidyType: Rename variables of nested forall at once (18ac80f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12382
Link       : http://ghc.haskell.org/trac/ghc/changeset/18ac80ff729eb19ec370ead9f9275b3bc32c1f81/ghc

>---------------------------------------------------------------

commit 18ac80ff729eb19ec370ead9f9275b3bc32c1f81
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jul 12 16:52:42 2016 +0200

    tidyType: Rename variables of nested forall at once
    
    this refactoring commit prepares for fixing #12382, which can now be
    implemented soley in tidyTyCoVarBndrs.


>---------------------------------------------------------------

18ac80ff729eb19ec370ead9f9275b3bc32c1f81
 compiler/basicTypes/OccName.hs         |  6 +++++-
 compiler/types/TyCoRep.hs              | 34 +++++++++++++++++++++++++++-------
 testsuite/tests/perf/space_leaks/all.T |  2 ++
 3 files changed, 34 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index 65195ab..c17bd06 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -98,7 +98,7 @@ module OccName (
         filterOccSet,
 
         -- * Tidying up
-        TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
+        TidyOccEnv, emptyTidyOccEnv, tidyOccNames, tidyOccName, initTidyOccEnv,
 
         -- FsEnv
         FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
@@ -114,6 +114,7 @@ import FastStringEnv
 import Outputable
 import Lexeme
 import Binary
+import Data.List (mapAccumL)
 import Data.Char
 import Data.Data
 
@@ -822,6 +823,9 @@ initTidyOccEnv = foldl add emptyUFM
   where
     add env (OccName _ fs) = addToUFM env fs 1
 
+tidyOccNames :: TidyOccEnv -> [OccName] -> (TidyOccEnv, [OccName])
+tidyOccNames env occs = mapAccumL tidyOccName env occs
+
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 08ac9c9..ab07f33 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -3104,17 +3104,21 @@ ppSuggestExplicitKinds
 --
 -- It doesn't change the uniques at all, just the print names.
 tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
-tidyTyCoVarBndrs env tvs = mapAccumL tidyTyCoVarBndr env tvs
+tidyTyCoVarBndrs tidy_env tvs = mapAccumL tidyTyCoVarBndr tidy_env tvs
 
 tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
 tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar
-  = case tidyOccName occ_env occ1 of
-      (tidy', occ') -> ((tidy', subst'), tyvar')
+  = case tidyOccName occ_env (getHelpfulOccName tyvar) of
+      (occ_env', occ') -> ((occ_env', subst'), tyvar')
         where
           subst' = extendVarEnv subst tyvar tyvar'
           tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
-          name'  = tidyNameOcc name occ'
           kind'  = tidyKind tidy_env (tyVarKind tyvar)
+          name'  = tidyNameOcc name occ'
+          name   = tyVarName tyvar
+
+getHelpfulOccName :: TyCoVar -> OccName
+getHelpfulOccName tyvar = occ1
   where
     name = tyVarName tyvar
     occ  = getOccName name
@@ -3182,13 +3186,29 @@ tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys
                                     in args `seqList` TyConApp tycon args
 tidyType env (AppTy fun arg)      = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
 tidyType env (FunTy fun arg)      = (FunTy $! (tidyType env fun)) $! (tidyType env arg)
-tidyType env (ForAllTy (TvBndr tv vis) ty)
-  = (ForAllTy $! ((TvBndr $! tvp) $! vis)) $! (tidyType envp ty)
+tidyType env (ty@(ForAllTy{}))    = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty
   where
-    (envp, tvp) = tidyTyCoVarBndr env tv
+    (tvs, vis, body_ty) = splitForAllTys' ty
+    (env', tvs') = tidyTyCoVarBndrs env tvs
 tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)
 tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)
 
+
+-- The following two functions differ from mkForAllTys and splitForAllTys in that
+-- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but
+-- how should they be named?
+mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type
+mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs
+  where
+    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty
+
+splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type)
+splitForAllTys' ty = go ty [] []
+  where
+    go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
+    go ty                            tvs viss = (reverse tvs, reverse viss, ty)
+
+
 ---------------
 -- | Grabs the free type variables, tidies them
 -- and then uses 'tidyType' to work over the type itself
diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T
index e3597df..0bb21b1 100644
--- a/testsuite/tests/perf/space_leaks/all.T
+++ b/testsuite/tests/perf/space_leaks/all.T
@@ -60,11 +60,13 @@ test('T4029',
           [(wordsize(64), 82, 10)]),
             # 2016-02-26: 66 (amd64/Linux)           INITIAL
             # 2016-05-23: 82 (amd64/Linux)           Use -G1
+            # 2016-07-13: 92 (amd64/Linux)           Changes to tidyType
       stats_num_field('max_bytes_used',
           [(wordsize(64), 25247216, 5)]),
             # 2016-02-26: 24071720 (amd64/Linux)     INITIAL
             # 2016-04-21: 25542832 (amd64/Linux)
             # 2016-05-23: 25247216 (amd64/Linux)     Use -G1
+            # 2016-07-13: 27575416 (amd64/Linux)     Changes to tidyType
       extra_hc_opts('+RTS -G1 -RTS' ),
       ],
      ghci_script,