Zubin pushed to branch wip/strict-level at Glasgow Haskell Compiler / GHC Commits: f70ba2e8 by Zubin Duggal at 2025-04-29T17:34:04+05:30 Add -fverbose-core-names flag to control generated name verbosity - - - - - 6 changed files: - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs Changes: ===================================== compiler/GHC/Core/Opt/FloatOut.hs ===================================== @@ -18,6 +18,7 @@ import GHC.Core.Make -- import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) +import GHC.Driver.DynFlags ( DynFlags ) import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Utils.Logger import GHC.Types.Id ( Id, idType, @@ -117,14 +118,15 @@ Well, maybe. We don't do this at the moment. ************************************************************************ -} -floatOutwards :: Logger +floatOutwards :: DynFlags + -> Logger -> FloatOutSwitches -> UniqSupply -> CoreProgram -> IO CoreProgram -floatOutwards logger float_sws us pgm +floatOutwards dflags logger float_sws us pgm = do { - let { annotated_w_levels = setLevels float_sws pgm us ; + let { annotated_w_levels = setLevels (initLevelOpts dflags) float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -491,7 +491,7 @@ doCorePass pass guts = do updateBinds (floatInwards platform) CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} - updateBindsM (liftIO . floatOutwards logger f us) + updateBindsM (liftIO . floatOutwards dflags logger f us) CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} updateBinds (doStaticArgs us) ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -76,6 +76,8 @@ module GHC.Core.Opt.SetLevels ( setLevels, + initLevelOpts, LevelOpts (..), + Level(..), tOP_LEVEL, LevelledBind, LevelledExpr, LevelledBndr, FloatSpec(..), floatSpecLevel, @@ -98,6 +100,8 @@ import GHC.Core.Type ( Type, tyCoVarsOfType ) import GHC.Core.Multiplicity ( pattern ManyTy ) +import GHC.Driver.DynFlags ( DynFlags, GeneralFlag(..), gopt) + import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Var @@ -256,15 +260,16 @@ instance Eq Level where ************************************************************************ -} -setLevels :: FloatOutSwitches +setLevels :: LevelOpts + -> FloatOutSwitches -> CoreProgram -> UniqSupply -> [LevelledBind] -setLevels float_lams binds us +setLevels opts float_lams binds us = initLvl us (do_them binds) where - env = initialEnv float_lams binds + env = initialEnv opts float_lams binds do_them :: [CoreBind] -> LvlM [LevelledBind] do_them [] = return [] @@ -1636,9 +1641,14 @@ countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet ************************************************************************ -} +newtype LevelOpts = LevelOpts { verboseInternalNames :: Bool } + +initLevelOpts :: DynFlags -> LevelOpts +initLevelOpts = LevelOpts . gopt Opt_VerboseCoreNames + data LevelEnv = LE { le_switches :: FloatOutSwitches - , le_bind_ctxt :: [Id] + , le_bind_ctxt :: Maybe [Id] , le_ctxt_lvl :: !Level -- The current level , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids @@ -1681,10 +1691,10 @@ The domain of the both envs is *pre-cloned* Ids, though The domain of the le_lvl_env is the *post-cloned* Ids -} -initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv -initialEnv float_lams binds +initialEnv :: LevelOpts -> FloatOutSwitches -> CoreProgram -> LevelEnv +initialEnv opts float_lams binds = LE { le_switches = float_lams - , le_bind_ctxt = [] + , le_bind_ctxt = if verboseInternalNames opts then Just [] else Nothing , le_ctxt_lvl = tOP_LEVEL , le_lvl_env = emptyVarEnv , le_subst = mkEmptySubst in_scope_toplvl @@ -1698,7 +1708,7 @@ initialEnv float_lams binds -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294) pushBindContext :: LevelEnv -> Id -> LevelEnv -pushBindContext env i = env { le_bind_ctxt = i : le_bind_ctxt env } +pushBindContext env i = env { le_bind_ctxt = fmap (i :) (le_bind_ctxt env) } addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl @@ -1863,8 +1873,8 @@ newLvlVar env lvld_rhs join_arity_maybe is_mk_static stem = case le_bind_ctxt env of - [] -> mkFastString "lvl" - ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx) + Nothing -> mkFastString "lvl" + Just ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx) -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1157,7 +1157,8 @@ defaultFlags settings Opt_SuppressStgReps, Opt_UnoptimizedCoreForInterpreter, Opt_SpecialiseIncoherents, - Opt_WriteSelfRecompInfo + Opt_WriteSelfRecompInfo, + Opt_VerboseCoreNames ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -853,6 +853,9 @@ data GeneralFlag -- Object code determinism | Opt_ObjectDeterminism + -- Should core names be verbose and include information about their context + | Opt_VerboseCoreNames + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -968,6 +971,7 @@ codeGenFlags = EnumSet.fromList , Opt_NoTypeableBinds , Opt_ObjectDeterminism , Opt_Haddock + , Opt_VerboseCoreNames -- Flags that affect catching of runtime errors , Opt_CatchNonexhaustiveCases ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2591,6 +2591,7 @@ fFlagsDeps = [ flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, flagSpec "object-determinism" Opt_ObjectDeterminism, + flagSpec "verbose-core-names" Opt_VerboseCoreNames, flagSpec' "compact-unwind" Opt_CompactUnwind (\turn_on -> updM (\dflags -> do unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f70ba2e8e6d7a02d01e2f0a5272d9111... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f70ba2e8e6d7a02d01e2f0a5272d9111... You're receiving this email because of your account on gitlab.haskell.org.