diff options
| -rw-r--r-- | compiler/GHC.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Core/Make.hs | 30 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/Tidy.hs | 73 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 53 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 335 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy/StaticPtrTable.hs | 81 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 |
7 files changed, 328 insertions, 250 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index c62f4baa3b..b573f2769e 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -338,7 +338,6 @@ import GHC.Parser.Utils import GHC.Iface.Load ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars ) -import GHC.Iface.Tidy import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt @@ -1330,12 +1329,12 @@ compileCore simplify fn = do if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy - -- (tidyProgram). + -- (hscTidy). hsc_env <- getSession simpl_guts <- liftIO $ do plugins <- readIORef (tcg_th_coreplugins tcg) hscSimplify hsc_env plugins mod_guts - tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts + tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts return $ Left tidy_guts else return $ Right mod_guts diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 200847134b..932bf8aa8d 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -19,6 +19,7 @@ module GHC.Core.Make ( mkIntegerExpr, mkNaturalExpr, mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + MkStringIds (..), getMkStringIds, -- * Floats FloatBind(..), wrapFloat, wrapFloats, floatBindings, @@ -333,26 +334,37 @@ mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] -- | Create a 'CoreExpr' which will evaluate to the given @String@ mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String +mkStringExpr str = mkStringExprFS (mkFastString str) -- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String +mkStringExprFS = mkStringExprFSLookup lookupId -mkStringExpr str = mkStringExprFS (mkFastString str) +mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr +mkStringExprFSLookup lookupM str = do + mk <- getMkStringIds lookupM + pure (mkStringExprFSWith mk str) + +getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds +getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name -mkStringExprFS = mkStringExprFSWith lookupId +data MkStringIds = MkStringIds + { unpackCStringId :: !Id + , unpackCStringUtf8Id :: !Id + } -mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr -mkStringExprFSWith lookupM str +mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr +mkStringExprFSWith ids str | nullFS str - = return (mkNilExpr charTy) + = mkNilExpr charTy | all safeChar chars - = do unpack_id <- lookupM unpackCStringName - return (App (Var unpack_id) lit) + = let !unpack_id = unpackCStringId ids + in App (Var unpack_id) lit | otherwise - = do unpack_utf8_id <- lookupM unpackCStringUtf8Name - return (App (Var unpack_utf8_id) lit) + = let !unpack_utf8_id = unpackCStringUtf8Id ids + in App (Var unpack_utf8_id) lit where chars = unpackFS str diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs new file mode 100644 index 0000000000..d7ad76fc87 --- /dev/null +++ b/compiler/GHC/Driver/Config/Tidy.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Driver.Config.Tidy + ( initTidyOpts + , initStaticPtrOpts + ) +where + +import GHC.Prelude + +import GHC.Iface.Tidy +import GHC.Iface.Tidy.StaticPtrTable + +import GHC.Driver.Session +import GHC.Driver.Env +import GHC.Driver.Backend + +import GHC.Core.Make (getMkStringIds) +import GHC.Data.Maybe +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Builtin.Names +import GHC.Tc.Utils.Env (lookupGlobal_maybe) +import GHC.Types.TyThing +import GHC.Platform.Ways + +import qualified GHC.LanguageExtensions as LangExt + +initTidyOpts :: HscEnv -> IO TidyOpts +initTidyOpts hsc_env = do + let dflags = hsc_dflags hsc_env + static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags) + then pure Nothing + else Just <$> initStaticPtrOpts hsc_env + pure $ TidyOpts + { opt_name_cache = hsc_NC hsc_env + , opt_collect_ccs = ways dflags `hasWay` WayProf + , opt_unfolding_opts = unfoldingOpts dflags + , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone + | gopt Opt_ExposeAllUnfoldings dflags -> ExposeAll + | otherwise -> ExposeSome + , opt_expose_rules = not (gopt Opt_OmitInterfacePragmas dflags) + , opt_trim_ids = gopt Opt_OmitInterfacePragmas dflags + , opt_static_ptr_opts = static_ptr_opts + } + +initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts +initStaticPtrOpts hsc_env = do + let dflags = hsc_dflags hsc_env + + let lookupM n = lookupGlobal_maybe hsc_env n >>= \case + Succeeded r -> pure r + Failed err -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n)) + + mk_string <- getMkStringIds (fmap tyThingId . lookupM) + static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName + static_ptr_datacon <- tyThingDataCon <$> lookupM staticPtrDataConName + + pure $ StaticPtrOpts + { opt_platform = targetPlatform dflags + + -- If we are compiling for the interpreter we will insert any necessary + -- SPT entries dynamically, otherwise we add a C stub to do so + , opt_gen_cstub = case backend dflags of + Interpreter -> False + _ -> True + + , opt_mk_string = mk_string + , opt_static_ptr_info_datacon = static_ptr_info_datacon + , opt_static_ptr_datacon = static_ptr_datacon + } + diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 62187d573f..32b94fbf14 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -79,6 +79,9 @@ module GHC.Driver.Main , hscParseExpr , hscParseType , hscCompileCoreExpr + , hscTidy + + -- * Low-level exports for hooks , hscCompileCoreExpr' -- We want to make sure that we export enough to be able to redefine @@ -109,6 +112,7 @@ import GHC.Driver.Config.Stg.Ppr (initStgPprOpts) import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Tidy import GHC.Driver.Hooks import GHC.Runtime.Context @@ -142,14 +146,17 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) import GHC.Core import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) -import GHC.Core.Lint ( lintInteractiveExpr ) +import GHC.Core.Lint ( lintInteractiveExpr, endPassIO ) import GHC.Core.Multiplicity import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike +import GHC.Core.Opt.Monad ( CoreToDo (..)) import GHC.Core.Opt.Pipeline import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import GHC.Core.Rules +import GHC.Core.Stats import GHC.CoreToStg.Prep import GHC.CoreToStg ( coreToStg ) @@ -940,8 +947,8 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) simplified_guts <- hscSimplify' plugins desugared_guts - (cg_guts, details) <- {-# SCC "CoreTidy" #-} - liftIO $ tidyProgram hsc_env simplified_guts + (cg_guts, details) <- + liftIO $ hscTidy hsc_env simplified_guts let !partial_iface = {-# SCC "GHC.Driver.Main.mkPartialIface" #-} @@ -2027,7 +2034,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do hscSimplify hsc_env plugins ds_result {- Tidy -} - (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg let !CgGuts{ cg_module = this_mod, cg_binds = core_binds, @@ -2197,6 +2204,44 @@ hscParseThingWithLocation source linenumber parser str = do FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) return thing +hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +hscTidy hsc_env guts = do + let logger = hsc_logger hsc_env + let this_mod = mg_module guts + + opts <- initTidyOpts hsc_env + (cgguts, details) <- withTiming logger + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) + $! {-# SCC "CoreTidy" #-} tidyProgram opts guts + + -- post tidy pretty-printing and linting... + let tidy_rules = md_rules details + let all_tidy_binds = cg_binds cgguts + let print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts) + + endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + unless (logHasDumpFlag logger Opt_D_dump_simpl) $ + putDumpFileMaybe logger Opt_D_dump_rules + (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules")) + FormatText + (pprRulesForUser tidy_rules) + + -- Print one-line size info + let cs = coreBindsStats all_tidy_binds + putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" + FormatText + (text "Tidy size (terms,types,coercions)" + <+> ppr (moduleName this_mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs)) + + pure (cgguts, details) + {- ********************************************************************** %* * diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 268c43945e..85cd431c37 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -6,21 +6,19 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{Tidying up Core} -} -module GHC.Iface.Tidy ( - mkBootModDetailsTc, tidyProgram - ) where +-- | Tidying up Core +module GHC.Iface.Tidy + ( TidyOpts (..) + , UnfoldingExposure (..) + , tidyProgram + , mkBootModDetailsTc + ) +where import GHC.Prelude -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Ppr -import GHC.Driver.Env - import GHC.Tc.Types import GHC.Tc.Utils.Env @@ -29,11 +27,7 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy -import GHC.Core.Opt.Monad -import GHC.Core.Stats (coreBindsStats, CoreStats(..)) import GHC.Core.Seq (seqBinds) -import GHC.Core.Lint -import GHC.Core.Rules import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type ( tidyTopType ) @@ -64,7 +58,6 @@ import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache -import GHC.Types.Name.Ppr import GHC.Types.Avail import GHC.Types.Tickish import GHC.Types.TypeEnv @@ -80,7 +73,6 @@ import Control.Monad import Data.Function import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S -import GHC.Platform.Ways import GHC.Types.CostCentre {- @@ -303,8 +295,7 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameCache kept in the HscEnv as the - source of such system-wide uniques. + We use the given NameCache as the source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache to ensure that the unique assigned is the same as the Id had @@ -348,145 +339,125 @@ three places this is actioned: load a compulsory unfolding -} -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -tidyProgram hsc_env (ModGuts { mg_module = mod - , mg_exports = exports - , mg_rdr_env = rdr_env - , mg_tcs = tcs - , mg_insts = cls_insts - , mg_fam_insts = fam_insts - , mg_binds = binds - , mg_patsyns = patsyns - , mg_rules = imp_rules - , mg_anns = anns - , mg_complete_matches = complete_matches - , mg_deps = deps - , mg_foreign = foreign_stubs - , mg_foreign_files = foreign_files - , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks - , mg_boot_exports = boot_exports - }) - - = Err.withTiming logger - (text "CoreTidy"<+>brackets (ppr mod)) - (const ()) $! - do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags - ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - ; implicit_binds = concatMap getImplicitBinds tcs - } - - ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all - binds implicit_binds imp_rules - ; let { (trimmed_binds, trimmed_rules) - = findExternalRules omit_prags binds imp_rules unfold_env } - - ; let uf_opts = unfoldingOpts dflags - ; (tidy_env, tidy_binds) - <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds - - -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. - ; (spt_entries, tidy_binds') <- - sptCreateStaticBinds hsc_env mod tidy_binds - ; let { platform = targetPlatform (hsc_dflags hsc_env) - ; spt_init_code = sptModuleInitCode platform mod spt_entries - ; add_spt_init_code = - case backend dflags of - -- If we are compiling for the interpreter we will insert - -- any necessary SPT entries dynamically - Interpreter -> id - -- otherwise add a C stub to do so - _ -> (`appendStubC` spt_init_code) - - -- The completed type environment is gotten from - -- a) the types and classes defined here (plus implicit things) - -- b) adding Ids with correct IdInfo, including unfoldings, - -- gotten from the bindings - -- From (b) we keep only those Ids with External names; - -- the CoreTidy pass makes sure these are all and only - -- the externally-accessible ones - -- This truncates the type environment to include only the - -- exported Ids and things needed from them, which saves space - -- - -- See Note [Don't attempt to trim data types] - ; final_ids = [ trimId omit_prags id - | id <- bindersOfBinds tidy_binds - , isExternalName (idName id) - , not (isWiredIn id) - ] -- See Note [Drop wired-in things] - - ; final_tcs = filterOut isWiredIn tcs - -- See Note [Drop wired-in things] - ; tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts - ; tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts - ; tidy_rules = tidyRules tidy_env trimmed_rules - - ; -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' - - -- Get the TyCons to generate code for. Careful! We must use - -- the untidied TyCons here, because we need - -- (a) implicit TyCons arising from types and classes defined - -- in this module - -- (b) wired-in TyCons, which are normally removed from the - -- TypeEnv we put in the ModDetails - -- (c) Constructors even if they are not exported (the - -- tidied TypeEnv has trimmed these away) - ; alg_tycons = filter isAlgTyCon tcs - - - ; local_ccs - | ways dflags `hasWay` WayProf - = collectCostCentres mod all_tidy_binds tidy_rules - | otherwise - = S.empty - } - - ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules - - -- If the endPass didn't print the rules, but ddump-rules is - -- on, print now - ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $ - Logger.putDumpFileMaybe logger Opt_D_dump_rules - (showSDoc dflags (ppr CoreTidy <+> text "rules")) - FormatText - (pprRulesForUser tidy_rules) - - -- Print one-line size info - ; let cs = coreBindsStats tidy_binds - ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" - FormatText - (text "Tidy size (terms,types,coercions)" - <+> ppr (moduleName mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) - <+> int (cs_co cs) ) - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_ccs = S.toList local_ccs, - cg_foreign = add_spt_init_code foreign_stubs, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dep_direct_pkgs deps, - cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks, - cg_spt_entries = spt_entries }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_cls_insts, - md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns, -- are already tidy - md_complete_matches = complete_matches - }) - } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env +data UnfoldingExposure + = ExposeNone -- ^ Don't expose unfoldings + | ExposeSome -- ^ Only expose required unfoldings + | ExposeAll -- ^ Expose all unfoldings + deriving (Show,Eq,Ord) + +data TidyOpts = TidyOpts + { opt_name_cache :: !NameCache + , opt_collect_ccs :: !Bool + , opt_unfolding_opts :: !UnfoldingOpts + , opt_expose_unfoldings :: !UnfoldingExposure + -- ^ Which unfoldings to expose + , opt_trim_ids :: !Bool + -- ^ trim off the arity, one-shot-ness, strictness etc which were + -- retained for the benefit of the code generator + , opt_expose_rules :: !Bool + -- ^ Are rules exposed or not? + , opt_static_ptr_opts :: !(Maybe StaticPtrOpts) + -- ^ Options for generated static pointers, if enabled (/= Nothing). + } + +tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram opts (ModGuts { mg_module = mod + , mg_exports = exports + , mg_tcs = tcs + , mg_insts = cls_insts + , mg_fam_insts = fam_insts + , mg_binds = binds + , mg_patsyns = patsyns + , mg_rules = imp_rules + , mg_anns = anns + , mg_complete_matches = complete_matches + , mg_deps = deps + , mg_foreign = foreign_stubs + , mg_foreign_files = foreign_files + , mg_hpc_info = hpc_info + , mg_modBreaks = modBreaks + , mg_boot_exports = boot_exports + }) = do + + let implicit_binds = concatMap getImplicitBinds tcs + + (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules + let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env + + let uf_opts = opt_unfolding_opts opts + (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds + + -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. + (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of + Nothing -> pure ([], Nothing, tidy_binds) + Just sopts -> sptCreateStaticBinds sopts mod tidy_binds + + let all_foreign_stubs = case mcstub of + Nothing -> foreign_stubs + Just cstub -> foreign_stubs `appendStubC` cstub + + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + final_ids = [ trimId (opt_trim_ids opts) id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredIn id) + ] -- See Note [Drop wired-in things] + + final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts + tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts + tidy_rules = tidyRules tidy_env trimmed_rules + + -- See Note [Injecting implicit bindings] + all_tidy_binds = implicit_binds ++ tidy_binds' + + -- Get the TyCons to generate code for. Careful! We must use + -- the untidied TyCons here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) + alg_tycons = filter isAlgTyCon tcs + + local_ccs + | opt_collect_ccs opts + = collectCostCentres mod all_tidy_binds tidy_rules + | otherwise + = S.empty + + return (CgGuts { cg_module = mod + , cg_tycons = alg_tycons + , cg_binds = all_tidy_binds + , cg_ccs = S.toList local_ccs + , cg_foreign = all_foreign_stubs + , cg_foreign_files = foreign_files + , cg_dep_pkgs = dep_direct_pkgs deps + , cg_hpc_info = hpc_info + , cg_modBreaks = modBreaks + , cg_spt_entries = spt_entries + } + , ModDetails { md_types = tidy_type_env + , md_rules = tidy_rules + , md_insts = tidy_cls_insts + , md_fam_insts = fam_insts + , md_exports = exports + , md_anns = anns -- are already tidy + , md_complete_matches = complete_matches + } + ) ------------------------------------------------------------------------------ @@ -541,8 +512,8 @@ trimId :: Bool -> Id -> Id -- etc which tidyTopIdInfo retains for the benefit of the code generator -- but which we don't want in the interface file or ModIface for -- downstream compilations -trimId omit_prags id - | omit_prags, not (isImplicitId id) +trimId do_trim id + | do_trim, not (isImplicitId id) = id `setIdInfo` vanillaIdInfo `setIdUnfolding` idUnfolding id -- We respect the final unfolding chosen by tidyTopIdInfo. @@ -673,21 +644,20 @@ type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) -- -- Bool => expose unfolding or not. -chooseExternalIds :: HscEnv +chooseExternalIds :: TidyOpts -> Module - -> Bool -> Bool -> [CoreBind] -> [CoreBind] -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules +chooseExternalIds opts mod binds implicit_binds imp_id_rules = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } where - name_cache = hsc_NC hsc_env + name_cache = opt_name_cache opts -- init_ext_ids is the initial list of Ids that should be -- externalised. It serves as the starting point for finding a @@ -701,18 +671,14 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders -- An Id should be external if either (a) it is exported, - -- (b) it appears in the RHS of a local rule for an imported Id, or - -- See Note [Which rules to expose] - is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars - - rule_rhs_vars - -- No rules are exposed when omit_prags is enabled see #19836 - -- imp_id_rules are the RULES in /this/ module for /imported/ Ids - -- If omit_prags is True, these rules won't be put in the interface file. - -- But if omit_prags is False, so imp_id_rules are in the interface file for - -- this module, then the local-defined Ids they use must be made external. - | omit_prags = emptyVarSet - | otherwise = mapUnionVarSet ruleRhsFreeVars imp_id_rules + -- (b) local rules are exposed and it appears in the RHS of a local rule for + -- an imported Id, or See Note [Which rules to expose] + is_external id + | isExportedId id = True + | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars + | otherwise = False + + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules binders = map fst $ flattenBinds binds implicit_binders = bindersOfBinds implicit_binds @@ -758,7 +724,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ | otherwise = do (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc let - (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id + (new_ids, show_unfold) = addExternal opts refined_id -- 'idocc' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set @@ -780,9 +746,9 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Bool -> Id -> ([Id], Bool) -addExternal omit_prags expose_all id - | omit_prags +addExternal :: TidyOpts -> Id -> ([Id], Bool) +addExternal opts id + | ExposeNone <- opt_expose_unfoldings opts , not (isCompulsoryUnfolding unfolding) = ([], False) -- See Note [Always expose compulsory unfoldings] -- in GHC.HsToCore @@ -804,8 +770,9 @@ addExternal omit_prags expose_all id -- In GHCi the unfolding is used by importers show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - = expose_all -- 'expose_all' says to expose all - -- unfoldings willy-nilly + = opt_expose_unfoldings opts == ExposeAll + -- 'ExposeAll' says to expose all + -- unfoldings willy-nilly || isStableSource src -- Always expose things whose -- source is an inline rule @@ -1000,13 +967,13 @@ called in the final code), we keep the rule too. This stuff is the only reason for the ru_auto field in a Rule. -} -findExternalRules :: Bool -- Omit pragmas +findExternalRules :: TidyOpts -> [CoreBind] -> [CoreRule] -- Local rules for imported fns -> UnfoldEnv -- Ids that are exported, so we need their rules -> ([CoreBind], [CoreRule]) -- See Note [Finding external rules] -findExternalRules omit_prags binds imp_id_rules unfold_env +findExternalRules opts binds imp_id_rules unfold_env = (trimmed_binds, filter keep_rule all_rules) where imp_rules = filter expose_rule imp_id_rules @@ -1031,7 +998,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env -- been discarded; see Note [Trimming auto-rules] expose_rule rule - | omit_prags = False + | not (opt_expose_rules opts) = False | otherwise = all is_external_id (ruleLhsFreeIdsList rule) -- Don't expose a rule whose LHS mentions a locally-defined -- Id that is completely internal (i.e. not visible to an diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index 4751ae9ea6..ab29a395da 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | Code generation for the Static Pointer Table -- @@ -48,9 +48,11 @@ -- module GHC.Iface.Tidy.StaticPtrTable - ( sptCreateStaticBinds - , sptModuleInitCode - ) where + ( sptCreateStaticBinds + , sptModuleInitCode + , StaticPtrOpts (..) + ) +where {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -126,36 +128,34 @@ Here is a running example: import GHC.Prelude import GHC.Platform -import GHC.Driver.Session -import GHC.Driver.Env - import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon -import GHC.Core.Make (mkStringExprFSWith) +import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..)) import GHC.Core.Type import GHC.Cmm.CLabel import GHC.Unit.Module import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Builtin.Names -import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Linker.Types -import GHC.Types.Name import GHC.Types.Id -import GHC.Types.TyThing import GHC.Types.ForeignStubs +import GHC.Data.Maybe -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.List (intercalate) -import Data.Maybe import GHC.Fingerprint -import qualified GHC.LanguageExtensions as LangExt + +data StaticPtrOpts = StaticPtrOpts + { opt_platform :: !Platform -- ^ Target platform + , opt_gen_cstub :: !Bool -- ^ Generate CStub or not + , opt_mk_string :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#` + , opt_static_ptr_info_datacon :: !DataCon -- ^ `StaticPtrInfo` datacon + , opt_static_ptr_datacon :: !DataCon -- ^ `StaticPtr` datacon + } -- | Replaces all bindings of the form -- @@ -170,16 +170,13 @@ import qualified GHC.LanguageExtensions as LangExt -- -- It also yields the C stub that inserts these bindings into the static -- pointer table. -sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO ([SptEntry], CoreProgram) -sptCreateStaticBinds hsc_env this_mod binds - | not (xopt LangExt.StaticPointers dflags) = - return ([], binds) - | otherwise = do - -- Make sure the required interface files are loaded. - _ <- lookupGlobal hsc_env unpackCStringName +sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram) +sptCreateStaticBinds opts this_mod binds = do (fps, binds') <- evalStateT (go [] [] binds) 0 - return (fps, binds') + let cstub + | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps) + | otherwise = Nothing + return (fps, cstub, binds') where go fps bs xs = case xs of [] -> return (reverse fps, reverse bs) @@ -187,8 +184,6 @@ sptCreateStaticBinds hsc_env this_mod binds (fps', bnd') <- replaceStaticBind bnd go (reverse fps' ++ fps) (bnd' : bs) xs' - dflags = hsc_dflags hsc_env - -- Generates keys and replaces 'makeStatic' with 'StaticPtr'. -- -- The 'Int' state is used to produce a different key for each binding. @@ -214,19 +209,16 @@ sptCreateStaticBinds hsc_env this_mod binds mkStaticBind t srcLoc e = do i <- get put (i + 1) - staticPtrInfoDataCon <- - lift $ lookupDataConHscEnv staticPtrInfoDataConName + let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i - info <- mkConApp staticPtrInfoDataCon <$> - (++[srcLoc]) <$> - mapM (mkStringExprFSWith (lift . lookupIdHscEnv)) - [ unitFS $ moduleUnit this_mod - , moduleNameFS $ moduleName this_mod - ] - - -- The module interface of GHC.StaticPtr should be loaded at least - -- when looking up 'fromStatic' during type-checking. - staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName + let mk_string_fs = mkStringExprFSWith (opt_mk_string opts) + let info = mkConApp staticPtrInfoDataCon + [ mk_string_fs $ unitFS $ moduleUnit this_mod + , mk_string_fs $ moduleNameFS $ moduleName this_mod + , srcLoc + ] + + let staticPtrDataCon = opt_static_ptr_datacon opts return (fp, mkConApp staticPtrDataCon [ Type t , mkWord64LitWord64 w0 @@ -241,17 +233,6 @@ sptCreateStaticBinds hsc_env this_mod binds , show n ] - lookupIdHscEnv :: Name -> IO Id - lookupIdHscEnv n = lookupType hsc_env n >>= - maybe (getError n) (return . tyThingId) - - lookupDataConHscEnv :: Name -> IO DataCon - lookupDataConHscEnv n = lookupType hsc_env n >>= - maybe (getError n) (return . tyThingDataCon) - - getError n = pprPanic "sptCreateStaticBinds.get: not found" $ - text "Couldn't find" <+> ppr n - -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries -- of @module@ into the static pointer table. -- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c02e56b291..9aae391a1b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -394,6 +394,7 @@ Library GHC.Driver.Config.Stg.Pipeline GHC.Driver.Config.Stg.Ppr GHC.Driver.Config.StgToCmm + GHC.Driver.Config.Tidy GHC.Driver.Env GHC.Driver.Env.KnotVars GHC.Driver.Env.Types |