Zubin pushed to branch wip/26264 at Glasgow Haskell Compiler / GHC Commits: 51ec3159 by Zubin Duggal at 2025-08-12T18:00:59+05:30 compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag Fixes #26264 - - - - - 22 changed files: - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/JS/JStg/Monad.hs - compiler/GHC/Platform/Reg.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Stg/EnforceEpt.hs - compiler/GHC/Stg/Pipeline.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Cache.hs - compiler/GHC/Types/Unique.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/Supply.hs Changes: ===================================== compiler/GHC/Builtin/Uniques.hs ===================================== @@ -121,7 +121,7 @@ mkSumTyConUnique arity = assertPpr (arity <= 0x3f) (ppr arity) $ -- 0x3f since we only have 6 bits to encode the -- alternative - mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) + mkUniqueInt SumTag (arity `shiftL` 8 .|. 0xfc) -- | Inverse of 'mkSumTyConUnique' isSumTyConUnique :: Unique -> Maybe Arity @@ -137,7 +137,7 @@ mkSumDataConUnique alt arity | alt >= arity = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) | otherwise - = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} + = mkUniqueInt SumTag (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} getUnboxedSumName :: Int -> Name getUnboxedSumName n @@ -224,17 +224,17 @@ selector Uniques takes inspiration from the encoding for unboxed sum Uniques. -} mkCTupleTyConUnique :: Arity -> Unique -mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a) +mkCTupleTyConUnique a = mkUniqueInt CTupleTag (2*a) mkCTupleDataConUnique :: Arity -> Unique -mkCTupleDataConUnique a = mkUniqueInt 'm' (3*a) +mkCTupleDataConUnique a = mkUniqueInt CTupleDataTag (3*a) mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique mkCTupleSelIdUnique sc_pos arity | sc_pos >= arity = panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity) | otherwise - = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos) + = mkUniqueInt CTupleSelTag (arity `shiftL` cTupleSelIdArityBits + sc_pos) -- | Inverse of 'mkCTupleTyConUnique' isCTupleTyConUnique :: Unique -> Maybe Arity @@ -288,12 +288,12 @@ cTupleSelIdPosBitmask = 0xff -- Normal tuples mkTupleDataConUnique :: Boxity -> Arity -> Unique -mkTupleDataConUnique Boxed a = mkUniqueInt '7' (3*a) -- may be used in C labels -mkTupleDataConUnique Unboxed a = mkUniqueInt '8' (3*a) +mkTupleDataConUnique Boxed a = mkUniqueInt BoxedTupleDataTag (3*a) -- may be used in C labels +mkTupleDataConUnique Unboxed a = mkUniqueInt UnboxedTupleDataTag (3*a) mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkTupleTyConUnique Boxed a = mkUniqueInt '4' (2*a) -mkTupleTyConUnique Unboxed a = mkUniqueInt '5' (2*a) +mkTupleTyConUnique Boxed a = mkUniqueInt BoxedTupleTyConTag (2*a) +mkTupleTyConUnique Unboxed a = mkUniqueInt UnboxedTupleTyConTag (2*a) -- | Inverse of 'mkTupleTyConUnique' isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity) @@ -397,50 +397,50 @@ mkPrimOpIdUnique :: Int -> Unique mkPrimOpWrapperUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique -mkAlphaTyVarUnique i = mkUniqueInt '1' i -mkPreludeClassUnique i = mkUniqueInt '2' i +mkAlphaTyVarUnique i = mkUniqueInt AlphaTyVarTag i +mkPreludeClassUnique i = mkUniqueInt PreludeClassTag i -------------------------------------------------- -mkPrimOpIdUnique op = mkUniqueInt '9' (2*op) -mkPrimOpWrapperUnique op = mkUniqueInt '9' (2*op+1) -mkPreludeMiscIdUnique i = mkUniqueInt '0' i +mkPrimOpIdUnique op = mkUniqueInt PrimOpTag (2*op) +mkPrimOpWrapperUnique op = mkUniqueInt PrimOpTag (2*op+1) +mkPreludeMiscIdUnique i = mkUniqueInt PreludeMiscIdTag i mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique -mkBuiltinUnique i = mkUniqueInt 'B' i -mkPseudoUniqueE i = mkUniqueInt 'E' i -- used in NCG spiller to create spill VirtualRegs +mkBuiltinUnique i = mkUniqueInt BuiltinTag i +mkPseudoUniqueE i = mkUniqueInt PseudoTag i -- used in NCG spiller to create spill VirtualRegs mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkRegSingleUnique = mkUniqueInt 'R' -mkRegSubUnique = mkUniqueInt 'S' -mkRegPairUnique = mkUniqueInt 'P' -mkRegClassUnique = mkUniqueInt 'L' +mkRegSingleUnique = mkUniqueInt RegSingleTag +mkRegSubUnique = mkUniqueInt RegSubTag +mkRegPairUnique = mkUniqueInt RegPairTag +mkRegClassUnique = mkUniqueInt RegClassTag mkCostCentreUnique :: Int -> Unique -mkCostCentreUnique = mkUniqueInt 'C' +mkCostCentreUnique = mkUniqueInt CostCentreTag varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique -varNSUnique = mkUnique 'i' 0 -dataNSUnique = mkUnique 'd' 0 -tvNSUnique = mkUnique 'v' 0 -tcNSUnique = mkUnique 'c' 0 +varNSUnique = mkUnique VarNSTag 0 +dataNSUnique = mkUnique DataNSTag 0 +tvNSUnique = mkUnique TvNSTag 0 +tcNSUnique = mkUnique TcNSTag 0 mkFldNSUnique :: FastString -> Unique -mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs) +mkFldNSUnique fs = mkUniqueInt FldNSTag (uniqueOfFS fs) isFldNSUnique :: Unique -> Bool isFldNSUnique uniq = case unpkUnique uniq of (tag, _) -> tag == 'f' initExitJoinUnique :: Unique -initExitJoinUnique = mkUnique 's' 0 +initExitJoinUnique = mkUnique SimplTag 0 -------------------------------------------------- -- Wired-in type constructor keys occupy *two* slots: -- See Note [Related uniques for wired-in things] mkPreludeTyConUnique :: Int -> Unique -mkPreludeTyConUnique i = mkUniqueInt '3' (2*i) +mkPreludeTyConUnique i = mkUniqueInt PreludeTyConTag (2*i) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u @@ -450,7 +450,7 @@ tyConRepNameUnique u = incrUnique u -- See Note [Related uniques for wired-in things] mkPreludeDataConUnique :: Int -> Unique -mkPreludeDataConUnique i = mkUniqueInt '6' (3*i) -- Must be alphabetic +mkPreludeDataConUnique i = mkUniqueInt PreludeDataConTag (3*i) -- Must be alphabetic dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u @@ -476,7 +476,7 @@ dataConTyRepNameUnique u = stepUnique u 2 -- A little delicate! mkBoxingTyConUnique :: Int -> Unique -mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i) +mkBoxingTyConUnique i = mkUniqueInt BoxingTyConTag (5*i) boxingDataConUnique :: Unique -> Unique boxingDataConUnique u = stepUnique u 2 ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -107,7 +107,7 @@ cpsTop logger platform cfg dus proc = -- TODO(#25273): Use the deterministic UniqDSM (ie `runUniqueDSM`) instead -- of UniqSM (see `initUs_`) to guarantee deterministic objects -- when doing thread sanitization. - us <- mkSplitUniqSupply 'u' + us <- mkSplitUniqSupply TsanTag return $ initUs_ us $ annotateTSAN platform g else return g ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -123,7 +123,7 @@ data CoreReader = CoreReader { cr_name_ppr_ctx :: NamePprCtx, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file - cr_uniq_tag :: !Char -- Tag for creating unique values + cr_uniq_tag :: !UniqueTag -- Tag for creating unique values } -- Note: CoreWriter used to be defined with data, rather than newtype. If it @@ -182,7 +182,7 @@ instance MonadUnique CoreM where runCoreM :: HscEnv -> RuleBase - -> Char -- ^ Mask + -> UniqueTag -- ^ Mask -> Module -> NamePprCtx -> SrcSpan @@ -267,7 +267,7 @@ getSrcSpanM = read cr_loc addSimplCount :: SimplCount -> CoreM () addSimplCount count = write (CoreWriter { cw_simpl_count = count }) -getUniqTag :: CoreM Char +getUniqTag :: CoreM UniqueTag getUniqTag = read cr_uniq_tag -- Convenience accessors for useful fields of HscEnv ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Types.Basic import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Types.Name.Ppr import GHC.Types.Var ( Var ) +import GHC.Types.Unique.Supply ( UniqueTag(..) ) import Control.Monad import qualified GHC.LanguageExtensions as LangExt @@ -78,7 +79,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_rdr_env = rdr_env }) = do { hpt_rule_base <- home_pkg_rules ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars - uniq_tag = 's' + uniq_tag = SimplTag ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -180,13 +180,9 @@ traceSmpl herald doc ************************************************************************ -} --- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques -simplTag :: Char -simplTag = 's' - instance MonadUnique SimplM where - getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag - getUniqueM = liftIO $ uniqFromTag simplTag + getUniqueSupplyM = liftIO $ mkSplitUniqSupply SimplTag + getUniqueM = liftIO $ uniqFromTag SimplTag instance HasLogger SimplM where getLogger = gets st_logger ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -251,7 +251,7 @@ corePrepPgm logger cp_cfg pgm_cfg (\a -> a `seqList` ()) $ do let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg - us <- mkSplitUniqSupply 's' + us <- mkSplitUniqSupply StgTag let implicit_binds = mkDataConWorkers (cpPgm_generateDebugInfo pgm_cfg) @@ -271,7 +271,7 @@ corePrepPgm logger cp_cfg pgm_cfg corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr corePrepExpr logger config expr = do withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do - us <- mkSplitUniqSupply 's' + us <- mkSplitUniqSupply StgTag let initialCorePrepEnv = mkInitialCorePrepEnv config let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -249,7 +249,7 @@ import GHC.Types.Name.Cache ( newNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr import GHC.Types.TyThing -import GHC.Types.Unique.Supply (uniqFromTag) +import GHC.Types.Unique.Supply ( uniqFromTag, UniqueTag(BcoTag) ) import GHC.Types.Unique.Set import GHC.Utils.Fingerprint ( Fingerprint ) @@ -2728,7 +2728,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do -- -- The id has to be exported for the JS backend. This isn't required for the -- byte-code interpreter but it does no harm to always do it. - u <- uniqFromTag 'I' + u <- uniqFromTag BcoTag let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel")) let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr) ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -308,7 +308,7 @@ lookupCompleteMatch type_env hsc_env (CompleteMatch { cmConLikes = nms, cmResult runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside - = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl + = do { res <- initTcRnIf DsTag hsc_env ds_gbl ds_lcl (tryM thing_inside) ; msgs <- readIORef (ds_msgs ds_gbl) ; let final_res ===================================== compiler/GHC/Iface/Rename.hs ===================================== @@ -34,6 +34,7 @@ import GHC.Types.Var import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Shape +import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Misc @@ -194,7 +195,7 @@ initRnIface hsc_env iface insts nsubst do_this = do sh_if_errs = errs_var } -- Modeled off of 'initTc' - res <- initTcRnIf 'c' hsc_env env () $ tryM do_this + res <- initTcRnIf RnIfaceTag hsc_env env () $ tryM do_this msgs <- readIORef errs_var case res of Left _ -> return (Left msgs) ===================================== compiler/GHC/JS/JStg/Monad.hs ===================================== @@ -76,7 +76,7 @@ initJSMState tag supply = JEnv { prefix = tag , ids = supply } initJSM :: IO JEnv -initJSM = do supply <- mkSplitUniqSupply 'j' +initJSM = do supply <- mkSplitUniqSupply JsTag return (initJSMState "js" supply) update_stream :: UniqSupply -> JSM () ===================================== compiler/GHC/Platform/Reg.hs ===================================== @@ -130,7 +130,7 @@ getHiVirtualRegFromLo :: VirtualReg -> VirtualReg getHiVirtualRegFromLo reg = case reg of -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + VirtualRegI u -> VirtualRegHi (newTagUnique u VirtualRegTag) _ -> panic "Reg.getHiVirtualRegFromLo" getHiVRegFromLo :: Reg -> Reg ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -613,7 +613,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do debugTraceMsg (hsc_logger hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" - us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time + us <- mkSplitUniqSupply BcoTag -- Dodgy; will give the same uniques every time let tv_subst = newTyVars us free_tvs (filtered_ids, occs'') = unzip -- again, sync the occ-names [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] ===================================== compiler/GHC/Stg/EnforceEpt.hs ===================================== @@ -17,7 +17,7 @@ import GHC.Types.Name import GHC.Stg.Syntax import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Demand (isDeadEndAppSig) -import GHC.Types.Unique.Supply (mkSplitUniqSupply) +import GHC.Types.Unique.Supply (mkSplitUniqSupply, UniqueTag(StgTag)) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) import Data.List (mapAccumL) @@ -326,7 +326,7 @@ enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do let export_tag_info = collectExportInfo stg_binds_w_tags -- Rewrite STG to uphold the strict field invariant - us_t <- mkSplitUniqSupply 't' + us_t <- mkSplitUniqSupply StgTag let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) ===================================== compiler/GHC/Stg/Pipeline.hs ===================================== @@ -62,7 +62,7 @@ data StgPipelineOpts = StgPipelineOpts -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp. } -newtype StgM a = StgM { _unStgM :: ReaderT Char IO a } +newtype StgM a = StgM { _unStgM :: ReaderT UniqueTag IO a } deriving (Functor, Applicative, Monad, MonadIO) instance MonadUnique StgM where @@ -71,7 +71,7 @@ instance MonadUnique StgM where getUniqueM = StgM $ do { tag <- ask ; liftIO $! uniqFromTag tag} -runStgM :: Char -> StgM a -> IO a +runStgM :: UniqueTag -> StgM a -> IO a runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger @@ -85,7 +85,7 @@ stg2stg logger extra_vars opts this_mod binds ; stg_linter False "StgFromCore" binds ; showPass logger "Stg2Stg" -- Do the main business! - ; binds' <- runStgM 'g' $ + ; binds' <- runStgM StgPTag $ foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts) -- Dependency sort the program as last thing. The program needs to be ===================================== compiler/GHC/StgToCmm/Monad.hs ===================================== @@ -174,7 +174,7 @@ instance DSM.MonadGetUnique FCode where getUniqueM = GHC.Types.Unique.Supply.getUniqueM initC :: IO CgState -initC = do { uniqs <- mkSplitUniqSupply 'c' +initC = do { uniqs <- mkSplitUniqSupply CmmTag ; return (initCgState uniqs) } runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState) ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -158,6 +158,7 @@ import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply ( UniqueTag ) import GHC.Types.Basic import GHC.Types.CostCentre.State @@ -285,7 +286,7 @@ data Env gbl lcl -- Includes all info about imported things -- BangPattern is to fix leak, see #15111 - env_ut :: {-# UNPACK #-} !Char, -- Tag for Uniques + env_ut :: {-# UNPACK #-} !UniqueTag, -- Tag for Uniques env_gbl :: gbl, -- Info about things defined at the top level -- of the module being compiled ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -347,7 +347,7 @@ unkSkolAnon = UnkSkol callStack -- shares a certain 'Unique'. mkSkolemInfo :: MonadIO m => SkolemInfoAnon -> m SkolemInfo mkSkolemInfo sk_anon = do - u <- liftIO $! uniqFromTag 's' + u <- liftIO $! uniqFromTag SkolemTag return (SkolemInfo u sk_anon) getSkolemInfo :: SkolemInfo -> SkolemInfoAnon ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -413,7 +413,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_errs = errs_var } - ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + ; maybe_res <- initTcRnIf TcTag hsc_env gbl_env lcl_env $ do { r <- tryM do_this ; case r of Right res -> return (Just res) @@ -447,7 +447,7 @@ initTcInteractive hsc_env thing_inside where interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 -initTcRnIf :: Char -- ^ Tag for unique supply +initTcRnIf :: UniqueTag -- ^ Tag for unique supply -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a @@ -2297,7 +2297,7 @@ initIfaceLoad hsc_env do_this if_doc = text "initIfaceLoad", if_rec_types = emptyKnotVars } - initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this + initTcRnIf IfaceTag (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this -- | This is used when we are doing to call 'typecheckModule' on an 'ModIface', -- if it's part of a loop with some other modules then we need to use their @@ -2308,7 +2308,7 @@ initIfaceLoadModule hsc_env this_mod do_this if_doc = text "initIfaceLoadModule", if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env) } - initTcRnIf 'i' hsc_env gbl_env () do_this + initTcRnIf IfaceTag hsc_env gbl_env () do_this initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a -- Used when checking the up-to-date-ness of the old Iface @@ -2318,7 +2318,7 @@ initIfaceCheck doc hsc_env do_this if_doc = text "initIfaceCheck" <+> doc, if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env } - initTcRnIf 'i' hsc_env gbl_env () do_this + initTcRnIf IfaceTag hsc_env gbl_env () do_this initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc hi_boot_file thing_inside ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -110,7 +110,7 @@ there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) -- each original name; i.e. (module-name, occ-name) pair and provides -- something of a lookup mechanism for those names. data NameCache = NameCache - { nsUniqChar :: {-# UNPACK #-} !Char + { nsUniqChar :: {-# UNPACK #-} !UniqueTag , nsNames :: {-# UNPACK #-} !(MVar OrigNameCache) } @@ -143,7 +143,7 @@ extendOrigNameCache nc mod occ name -- | Initialize a new name cache newNameCache :: IO NameCache -newNameCache = newNameCacheWith 'r' knownKeysOrigNameCache +newNameCache = newNameCacheWith HscTag knownKeysOrigNameCache -- | This is a version of `newNameCache` that lets you supply your -- own unique tag and set of known key names. This can go wrong if the tag @@ -151,8 +151,8 @@ newNameCache = newNameCacheWith 'r' knownKeysOrigNameCache -- an example. -- -- Use `newNameCache` when possible. -newNameCacheWith :: Char -> OrigNameCache -> IO NameCache -newNameCacheWith c nc = NameCache c <$> newMVar nc +newNameCacheWith :: UniqueTag -> OrigNameCache -> IO NameCache +newNameCacheWith ut nc = NameCache ut <$> newMVar nc -- | This takes a tag for uniques to be generated and the list of knownKeyNames -- These must be initialized properly to ensure that names generated from this @@ -160,7 +160,7 @@ newNameCacheWith c nc = NameCache c <$> newMVar nc -- -- Use `newNameCache` or `newNameCacheWith` instead {-# DEPRECATED initNameCache "Use newNameCache or newNameCacheWith instead" #-} -initNameCache :: Char -> [Name] -> IO NameCache +initNameCache :: UniqueTag -> [Name] -> IO NameCache initNameCache c names = newNameCacheWith c (initOrigNames names) initOrigNames :: [Name] -> OrigNameCache ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -23,6 +23,7 @@ Haskell). module GHC.Types.Unique ( -- * Main data types Unique, Uniquable(..), + UniqueTag(..), uniqueTag, uNIQUE_BITS, -- ** Constructors, destructors and operations on 'Unique's @@ -97,6 +98,100 @@ GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known tag -- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Word64 +data UniqueTag = PluginTag + | SkolemTag + | JsTag + | SimplTag + | StgTag + | CmmTag + | HscTag + | TsanTag + | TcTag + | IfaceTag + | RnIfaceTag + | DsTag + | StgPTag + | BcoTag + | LocalTag + | SumTag + | TupleTag + | CTupleTag + | CTupleDataTag + | CTupleSelTag + | BoxedTupleDataTag + | UnboxedTupleDataTag + | BoxedTupleTyConTag + | UnboxedTupleTyConTag + | AlphaTyVarTag + | PreludeClassTag + | PrimOpTag + | PreludeMiscIdTag + | BuiltinTag + | PseudoTag + | RegSingleTag + | RegSubTag + | RegPairTag + | RegClassTag + | CostCentreTag + | VarNSTag + | DataNSTag + | TvNSTag + | TcNSTag + | FldNSTag + | PreludeTyConTag + | PreludeDataConTag + | BoxingTyConTag + | VirtualRegTag + +uniqueTag :: UniqueTag -> Char +uniqueTag PluginTag = 'p' +uniqueTag JsTag = 'j' +uniqueTag SkolemTag = 's' -- TODO: conflicts with SimplTag +uniqueTag SimplTag = 's' -- TODO: conflicts with SkolemTag +uniqueTag StgTag = 't' +uniqueTag CmmTag = 'c' -- TODO: conflicts with RnIfaceTag and TcNSTag +uniqueTag HscTag = 'r' +uniqueTag TsanTag = 'u' +uniqueTag TcTag = 'a' +uniqueTag IfaceTag = 'i' -- TODO: conflicts with VarNSTag +uniqueTag RnIfaceTag = 'c' -- TODO: conflicts with CmmTag and TcNSTag +uniqueTag DsTag = 'd' -- TODO: conflicts with DataNSTag +uniqueTag StgPTag = 'g' +uniqueTag BcoTag = 'I' +uniqueTag LocalTag = 'X' +uniqueTag SumTag = 'z' +uniqueTag TupleTag = 'k' -- TODO: conflicts with CTupleTag +uniqueTag CTupleTag = 'k' -- TODO: conflicts with TupleTag +uniqueTag CTupleDataTag = 'm' +uniqueTag CTupleSelTag = 'j' +uniqueTag BoxedTupleDataTag = '7' +uniqueTag UnboxedTupleDataTag = '8' +uniqueTag BoxedTupleTyConTag = '4' +uniqueTag UnboxedTupleTyConTag = '5' +uniqueTag AlphaTyVarTag = '1' +uniqueTag PreludeClassTag = '2' +uniqueTag PrimOpTag = '9' +uniqueTag PreludeMiscIdTag = '0' +uniqueTag BuiltinTag = 'B' +uniqueTag PseudoTag = 'E' +uniqueTag RegSingleTag = 'R' +uniqueTag RegSubTag = 'S' +uniqueTag RegPairTag = 'P' +uniqueTag RegClassTag = 'L' +uniqueTag CostCentreTag = 'C' +uniqueTag VarNSTag = 'i' -- TODO: conflicts with IfaceTag +uniqueTag DataNSTag = 'd' -- TODO: conflicts with DsTag +uniqueTag TvNSTag = 'v' +uniqueTag TcNSTag = 'c' -- TODO: conflicts with CmmTag and RnIfaceTag +uniqueTag FldNSTag = 'f' +uniqueTag PreludeTyConTag = '3' +uniqueTag PreludeDataConTag = '6' +uniqueTag BoxingTyConTag = 'b' +uniqueTag VirtualRegTag = 'H' + +{-# INLINE uniqueTag #-} + + {-# INLINE uNIQUE_BITS #-} uNIQUE_BITS :: Int uNIQUE_BITS = 64 - UNIQUE_TAG_BITS @@ -113,7 +208,7 @@ getKey :: Unique -> Word64 -- for Var incrUnique :: Unique -> Unique stepUnique :: Unique -> Word64 -> Unique -newTagUnique :: Unique -> Char -> Unique +newTagUnique :: Unique -> UniqueTag -> Unique mkUniqueGrimily = MkUnique @@ -124,7 +219,7 @@ incrUnique (MkUnique i) = MkUnique (i + 1) stepUnique (MkUnique i) n = MkUnique (i + n) mkLocalUnique :: Word64 -> Unique -mkLocalUnique i = mkUnique 'X' i +mkLocalUnique i = mkUnique LocalTag i minLocalUnique :: Unique minLocalUnique = mkLocalUnique 0 @@ -152,15 +247,15 @@ mkTag c = intToWord64 (ord c) `shiftL` uNIQUE_BITS -- and as long as the Char fits in 8 bits, which we assume anyway! -mkUnique :: Char -> Word64 -> Unique -- Builds a unique from pieces +mkUnique :: UniqueTag -> Word64 -> Unique -- Builds a unique from pieces -- EXPORTED and used only in GHC.Builtin.Uniques mkUnique c i = MkUnique (tag .|. bits) where - tag = mkTag c + tag = mkTag $ uniqueTag c bits = i .&. uniqueMask -mkUniqueInt :: Char -> Int -> Unique +mkUniqueInt :: UniqueTag -> Int -> Unique mkUniqueInt c i = mkUnique c (intToWord64 i) mkUniqueIntGrimily :: Int -> Unique ===================================== compiler/GHC/Types/Unique/DSM.hs ===================================== @@ -134,12 +134,13 @@ runUniqueDSM ds (UDSM f) = DUniqResult uq us -> (uq, us) -- | Set the tag of uniques generated from this deterministic unique supply -newTagDUniqSupply :: Char -> DUniqSupply -> DUniqSupply +newTagDUniqSupply :: UniqueTag -> DUniqSupply -> DUniqSupply newTagDUniqSupply c (DUS w) = DUS $ getKey $ newTagUnique (mkUniqueGrimily w) c -- | Get the tag uniques generated from this deterministic unique supply would have -getTagDUniqSupply :: DUniqSupply -> Char -getTagDUniqSupply (DUS w) = fst $ unpkUnique (mkUniqueGrimily w) +getTagDUniqSupply :: DUniqSupply -> UniqueTag -- TODO +getTagDUniqSupply (DUS w) = fst $ undefined -- unpkUnique (mkUniqueGrimily w) + -- | Get a unique from a monad that can access a unique supply. -- @@ -201,7 +202,7 @@ instance Monad m => MonadGetUnique (UniqDSMT m) where -- | Set the tag of the running @UniqDSMT@ supply to the given tag and run an action with it. -- All uniques produced in the given action will use this tag, until the tag is changed -- again. -setTagUDSMT :: Monad m => Char {-^ Tag -} -> UniqDSMT m a -> UniqDSMT m a +setTagUDSMT :: Monad m => UniqueTag {-^ Tag -} -> UniqDSMT m a -> UniqDSMT m a setTagUDSMT tag (UDSMT act) = UDSMT $ \us -> do let origtag = getTagDUniqSupply us new_us = newTagDUniqSupply tag us ===================================== compiler/GHC/Types/Unique/Supply.hs ===================================== @@ -15,7 +15,8 @@ module GHC.Types.Unique.Supply ( -- ** Operations on supplies uniqFromSupply, uniqsFromSupply, -- basic ops - takeUniqFromSupply, uniqFromTag, + takeUniqFromSupply, + uniqFromTag, UniqueTag(..), mkSplitUniqSupply, splitUniqSupply, listSplitUniqSupply, @@ -200,7 +201,7 @@ data UniqSupply UniqSupply UniqSupply -- when split => these two supplies -mkSplitUniqSupply :: Char -> IO UniqSupply +mkSplitUniqSupply :: UniqueTag -> IO UniqSupply -- ^ Create a unique supply out of thin air. -- The "tag" (Char) supplied is mostly cosmetic, making it easier -- to figure out where a Unique was born. See Note [Uniques and tags]. @@ -213,11 +214,11 @@ mkSplitUniqSupply :: Char -> IO UniqSupply -- See Note [How the unique supply works] -- See Note [Optimising the unique supply] -mkSplitUniqSupply c +mkSplitUniqSupply ut = unsafeDupableInterleaveIO (IO mk_supply) where - !tag = mkTag c + !tag = mkTag $ uniqueTag ut -- Here comes THE MAGIC: see Note [How the unique supply works] -- This is one of the most hammered bits in the whole compiler @@ -279,11 +280,11 @@ initUniqSupply counter inc = do poke ghc_unique_counter64 counter poke ghc_unique_inc inc -uniqFromTag :: Char -> IO Unique +uniqFromTag :: UniqueTag -> IO Unique uniqFromTag !tag = do { uqNum <- genSym ; return $! mkUnique tag uqNum } -{-# NOINLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it +{-# INLINE uniqFromTag #-} -- We'll unbox everything, but we don't want to inline it splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51ec3159742c85592945b40cd654a3fa... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/51ec3159742c85592945b40cd654a3fa... You're receiving this email because of your account on gitlab.haskell.org.