summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Driver/Main.hs')
-rw-r--r--compiler/GHC/Driver/Main.hs110
1 files changed, 84 insertions, 26 deletions
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index f45cdc8020..ddc86ac3e3 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -39,6 +39,7 @@ module GHC.Driver.Main
-- * Making an HscEnv
newHscEnv
, newHscEnvWithHUG
+ , initHscEnv
-- * Compiling complete source files
, Messager, batchMsg, batchMultiMsg
@@ -99,10 +100,14 @@ module GHC.Driver.Main
import GHC.Prelude
+import GHC.Platform
+import GHC.Platform.Ways
+
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
+import GHC.Driver.Env.KnotVars
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
@@ -111,10 +116,13 @@ import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Stg.Ppr (initStgPprOpts)
import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
-import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
+import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
+import GHC.Driver.Config.Cmm (initCmmConfig)
+import GHC.Driver.LlvmConfigCache (initLlvmConfigCache)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks
+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
import GHC.Runtime.Context
import GHC.Runtime.Interpreter ( addSptEntry )
@@ -172,6 +180,7 @@ import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
import GHC.Stg.Syntax
import GHC.Stg.Pipeline ( stg2stg )
+import GHC.Stg.InferTags
import GHC.Builtin.Utils
import GHC.Builtin.Names
@@ -215,6 +224,7 @@ import GHC.Types.Name
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
+import GHC.Types.Name.Set (NonCaffySet)
import GHC.Types.TyThing
import GHC.Types.HpcInfo
@@ -232,7 +242,11 @@ import GHC.Data.Bag
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
+import GHC.Data.Maybe
+
import qualified GHC.SysTools
+import GHC.SysTools (initSysTools)
+import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
@@ -246,14 +260,9 @@ import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
-import GHC.Data.Maybe
-import GHC.Driver.Env.KnotVars
-import GHC.Types.Name.Set (NonCaffySet)
-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
import Data.List.NonEmpty (NonEmpty ((:|)))
-import GHC.Stg.InferTags
{- **********************************************************************
%* *
@@ -261,36 +270,80 @@ import GHC.Stg.InferTags
%* *
%********************************************************************* -}
-newHscEnv :: DynFlags -> IO HscEnv
-newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph
+newHscEnv :: FilePath -> DynFlags -> IO HscEnv
+newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph
where
home_unit_graph = unitEnv_singleton
(homeUnitId_ dflags)
(mkHomeUnitEnv dflags emptyHomePackageTable Nothing)
-newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
-newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do
+newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
+newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
nc_var <- initNameCache 'r' knownKeyNames
fc_var <- initFinderCache
logger <- initLogger
tmpfs <- initTmpFs
let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph
unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
- return HscEnv { hsc_dflags = top_dynflags
+ llvm_config <- initLlvmConfigCache top_dir
+ return HscEnv { hsc_dflags = top_dynflags
, hsc_logger = setLogFlags logger (initLogFlags top_dynflags)
- , hsc_targets = []
- , hsc_mod_graph = emptyMG
- , hsc_IC = emptyInteractiveContext dflags
- , hsc_NC = nc_var
- , hsc_FC = fc_var
- , hsc_type_env_vars = emptyKnotVars
- , hsc_interp = Nothing
- , hsc_unit_env = unit_env
- , hsc_plugins = emptyPlugins
- , hsc_hooks = emptyHooks
- , hsc_tmpfs = tmpfs
+ , hsc_targets = []
+ , hsc_mod_graph = emptyMG
+ , hsc_IC = emptyInteractiveContext dflags
+ , hsc_NC = nc_var
+ , hsc_FC = fc_var
+ , hsc_type_env_vars = emptyKnotVars
+ , hsc_interp = Nothing
+ , hsc_unit_env = unit_env
+ , hsc_plugins = emptyPlugins
+ , hsc_hooks = emptyHooks
+ , hsc_tmpfs = tmpfs
+ , hsc_llvm_config = llvm_config
}
+-- | Initialize HscEnv from an optional top_dir path
+initHscEnv :: Maybe FilePath -> IO HscEnv
+initHscEnv mb_top_dir = do
+ top_dir <- findTopDir mb_top_dir
+ mySettings <- initSysTools top_dir
+ dflags <- initDynFlags (defaultDynFlags mySettings)
+ hsc_env <- newHscEnv top_dir dflags
+ checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags
+ setUnsafeGlobalDynFlags dflags
+ -- c.f. DynFlags.parseDynamicFlagsFull, which
+ -- creates DynFlags and sets the UnsafeGlobalDynFlags
+ return hsc_env
+
+-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
+-- breaks tables-next-to-code in dynamically linked modules. This
+-- check should be more selective but there is currently no released
+-- version where this bug is fixed.
+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
+checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO ()
+checkBrokenTablesNextToCode logger dflags = do
+ let invalidLdErr = "Tables-next-to-code not supported on ARM \
+ \when using binutils ld (please see: \
+ \https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
+ broken <- checkBrokenTablesNextToCode' logger dflags
+ when broken (panic invalidLdErr)
+
+checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool
+checkBrokenTablesNextToCode' logger dflags
+ | not (isARM arch) = return False
+ | ways dflags `hasNotWay` WayDyn = return False
+ | not tablesNextToCode = return False
+ | otherwise = do
+ linkerInfo <- liftIO $ GHC.SysTools.getLinkerInfo logger dflags
+ case linkerInfo of
+ GnuLD _ -> return True
+ _ -> return False
+ where platform = targetPlatform dflags
+ arch = platformArch platform
+ tablesNextToCode = platformTablesNextToCode platform
+
+
-- -----------------------------------------------------------------------------
getDiagnostics :: Hsc (Messages GhcMessage)
@@ -1630,6 +1683,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
+ llvm_config = hsc_llvm_config hsc_env
profile = targetProfile dflags
data_tycons = filter isDataTyCon tycons
-- cg_tycons includes newtypes, for the benefit of External Core,
@@ -1688,7 +1742,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
<- {-# SCC "codeOutput" #-}
- codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location
+ codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)
@@ -1741,6 +1795,8 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
profile = targetProfile dflags
home_unit = hsc_home_unit hsc_env
platform = targetPlatform dflags
+ llvm_config = hsc_llvm_config hsc_env
+ cmm_config = initCmmConfig dflags
do_info_table = gopt Opt_InfoTableMap dflags
-- Make up a module name to give the NCG. We can't pass bottom here
-- lest we reproduce #11784.
@@ -1763,7 +1819,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
-- in C we must declare before use, but SRT algorithm is free to
-- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]
cmmgroup <-
- concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm
+ concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm
unless (null cmmgroup) $
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
@@ -1778,7 +1834,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
in NoStubs `appendStubC` ip_init
(_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
- <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
+ <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
rawCmms
return stub_c_exists
where
@@ -1853,11 +1909,13 @@ doCodeGen hsc_env this_mod denv data_tycons
ppr_stream1 = Stream.mapM dump1 cmm_stream
+ cmm_config = initCmmConfig dflags
+
pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
pipeline_stream = do
(non_cafs, lf_infos) <-
{-# SCC "cmmPipeline" #-}
- Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
+ Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1
<&> first (srtMapNonCAFs . moduleSRTMap)
return (non_cafs, lf_infos)
View Lorry Controller Status