Minor refactor

* Introduce refactorDupsOn f = refactorDups (comparing f)
* Make mkBigTupleCase and coreCaseTuple monadic.
  Every call to those functions was preceded by calling newUniqueSupply.
* Use mkUserLocalOrCoVar, which is equivalent to combining
  mkLocalIdOrCoVar with mkInternalName.

3 files changed, 10 insertions, 12 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 45561d784c..2f7ab56b5b 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -96,7 +96,6 @@ import Data.Foldable      ( for_, toList )
 import Data.List.NonEmpty ( NonEmpty(..), groupWith )
 import Data.List          ( partition )
 import Data.Maybe
-import Data.Ord           ( comparing )
 import GHC.Data.Pair
 import GHC.Base (oneShot)
 import GHC.Data.Unboxed
@@ -478,7 +477,7 @@ lintCoreBindings' cfg binds
     --    M.n{r3}  = ...
     --    M.n{r29} = ...
     -- because they both get the same linker symbol
-    ext_dups = snd $ removeDups (comparing ord_ext) $
+    ext_dups = snd $ removeDupsOn ord_ext $
                filter isExternalName $ map Var.varName binders
     ord_ext n = (nameModule n, nameOccName n)
 
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index abd28baa47..c11f84d9ba 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -648,12 +648,12 @@ mkSmallTupleSelector1 vars the_var scrut_var scrut
 -- To avoid shadowing, we use uniques to invent new variables.
 --
 -- If necessary we pattern match on a "big" tuple.
-mkBigTupleCase :: UniqSupply       -- ^ For inventing names of intermediate variables
-               -> [Id]             -- ^ The tuple identifiers to pattern match on;
+mkBigTupleCase :: MonadUnique m    --   For inventing names of intermediate variables
+               => [Id]             -- ^ The tuple identifiers to pattern match on;
                                    --   Bring these into scope in the body
                -> CoreExpr         -- ^ Body of the case
                -> CoreExpr         -- ^ Scrutinee
-               -> CoreExpr
+               -> m CoreExpr
 -- ToDo: eliminate cases where none of the variables are needed.
 --
 --         mkBigTupleCase uniqs [a,b,c,d] body v e
@@ -661,11 +661,11 @@ mkBigTupleCase :: UniqSupply       -- ^ For inventing names of intermediate vari
 --             case p of p { (a,b) ->
 --             case q of q { (c,d) ->
 --             body }}}
-mkBigTupleCase us vars body scrut
-  = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
+mkBigTupleCase vars body scrut
+  = do us <- getUniqueSupplyM
+       let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars
+       return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body
   where
-    (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars
-
     scrut_ty = exprType scrut
 
     unwrap var (us,vars,body)
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 35023c6576..ff3357e87b 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -2090,9 +2090,8 @@ dataConInstPat fss uniqs mult con inst_tys
     arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
     mk_id_var uniq fs (Scaled m ty) str
       = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]
-        mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty)
-      where
-        name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
+        mkUserLocalOrCoVar (mkVarOccFS fs) uniq
+                           (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan
 
 {-
 Note [Mark evaluated arguments]