summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC.hs5
-rw-r--r--compiler/GHC/Core/Make.hs30
-rw-r--r--compiler/GHC/Driver/Config/Tidy.hs73
-rw-r--r--compiler/GHC/Driver/Main.hs53
-rw-r--r--compiler/GHC/Iface/Tidy.hs335
-rw-r--r--compiler/GHC/Iface/Tidy/StaticPtrTable.hs81
-rw-r--r--compiler/ghc.cabal.in1
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