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
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:
| ... | ... | @@ -18,6 +18,7 @@ import GHC.Core.Make |
| 18 | 18 | -- import GHC.Core.Opt.Arity ( exprArity, etaExpand )
|
| 19 | 19 | import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
|
| 20 | 20 | |
| 21 | +import GHC.Driver.DynFlags ( DynFlags )
|
|
| 21 | 22 | import GHC.Driver.Flags ( DumpFlag (..) )
|
| 22 | 23 | import GHC.Utils.Logger
|
| 23 | 24 | import GHC.Types.Id ( Id, idType,
|
| ... | ... | @@ -117,14 +118,15 @@ Well, maybe. We don't do this at the moment. |
| 117 | 118 | ************************************************************************
|
| 118 | 119 | -}
|
| 119 | 120 | |
| 120 | -floatOutwards :: Logger
|
|
| 121 | +floatOutwards :: DynFlags
|
|
| 122 | + -> Logger
|
|
| 121 | 123 | -> FloatOutSwitches
|
| 122 | 124 | -> UniqSupply
|
| 123 | 125 | -> CoreProgram -> IO CoreProgram
|
| 124 | 126 | |
| 125 | -floatOutwards logger float_sws us pgm
|
|
| 127 | +floatOutwards dflags logger float_sws us pgm
|
|
| 126 | 128 | = do {
|
| 127 | - let { annotated_w_levels = setLevels float_sws pgm us ;
|
|
| 129 | + let { annotated_w_levels = setLevels (initLevelOpts dflags) float_sws pgm us ;
|
|
| 128 | 130 | (fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
|
| 129 | 131 | } ;
|
| 130 | 132 |
| ... | ... | @@ -491,7 +491,7 @@ doCorePass pass guts = do |
| 491 | 491 | updateBinds (floatInwards platform)
|
| 492 | 492 | |
| 493 | 493 | CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-}
|
| 494 | - updateBindsM (liftIO . floatOutwards logger f us)
|
|
| 494 | + updateBindsM (liftIO . floatOutwards dflags logger f us)
|
|
| 495 | 495 | |
| 496 | 496 | CoreDoStaticArgs -> {-# SCC "StaticArgs" #-}
|
| 497 | 497 | updateBinds (doStaticArgs us)
|
| ... | ... | @@ -76,6 +76,8 @@ |
| 76 | 76 | module GHC.Core.Opt.SetLevels (
|
| 77 | 77 | setLevels,
|
| 78 | 78 | |
| 79 | + initLevelOpts, LevelOpts (..),
|
|
| 80 | + |
|
| 79 | 81 | Level(..), tOP_LEVEL,
|
| 80 | 82 | LevelledBind, LevelledExpr, LevelledBndr,
|
| 81 | 83 | FloatSpec(..), floatSpecLevel,
|
| ... | ... | @@ -98,6 +100,8 @@ import GHC.Core.Type ( Type, tyCoVarsOfType |
| 98 | 100 | )
|
| 99 | 101 | import GHC.Core.Multiplicity ( pattern ManyTy )
|
| 100 | 102 | |
| 103 | +import GHC.Driver.DynFlags ( DynFlags, GeneralFlag(..), gopt)
|
|
| 104 | + |
|
| 101 | 105 | import GHC.Types.Id
|
| 102 | 106 | import GHC.Types.Id.Info
|
| 103 | 107 | import GHC.Types.Var
|
| ... | ... | @@ -256,15 +260,16 @@ instance Eq Level where |
| 256 | 260 | ************************************************************************
|
| 257 | 261 | -}
|
| 258 | 262 | |
| 259 | -setLevels :: FloatOutSwitches
|
|
| 263 | +setLevels :: LevelOpts
|
|
| 264 | + -> FloatOutSwitches
|
|
| 260 | 265 | -> CoreProgram
|
| 261 | 266 | -> UniqSupply
|
| 262 | 267 | -> [LevelledBind]
|
| 263 | 268 | |
| 264 | -setLevels float_lams binds us
|
|
| 269 | +setLevels opts float_lams binds us
|
|
| 265 | 270 | = initLvl us (do_them binds)
|
| 266 | 271 | where
|
| 267 | - env = initialEnv float_lams binds
|
|
| 272 | + env = initialEnv opts float_lams binds
|
|
| 268 | 273 | |
| 269 | 274 | do_them :: [CoreBind] -> LvlM [LevelledBind]
|
| 270 | 275 | do_them [] = return []
|
| ... | ... | @@ -1636,9 +1641,14 @@ countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet |
| 1636 | 1641 | ************************************************************************
|
| 1637 | 1642 | -}
|
| 1638 | 1643 | |
| 1644 | +newtype LevelOpts = LevelOpts { verboseInternalNames :: Bool }
|
|
| 1645 | + |
|
| 1646 | +initLevelOpts :: DynFlags -> LevelOpts
|
|
| 1647 | +initLevelOpts = LevelOpts . gopt Opt_VerboseCoreNames
|
|
| 1648 | + |
|
| 1639 | 1649 | data LevelEnv
|
| 1640 | 1650 | = LE { le_switches :: FloatOutSwitches
|
| 1641 | - , le_bind_ctxt :: [Id]
|
|
| 1651 | + , le_bind_ctxt :: Maybe [Id]
|
|
| 1642 | 1652 | , le_ctxt_lvl :: !Level -- The current level
|
| 1643 | 1653 | , le_lvl_env :: VarEnv Level -- Domain is *post-cloned* TyVars and Ids
|
| 1644 | 1654 | |
| ... | ... | @@ -1681,10 +1691,10 @@ The domain of the both envs is *pre-cloned* Ids, though |
| 1681 | 1691 | The domain of the le_lvl_env is the *post-cloned* Ids
|
| 1682 | 1692 | -}
|
| 1683 | 1693 | |
| 1684 | -initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
|
|
| 1685 | -initialEnv float_lams binds
|
|
| 1694 | +initialEnv :: LevelOpts -> FloatOutSwitches -> CoreProgram -> LevelEnv
|
|
| 1695 | +initialEnv opts float_lams binds
|
|
| 1686 | 1696 | = LE { le_switches = float_lams
|
| 1687 | - , le_bind_ctxt = []
|
|
| 1697 | + , le_bind_ctxt = if verboseInternalNames opts then Just [] else Nothing
|
|
| 1688 | 1698 | , le_ctxt_lvl = tOP_LEVEL
|
| 1689 | 1699 | , le_lvl_env = emptyVarEnv
|
| 1690 | 1700 | , le_subst = mkEmptySubst in_scope_toplvl
|
| ... | ... | @@ -1698,7 +1708,7 @@ initialEnv float_lams binds |
| 1698 | 1708 | -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)
|
| 1699 | 1709 | |
| 1700 | 1710 | pushBindContext :: LevelEnv -> Id -> LevelEnv
|
| 1701 | -pushBindContext env i = env { le_bind_ctxt = i : le_bind_ctxt env }
|
|
| 1711 | +pushBindContext env i = env { le_bind_ctxt = fmap (i :) (le_bind_ctxt env) }
|
|
| 1702 | 1712 | |
| 1703 | 1713 | addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
|
| 1704 | 1714 | addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
|
| ... | ... | @@ -1863,8 +1873,8 @@ newLvlVar env lvld_rhs join_arity_maybe is_mk_static |
| 1863 | 1873 | |
| 1864 | 1874 | stem =
|
| 1865 | 1875 | case le_bind_ctxt env of
|
| 1866 | - [] -> mkFastString "lvl"
|
|
| 1867 | - ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx)
|
|
| 1876 | + Nothing -> mkFastString "lvl"
|
|
| 1877 | + Just ctx -> mkFastString $ intercalate "_" ("lvl" : map (occNameString . getOccName) ctx)
|
|
| 1868 | 1878 | |
| 1869 | 1879 | -- | Clone the binders bound by a single-alternative case.
|
| 1870 | 1880 | cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
|
| ... | ... | @@ -1157,7 +1157,8 @@ defaultFlags settings |
| 1157 | 1157 | Opt_SuppressStgReps,
|
| 1158 | 1158 | Opt_UnoptimizedCoreForInterpreter,
|
| 1159 | 1159 | Opt_SpecialiseIncoherents,
|
| 1160 | - Opt_WriteSelfRecompInfo
|
|
| 1160 | + Opt_WriteSelfRecompInfo,
|
|
| 1161 | + Opt_VerboseCoreNames
|
|
| 1161 | 1162 | ]
|
| 1162 | 1163 | |
| 1163 | 1164 | ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
|
| ... | ... | @@ -853,6 +853,9 @@ data GeneralFlag |
| 853 | 853 | -- Object code determinism
|
| 854 | 854 | | Opt_ObjectDeterminism
|
| 855 | 855 | |
| 856 | + -- Should core names be verbose and include information about their context
|
|
| 857 | + | Opt_VerboseCoreNames
|
|
| 858 | + |
|
| 856 | 859 | -- temporary flags
|
| 857 | 860 | | Opt_AutoLinkPackages
|
| 858 | 861 | | Opt_ImplicitImportQualified
|
| ... | ... | @@ -968,6 +971,7 @@ codeGenFlags = EnumSet.fromList |
| 968 | 971 | , Opt_NoTypeableBinds
|
| 969 | 972 | , Opt_ObjectDeterminism
|
| 970 | 973 | , Opt_Haddock
|
| 974 | + , Opt_VerboseCoreNames
|
|
| 971 | 975 | |
| 972 | 976 | -- Flags that affect catching of runtime errors
|
| 973 | 977 | , Opt_CatchNonexhaustiveCases
|
| ... | ... | @@ -2591,6 +2591,7 @@ fFlagsDeps = [ |
| 2591 | 2591 | flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode,
|
| 2592 | 2592 | flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects,
|
| 2593 | 2593 | flagSpec "object-determinism" Opt_ObjectDeterminism,
|
| 2594 | + flagSpec "verbose-core-names" Opt_VerboseCoreNames,
|
|
| 2594 | 2595 | flagSpec' "compact-unwind" Opt_CompactUnwind
|
| 2595 | 2596 | (\turn_on -> updM (\dflags -> do
|
| 2596 | 2597 | unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)
|