From 7612dc713d5a1f108cfd6eb731435b090fbb8809 Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski Date: Tue, 24 Jan 2023 06:33:29 +0100 Subject: 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. --- compiler/GHC/Core/Lint.hs | 3 +-- compiler/GHC/Core/Make.hs | 14 +++++++------- compiler/GHC/Core/Utils.hs | 5 ++--- compiler/GHC/Data/List/SetOps.hs | 6 +++++- compiler/GHC/HsToCore/Arrows.hs | 19 ++++++++----------- compiler/GHC/HsToCore/ListComp.hs | 17 +++++++---------- compiler/GHC/HsToCore/Pmc/Solver.hs | 3 +-- compiler/GHC/HsToCore/Pmc/Utils.hs | 3 +-- compiler/GHC/Iface/Env.hs | 4 ++-- compiler/GHC/IfaceToCore.hs | 3 +-- compiler/GHC/Rename/Expr.hs | 5 ++--- compiler/GHC/Rename/Module.hs | 6 +++--- compiler/GHC/Rename/Utils.hs | 8 ++++---- compiler/GHC/Stg/Lift/Monad.hs | 8 +++----- compiler/GHC/Tc/Gen/HsType.hs | 3 +-- compiler/GHC/Tc/Utils/Monad.hs | 4 ++-- compiler/GHC/Tc/Utils/TcMType.hs | 6 ++---- 17 files changed, 52 insertions(+), 65 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] diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs index 99bf2fe903..5aff54c949 100644 --- a/compiler/GHC/Data/List/SetOps.hs +++ b/compiler/GHC/Data/List/SetOps.hs @@ -18,7 +18,7 @@ module GHC.Data.List.SetOps ( Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, -- Duplicate handling - hasNoDups, removeDups, nubOrdBy, findDupsEq, + hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq, equivClasses, -- Indexing @@ -37,6 +37,7 @@ import GHC.Utils.Misc import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) +import Data.Ord (comparing) import qualified Data.Set as S getNth :: Outputable a => [a] -> Int -> a @@ -193,6 +194,9 @@ removeDups cmp xs collect_dups dups_so_far (x :| []) = (dups_so_far, x) collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) +removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a]) +removeDupsOn f x = removeDups (comparing f) x + -- | Remove the duplicates from a list using the provided -- comparison function. nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a] diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index 3a6b964aa8..3013524a2d 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -158,9 +158,9 @@ because the list of variables is typically not yet defined. -- = case v of v { (x1, .., xn) -> body } -- But the matching may be nested if the tuple is very big -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkBigTupleCase uniqs vars body (Var scrut_var) +coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr +coreCaseTuple scrut_var vars body + = mkBigTupleCase vars body (Var scrut_var) coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body @@ -231,9 +231,8 @@ matchEnvStack :: [Id] -- x1..xn -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body + match_env <- coreCaseTuple tup_var env_ids body pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) @@ -250,9 +249,9 @@ matchEnv :: [Id] -- x1..xn -> CoreExpr -- e -> DsM CoreExpr matchEnv env_ids body = do - uniqs <- newUniqueSupply tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + tup_case <- coreCaseTuple tup_id env_ids body + return (Lam tup_id tup_case) ---------------------------------------------- -- matchVarStack @@ -957,11 +956,10 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do -- \ (p, (xs2)) -> (zs) env_id <- newSysLocalDs ManyTy env_ty2 - uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty pat_id <- selectSimpleMatchVarL ManyTy pat @@ -1029,12 +1027,11 @@ dsCmdStmt ids local_vars out_ids -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - uniqs <- newUniqueSupply env2_id <- newSysLocalDs ManyTy env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids) post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index ca89c468ed..d338d331db 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -444,15 +444,13 @@ mkUnzipBind _ elt_tys ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) tupled_concat_expression = mkBigCoreTup concat_expressions - folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs) - folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case + ; folder_body_inner_case <- mkBigTupleCase xss tupled_concat_expression (Var axs) + ; folder_body_outer_case <- mkBigTupleCase xs folder_body_inner_case (Var ax) + ; let folder_body = mkLams [ax, axs] folder_body_outer_case ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } @@ -546,9 +544,8 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs ; body <- dsMcStmts stmts_rest ; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys - ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkBigTupleCase us to_bndrs body tup_n_expr' + ; body' <- mkBigTupleCase to_bndrs body tup_n_expr' ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -592,9 +589,9 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr -- returns the Core term -- \x. case x of (a,b,c) -> body matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) } + = do { tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) + ; tup_case <- mkBigTupleCase ids body (Var tup_id) + ; return (Lam tup_id tup_case) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index cfc98273e3..30b55388dd 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -640,8 +640,7 @@ nameTyCt :: PredType -> DsM EvVar nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) - idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname ManyTy pred_ty) + return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan) ----------------------------- -- ** Adding term constraints diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index a2a73067a9..771f51916d 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -51,8 +51,7 @@ traceWhenFailPm herald doc act = MaybeT $ do mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" - name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name ManyTy ty) + in return (mkUserLocalOrCoVar occname unique ManyTy ty noSrcSpan) {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index eeef41ecc1..a67fdfe334 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -262,9 +262,9 @@ newIfaceName occ newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs - = do { uniqs <- newUniqueSupply + = do { uniqs <- getUniquesM ; return [ mkInternalName uniq occ noSrcSpan - | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } + | (occ,uniq) <- occs `zip` uniqs] } trace_if :: Logger -> SDoc -> IO () {-# INLINE trace_if #-} diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 7138c0433e..4a4c2a6cee 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1674,8 +1674,7 @@ tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_st tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs - = do { us <- newUniqueSupply - ; let uniqs = uniqsFromSupply us + = do { uniqs <- getUniquesM ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs mult con inst_tys diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 24462a21bc..47e6217f56 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -64,7 +64,7 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText import GHC.Utils.Misc -import GHC.Data.List.SetOps ( removeDups ) +import GHC.Data.List.SetOps ( removeDupsOn ) import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -1305,7 +1305,7 @@ rnParallelStmts ctxt return_op segs thing_inside -> [Name] -> [ParStmtBlock GhcPs GhcPs] -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) rn_segs _ bndrs_so_far [] - = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far + = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far ; mapM_ dupErr dups ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } @@ -1321,7 +1321,6 @@ rnParallelStmts ctxt return_op segs thing_inside ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 597d6acc27..7bb5b56afc 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -62,7 +62,7 @@ import GHC.Driver.Session import GHC.Utils.Misc ( lengthExceeds, partitionWith ) import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) -import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) +import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) import GHC.Types.Unique.Set @@ -1604,7 +1604,7 @@ rnStandaloneKindSignatures -> [LStandaloneKindSig GhcPs] -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] rnStandaloneKindSignatures tc_names kisigs - = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs + = do { let (no_dups, dup_kisigs) = removeDupsOn get_name kisigs get_name = standaloneKindSigName . unLoc ; mapM_ dupKindSig_Err dup_kisigs ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups @@ -1682,7 +1682,7 @@ rnRoleAnnots :: NameSet rnRoleAnnots tc_names role_annots = do { -- Check for duplicates *before* renaming, to avoid -- lumping together all the unboundNames - let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots + let (no_dups, dup_annots) = removeDupsOn get_name role_annots get_name = roleAnnotDeclName . unLoc ; mapM_ dupRoleAnnotErr dup_annots ; mapM (wrapLocMA rn_role_annot1) no_dups } diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 25c91eb62c..f0f5b426b7 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -57,7 +57,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) -import GHC.Data.List.SetOps ( removeDups ) +import GHC.Data.List.SetOps ( removeDupsOn ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session import GHC.Data.FastString @@ -114,14 +114,14 @@ checkDupRdrNames :: [LocatedN RdrName] -> RnM () checkDupRdrNames rdr_names_w_loc = mapM_ (dupNamesErr getLocA) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDupsOn unLoc rdr_names_w_loc checkDupRdrNamesN :: [LocatedN RdrName] -> RnM () -- Check for duplicated names in a binding group checkDupRdrNamesN rdr_names_w_loc = mapM_ (dupNamesErr getLocA) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDupsOn unLoc rdr_names_w_loc checkDupNames :: [Name] -> RnM () -- Check for duplicated names in a binding group @@ -132,7 +132,7 @@ check_dup_names :: [Name] -> RnM () check_dup_names names = mapM_ (dupNamesErr nameSrcSpan) dups where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + (_, dups) = removeDupsOn nameOccName names --------------------- checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 0003150e19..930c3963b2 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -275,15 +275,13 @@ withSubstBndrs = runContT . traverse (ContT . withSubstBndr) -- binder and fresh name generation. withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do - uniq <- getUniqueM let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) - let bndr' + bndr' <- -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. - = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal str uniq ManyTy - $ ty + transferPolyIdInfo bndr (dVarSetElems abs_ids) + <$> mkSysLocalM str ManyTy ty LiftM $ RWS.local (\e -> e { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index bf15393048..222755f6c9 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -3692,14 +3692,13 @@ splitTyConKind :: SkolemInfo -- See also Note [Datatype return kinds] in GHC.Tc.TyCl splitTyConKind skol_info in_scope avoid_occs kind = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply + ; new_uniqs <- getUniquesM ; rdr_env <- getLocalRdrEnv ; lvl <- getTcLevel ; let new_occs = Inf.filter (\ occ -> isNothing (lookupLocalRdrOcc rdr_env occ) && -- Note [Avoid name clashes for associated data types] not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings - new_uniqs = uniqsFromSupply uniqs subst = mkEmptySubst in_scope details = SkolemTv skol_info (pushTcLevel lvl) False -- As always, allocate skolems one level in diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index afc7633ff2..ecd3ab3249 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -729,9 +729,9 @@ newSysLocalId fs w ty newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys - = do { us <- newUniqueSupply + = do { us <- getUniquesM ; let mkId' n (Scaled w t) = mkSysLocal fs n w t - ; return (zipWith mkId' (uniqsFromSupply us) tys) } + ; return (zipWith mkId' us tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index 89614378cd..d0afe71560 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -770,13 +770,11 @@ newMetaTyVarName :: FastString -> TcM Name -- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and -- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2) newMetaTyVarName str - = do { uniq <- newUnique - ; return (mkSystemName uniq (mkTyVarOccFS str)) } + = newSysName (mkTyVarOccFS str) cloneMetaTyVarName :: Name -> TcM Name cloneMetaTyVarName name - = do { uniq <- newUnique - ; return (mkSystemName uniq (nameOccName name)) } + = newSysName (nameOccName name) -- See Note [Name of an instantiated type variable] {- Note [Name of an instantiated type variable] -- cgit v1.2.1