diff options
| -rw-r--r-- | compiler/cmm/CLabel.hs | 57 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs | 1 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.hs | 3 | ||||
| -rw-r--r-- | compiler/ghc.mk | 50 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 9 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.hs | 8 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 3 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 59 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 2 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 47 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.hs | 2 | ||||
| -rw-r--r-- | compiler/nativeGen/PIC.hs | 48 | ||||
| -rw-r--r-- | hadrian/src/Rules/Generate.hs | 130 | ||||
| -rw-r--r-- | includes/ghc.mk | 17 |
14 files changed, 208 insertions, 228 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 81a226d65f..fddb063185 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -120,7 +120,6 @@ import Module import Name import Unique import PrimOp -import Config import CostCentre import Outputable import FastString @@ -1151,35 +1150,35 @@ and are not externally visible. -} instance Outputable CLabel where - ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c + ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c -pprCLabel :: Platform -> CLabel -> SDoc +pprCLabel :: DynFlags -> CLabel -> SDoc pprCLabel _ (LocalBlockLabel u) = tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempLabel u) - | not (platformUnregisterised platform) +pprCLabel dynFlags (AsmTempLabel u) + | not (platformUnregisterised $ targetPlatform dynFlags) = tempLabelPrefixOrUnderscore <> pprUniqueAlways u -pprCLabel platform (AsmTempDerivedLabel l suf) - | cGhcWithNativeCodeGen == "YES" - = ptext (asmTempLabelPrefix platform) +pprCLabel dynFlags (AsmTempDerivedLabel l suf) + | sGhcWithNativeCodeGen $ settings dynFlags + = ptext (asmTempLabelPrefix $ targetPlatform dynFlags) <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel platform l + _other -> pprCLabel dynFlags l <> ftext suf -pprCLabel platform (DynamicLinkerLabel info lbl) - | cGhcWithNativeCodeGen == "YES" - = pprDynamicLinkerAsmLabel platform info lbl +pprCLabel dynFlags (DynamicLinkerLabel info lbl) + | sGhcWithNativeCodeGen $ settings dynFlags + = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl -pprCLabel _ PicBaseLabel - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags PicBaseLabel + | sGhcWithNativeCodeGen $ settings dynFlags = text "1b" -pprCLabel platform (DeadStripPreventer lbl) - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags (DeadStripPreventer lbl) + | sGhcWithNativeCodeGen $ settings dynFlags = {- `lbl` can be temp one but we need to ensure that dsp label will stay @@ -1187,23 +1186,24 @@ pprCLabel platform (DeadStripPreventer lbl) optional `_` (underscore) because this is how you mark non-temp symbols on some platforms (Darwin) -} - maybe_underscore $ text "dsp_" - <> pprCLabel platform lbl <> text "_dsp" + maybe_underscore dynFlags $ text "dsp_" + <> pprCLabel dynFlags lbl <> text "_dsp" -pprCLabel _ (StringLitLabel u) - | cGhcWithNativeCodeGen == "YES" +pprCLabel dynFlags (StringLitLabel u) + | sGhcWithNativeCodeGen $ settings dynFlags = pprUniqueAlways u <> ptext (sLit "_str") -pprCLabel platform lbl +pprCLabel dynFlags lbl = getPprStyle $ \ sty -> - if cGhcWithNativeCodeGen == "YES" && asmStyle sty - then maybe_underscore (pprAsmCLbl platform lbl) + if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty + then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl else pprCLbl lbl -maybe_underscore :: SDoc -> SDoc -maybe_underscore doc - | underscorePrefix = pp_cSEP <> doc - | otherwise = doc +maybe_underscore :: DynFlags -> SDoc -> SDoc +maybe_underscore dynFlags doc = + if sLeadingUnderscore $ settings dynFlags + then pp_cSEP <> doc + else doc pprAsmCLbl :: Platform -> CLabel -> SDoc pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) @@ -1363,9 +1363,6 @@ tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -underscorePrefix :: Bool -- leading underscore on assembler labels? -underscorePrefix = (cLeadingUnderscore == "YES") - asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels asmTempLabelPrefix platform = case platformOS platform of OSDarwin -> sLit "L" diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index bf6182bc89..e49ffb5973 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -55,7 +55,6 @@ import Pair import Outputable import Platform import FastString -import Config import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 95a5e4af14..4df053d845 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -50,7 +50,6 @@ import Outputable import FastString import DynFlags import Platform -import Config import OrdList import Pair import Util @@ -542,7 +541,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc | otherwise = text ('a':show n) -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = cLibFFI && isNothing maybe_target + libffi = sLibFFI (settings dflags) && isNothing maybe_target type_string -- libffi needs to know the result type too: diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 18c3425305..b8c0a1a2fc 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -55,10 +55,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ - @echo 'data IntegerLibrary = IntegerGMP' >> $@ - @echo ' | IntegerSimple' >> $@ - @echo ' deriving Eq' >> $@ - @echo >> $@ @echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @echo 'cHostPlatformString :: String' >> $@ @@ -82,52 +78,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cBooterVersion = "$(GhcVersion)"' >> $@ @echo 'cStage :: String' >> $@ @echo 'cStage = show (STAGE :: Int)' >> $@ - @echo 'cIntegerLibraryType :: IntegerLibrary' >> $@ -ifeq "$(INTEGER_LIBRARY)" "integer-gmp" - @echo 'cIntegerLibraryType = IntegerGMP' >> $@ -else ifeq "$(INTEGER_LIBRARY)" "integer-simple" - @echo 'cIntegerLibraryType = IntegerSimple' >> $@ -else ifneq "$(CLEANING)" "YES" -$(error Unknown integer library) -endif - @echo 'cGhcWithInterpreter :: String' >> $@ - @echo 'cGhcWithInterpreter = "$(GhcWithInterpreter)"' >> $@ - @echo 'cGhcWithNativeCodeGen :: String' >> $@ - @echo 'cGhcWithNativeCodeGen = "$(GhcWithNativeCodeGen)"' >> $@ - @echo 'cGhcWithSMP :: String' >> $@ - @echo 'cGhcWithSMP = "$(GhcWithSMP)"' >> $@ - @echo 'cGhcRTSWays :: String' >> $@ - @echo 'cGhcRTSWays = "$(GhcRTSWays)"' >> $@ - @echo 'cGhcRtsWithLibdw :: Bool' >> $@ -ifeq "$(GhcRtsWithLibdw)" "YES" - @echo 'cGhcRtsWithLibdw = True' >> $@ -else - @echo 'cGhcRtsWithLibdw = False' >> $@ -endif - @echo 'cLeadingUnderscore :: String' >> $@ - @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ - @echo 'cLibFFI :: Bool' >> $@ -ifeq "$(UseLibFFIForAdjustors)" "YES" - @echo 'cLibFFI = True' >> $@ -else - @echo 'cLibFFI = False' >> $@ -endif -# Note that GhcThreaded just reflects the Makefile variable setting. -# In particular, the stage1 compiler is never actually compiled with -# -threaded, but it will nevertheless have cGhcThreaded = True. -# The "+RTS --info" output will show what RTS GHC is really using. - @echo 'cGhcThreaded :: Bool' >> $@ -ifeq "$(GhcThreaded)" "YES" - @echo 'cGhcThreaded = True' >> $@ -else - @echo 'cGhcThreaded = False' >> $@ -endif - @echo 'cGhcDebugged :: Bool' >> $@ -ifeq "$(GhcDebugged)" "YES" - @echo 'cGhcDebugged = True' >> $@ -else - @echo 'cGhcDebugged = False' >> $@ -endif @echo done. # ----------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 15101c82ee..d55c339888 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -390,17 +390,15 @@ ghcInternalFunctions = do -- | Pretty print a 'CLabel'. strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) return (fsLit str) strDisplayName_llvm :: CLabel -> LlvmM LMString strDisplayName_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl depth = Outp.PartWay 1 style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth str = Outp.renderWithStyle dflags sdoc style @@ -416,9 +414,8 @@ dropInfoSuffix = go strProcedureName_llvm :: CLabel -> LlvmM LMString strProcedureName_llvm lbl = do - platform <- getLlvmPlatform dflags <- getDynFlags - let sdoc = pprCLabel platform lbl + let sdoc = pprCLabel dflags lbl depth = Outp.PartWay 1 style = Outp.mkUserStyle dflags Outp.neverQualify depth str = Outp.renderWithStyle dflags sdoc style diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 478de594ac..1ded72111a 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -24,7 +24,6 @@ import Packages import Cmm ( RawCmmGroup ) import HscTypes import DynFlags -import Config import Stream (Stream) import qualified Stream import FileCleanup @@ -156,7 +155,7 @@ outputAsm :: DynFlags -> Module -> ModLocation -> FilePath -> Stream IO RawCmmGroup () -> IO () outputAsm dflags this_mod location filenm cmm_stream - | cGhcWithNativeCodeGen == "YES" + | sGhcWithNativeCodeGen $ settings dflags = do ncg_uniqs <- mkSplitUniqSupply 'n' debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) @@ -226,8 +225,9 @@ outputForeignStubs dflags mod location stubs mk_include i = "#include \"" ++ i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h - ffi_includes | cLibFFI = "#include \"ffi.h\"\n" - | otherwise = "" + ffi_includes + | sLibFFI $ settings dflags = "#include \"ffi.h\"\n" + | otherwise = "" stub_h_file_exists <- outputForeignStubs_help stub_h stub_h_output_w diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 82a6d601de..d22462388e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -49,7 +49,6 @@ import Outputable import Module import ErrUtils import DynFlags -import Config import Panic import Util import StringBuffer ( hGetStringBuffer ) @@ -369,7 +368,7 @@ link ghcLink dflags = lookupHook linkHook l dflags ghcLink dflags where l LinkInMemory _ _ _ - = if cGhcWithInterpreter == "YES" + = if sGhcWithInterpreter $ settings dflags then -- Not Linking...(demand linker will do the job) return Succeeded else panicBadLink LinkInMemory diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ece0c2208e..d40a9aba36 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -87,6 +87,7 @@ module DynFlags ( -- ** System tool settings and locations Settings(..), + IntegerLibrary(..), targetPlatform, programName, projectVersion, ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, versionedAppDir, @@ -1302,6 +1303,11 @@ type LlvmTargets = [(String, LlvmTarget)] type LlvmPasses = [(Int, String)] type LlvmConfig = (LlvmTargets, LlvmPasses) +data IntegerLibrary + = IntegerGMP + | IntegerSimple + deriving (Read, Show, Eq) + data Settings = Settings { sTargetPlatform :: Platform, -- Filled in by SysTools sGhcUsagePath :: FilePath, -- ditto @@ -1358,7 +1364,18 @@ data Settings = Settings { -- Formerly Config.hs, target specific sTargetPlatformString :: String, -- TODO Recalculate string from richer info? - sTablesNextToCode :: Bool + sIntegerLibrary :: String, + sIntegerLibraryType :: IntegerLibrary, + sGhcWithInterpreter :: Bool, + sGhcWithNativeCodeGen :: Bool, + sGhcWithSMP :: Bool, + sGhcRTSWays :: String, + sTablesNextToCode :: Bool, + sLeadingUnderscore :: Bool, + sLibFFI :: Bool, + sGhcThreaded :: Bool, + sGhcDebugged :: Bool, + sGhcRtsWithLibdw :: Bool } targetPlatform :: DynFlags -> Platform @@ -1615,16 +1632,18 @@ instance Outputable PackageFlag where ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) ppr (HidePackage str) = text "-hide-package" <+> text str -defaultHscTarget :: Platform -> HscTarget +defaultHscTarget :: Settings -> HscTarget defaultHscTarget = defaultObjectTarget -- | The 'HscTarget' value corresponding to the default way to create -- object files on the current platform. -defaultObjectTarget :: Platform -> HscTarget -defaultObjectTarget platform +defaultObjectTarget :: Settings -> HscTarget +defaultObjectTarget settings | platformUnregisterised platform = HscC - | cGhcWithNativeCodeGen == "YES" = HscAsm + | sGhcWithNativeCodeGen settings = HscAsm | otherwise = HscLlvm + where + platform = sTargetPlatform settings -- Determines whether we will be compiling -- info tables that reside just before the entry code, or with an @@ -1887,8 +1906,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, - hscTarget = defaultHscTarget (sTargetPlatform mySettings), - integerLibrary = cIntegerLibraryType, + hscTarget = defaultHscTarget mySettings, + integerLibrary = sIntegerLibraryType mySettings, verbosity = 0, optLevel = 0, debugLevel = 0, @@ -3704,7 +3723,7 @@ dynamic_flags_deps = [ , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> d { ghcLink=NoLink }) >> setTarget HscNothing)) , make_ord_flag defFlag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , make_ord_flag defFlag "fobject-code" (NoArg (setTargetWithPlatform + , make_ord_flag defFlag "fobject-code" (NoArg (setTargetWithSettings defaultHscTarget)) , make_dep_flag defFlag "fglasgow-exts" (NoArg enableGlasgowExts) "Use individual extensions instead" @@ -5386,12 +5405,12 @@ interpretPackageEnv dflags = do -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). setTarget :: HscTarget -> DynP () -setTarget l = setTargetWithPlatform (const l) +setTarget l = setTargetWithSettings (const l) -setTargetWithPlatform :: (Platform -> HscTarget) -> DynP () -setTargetWithPlatform f = upd set +setTargetWithSettings :: (Settings -> HscTarget) -> DynP () +setTargetWithSettings f = upd set where - set dfs = let l = f (targetPlatform dfs) + set dfs = let l = f (settings dfs) in if ghcLink dfs /= LinkBinary || isObjectTarget l then dfs{ hscTarget = l } else dfs @@ -5623,13 +5642,13 @@ compilerInfo dflags ("Build platform", cBuildPlatformString), ("Host platform", cHostPlatformString), ("Target platform", sTargetPlatformString $ settings dflags), - ("Have interpreter", cGhcWithInterpreter), + ("Have interpreter", showBool $ sGhcWithInterpreter $ settings dflags), ("Object splitting supported", showBool False), - ("Have native code generator", cGhcWithNativeCodeGen), - ("Support SMP", cGhcWithSMP), + ("Have native code generator", showBool $ sGhcWithNativeCodeGen $ settings dflags), + ("Support SMP", showBool $ sGhcWithSMP $ settings dflags), ("Tables next to code", showBool $ sTablesNextToCode $ settings dflags), - ("RTS ways", cGhcRTSWays), - ("RTS expects libdw", showBool cGhcRtsWithLibdw), + ("RTS ways", sGhcRTSWays $ settings dflags), + ("RTS expects libdw", showBool $ sGhcRtsWithLibdw $ settings dflags), -- Whether or not we support @-dynamic-too@ ("Support dynamic-too", showBool $ not isWindows), -- Whether or not we support the @-j@ flag with @--make@. @@ -5656,7 +5675,7 @@ compilerInfo dflags ("GHC Dynamic", showBool dynamicGhc), -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool rtsIsProfiled), - ("Leading underscore", cLeadingUnderscore), + ("Leading underscore", showBool $ sLeadingUnderscore $ settings dflags), ("Debug on", show debugIsOn), ("LibDir", topDir dflags), -- The path of the global package database used by GHC @@ -5747,7 +5766,7 @@ makeDynFlagsConsistent dflags in loop dflags' warn | hscTarget dflags == HscC && not (platformUnregisterised (targetPlatform dflags)) - = if cGhcWithNativeCodeGen == "YES" + = if sGhcWithNativeCodeGen $ settings dflags then let dflags' = dflags { hscTarget = HscAsm } warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" in loop dflags' warn @@ -5763,7 +5782,7 @@ makeDynFlagsConsistent dflags = loop (dflags { hscTarget = HscC }) "Compiler unregisterised, so compiling via C" | hscTarget dflags == HscAsm && - cGhcWithNativeCodeGen /= "YES" + not (sGhcWithNativeCodeGen $ settings dflags) = let dflags' = dflags { hscTarget = HscLlvm } warn = "No native code generator, so using LLVM" in loop dflags' warn diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index d730fe70f1..fe4c9781e2 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1953,7 +1953,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- See Note [-fno-code mode] #8025 map1 <- if hscTarget dflags == HscNothing then enableCodeGenForTH - (defaultObjectTarget (targetPlatform dflags)) + (defaultObjectTarget (settings dflags)) map0 else return map0 return $ concat $ nodeMapElts map1 diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 50cc6d58e5..b3dc60654e 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -259,6 +259,29 @@ initSysTools top_dir platformIsCrossCompiling = crossCompiling } + integerLibrary <- getSetting "integer library" + integerLibraryType <- case integerLibrary of + "integer-gmp" -> pure IntegerGMP + "integer-simple" -> pure IntegerSimple + _ -> pgmError $ unwords + [ "Entry for" + , show "integer library" + , "must be one of" + , show "integer-gmp" + , "or" + , show "integer-simple" + ] + + ghcWithInterpreter <- getBooleanSetting "Use interpreter" + ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator" + ghcWithSMP <- getBooleanSetting "Support SMP" + ghcRTSWays <- getSetting "RTS ways" + leadingUnderscore <- getBooleanSetting "Leading underscore" + useLibFFI <- getBooleanSetting "Use LibFFI" + ghcThreaded <- getBooleanSetting "Use Threads" + ghcDebugged <- getBooleanSetting "Use Debugging" + ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" + return $ Settings { sTargetPlatform = platform, sTmpDir = normalise tmpdir, @@ -306,8 +329,20 @@ initSysTools top_dir sOpt_lc = [], sOpt_i = [], sPlatformConstants = platformConstants, + sTargetPlatformString = targetPlatformString, - sTablesNextToCode = tablesNextToCode + sIntegerLibrary = integerLibrary, + sIntegerLibraryType = integerLibraryType, + sGhcWithInterpreter = ghcWithInterpreter, + sGhcWithNativeCodeGen = ghcWithNativeCodeGen, + sGhcWithSMP = ghcWithSMP, + sGhcRTSWays = ghcRTSWays, + sTablesNextToCode = tablesNextToCode, + sLeadingUnderscore = leadingUnderscore, + sLibFFI = useLibFFI, + sGhcThreaded = ghcThreaded, + sGhcDebugged = ghcDebugged, + sGhcRtsWithLibdw = ghcRtsWithLibdw } @@ -383,10 +418,12 @@ linkDynLib dflags0 o_files dep_packages -- against libHSrts, then both end up getting loaded, -- and things go wrong. We therefore link the libraries -- with the same RTS flags that we link GHC with. - dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 - else dflags0 - dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 - else dflags1 + dflags1 = if sGhcThreaded $ settings dflags0 + then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if sGhcDebugged $ settings dflags1 + then addWay' WayDebug dflags1 + else dflags1 dflags = updateWays dflags2 verbFlags = getVerbFlags dflags diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index c78ea5fcb1..2d0bf30b5e 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -852,7 +852,7 @@ makeImportsDoc dflags imports | otherwise = Outputable.empty - doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) + doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle) astyle = mkCodeStyle AsmStyle -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index b4bf8998d1..69113e8ea5 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -565,19 +565,19 @@ pprGotDeclaration _ _ _ -- pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc -pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl +pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl = case positionIndependent dflags of False -> vcat [ text ".symbol_stub", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\tjmp *L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tjmp *L" <> pprCLabel dflags lbl <> text "$lazy_ptr", - text "L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> text "$stub_binder:", - text "\tpushl $L" <> pprCLabel platform lbl + text "\tpushl $L" <> pprCLabel dflags lbl <> text "$lazy_ptr", text "\tjmp dyld_stub_binding_helper" ] @@ -585,16 +585,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS vcat [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, text "\tcall ___i686.get_pc_thunk.ax", text "1:", - text "\tmovl L" <> pprCLabel platform lbl + text "\tmovl L" <> pprCLabel dflags lbl <> text "$lazy_ptr-1b(%eax),%edx", text "\tjmp *%edx", - text "L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> text "$stub_binder:", - text "\tlea L" <> pprCLabel platform lbl + text "\tlea L" <> pprCLabel dflags lbl <> text "$lazy_ptr-1b(%eax),%eax", text "\tpushl %eax", text "\tjmp dyld_stub_binding_helper" @@ -602,16 +602,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if positionIndependent dflags then int 2 else int 3) <> text ",lazy_symbol_pointers", - text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), - text "\t.indirect_symbol" <+> pprCLabel platform lbl, - text "\t.long L" <> pprCLabel platform lbl + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\t.long L" <> pprCLabel dflags lbl <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl = vcat [ text ".non_lazy_symbol_pointer", - char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", - text "\t.indirect_symbol" <+> pprCLabel platform lbl, + char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:", + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, text "\t.long\t0"] | otherwise @@ -632,12 +632,12 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ -- -- NB: No DSO-support yet -pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl +pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ - text "LC.." <> pprCLabel platform lbl <> char ':', - text "\t.long" <+> pprCLabel platform lbl ] + text "LC.." <> pprCLabel dflags lbl <> char ':', + text "\t.long" <+> pprCLabel dflags lbl ] _ -> empty -- ELF / Linux @@ -669,15 +669,15 @@ pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl -- the NCG will keep track of all DynamicLinkerLabels it uses -- and output each of them using pprImportedSymbol. -pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) +pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ }) importedLbl | osElfTarget (platformOS platform) = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ text ".section \".toc\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - text "\t.quad" <+> pprCLabel platform lbl ] + text ".LC_" <> pprCLabel dflags lbl <> char ':', + text "\t.quad" <+> pprCLabel dflags lbl ] _ -> empty pprImportedSymbol dflags platform importedLbl @@ -691,8 +691,8 @@ pprImportedSymbol dflags platform importedLbl in vcat [ text ".section \".got2\", \"aw\"", - text ".LC_" <> pprCLabel platform lbl <> char ':', - ptext symbolSize <+> pprCLabel platform lbl ] + text ".LC_" <> pprCLabel dflags lbl <> char ':', + ptext symbolSize <+> pprCLabel dflags lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs index 0787978938..2538e76c0a 100644 --- a/hadrian/src/Rules/Generate.hs +++ b/hadrian/src/Rules/Generate.hs @@ -271,47 +271,54 @@ generateGhcPlatformH = do generateSettings :: Expr String generateSettings = do - let flag' = flag >=> \case - True -> pure "YES" - False -> pure "NO" - settings <- (traverse . traverse) expr $ - [ ("GCC extra via C opts", lookupValueOrError configFile "gcc-extra-via-c-opts") - , ("C compiler command", settingsFileSetting SettingsFileSetting_CCompilerCommand) - , ("C compiler flags", settingsFileSetting SettingsFileSetting_CCompilerFlags) - , ("C compiler link flags", settingsFileSetting SettingsFileSetting_CCompilerLinkFlags) - , ("C compiler supports -no-pie", settingsFileSetting SettingsFileSetting_CCompilerSupportsNoPie) - , ("Haskell CPP command", settingsFileSetting SettingsFileSetting_HaskellCPPCommand) - , ("Haskell CPP flags", settingsFileSetting SettingsFileSetting_HaskellCPPFlags) - , ("ld command", settingsFileSetting SettingsFileSetting_LdCommand) - , ("ld flags", settingsFileSetting SettingsFileSetting_LdFlags) - , ("ld supports compact unwind", lookupValueOrError configFile "ld-has-no-compact-unwind") - , ("ld supports build-id", lookupValueOrError configFile "ld-has-build-id") - , ("ld supports filelist", lookupValueOrError configFile "ld-has-filelist") - , ("ld is GNU ld", lookupValueOrError configFile "ld-is-gnu-ld") - , ("ar command", settingsFileSetting SettingsFileSetting_ArCommand) - , ("ar flags", lookupValueOrError configFile "ar-args") - , ("ar supports at file", flag' ArSupportsAtFile) - , ("ranlib command", settingsFileSetting SettingsFileSetting_RanlibCommand) - , ("touch command", settingsFileSetting SettingsFileSetting_TouchCommand) - , ("dllwrap command", settingsFileSetting SettingsFileSetting_DllWrapCommand) - , ("windres command", settingsFileSetting SettingsFileSetting_WindresCommand) - , ("libtool command", settingsFileSetting SettingsFileSetting_LibtoolCommand) - , ("unlit command", ("$topdir/bin/" <>) . takeFileName <$> builderPath Unlit) - , ("cross compiling", flag' CrossCompiling) - , ("target platform string", setting TargetPlatform) - , ("target os", lookupValueOrError configFile "haskell-target-os") - , ("target arch", lookupValueOrError configFile "haskell-target-arch") - , ("target word size", lookupValueOrError configFile "target-word-size") - , ("target has GNU nonexec stack", lookupValueOrError configFile "haskell-have-gnu-nonexec-stack") - , ("target has .ident directive", lookupValueOrError configFile "haskell-have-ident-directive") - , ("target has subsections via symbols", lookupValueOrError configFile "haskell-have-subsections-via-symbols") - , ("target has RTS linker", lookupValueOrError configFile "haskell-have-rts-linker") - , ("Unregisterised", flag' GhcUnregisterised) - , ("LLVM llc command", settingsFileSetting SettingsFileSetting_LlcCommand) - , ("LLVM opt command", settingsFileSetting SettingsFileSetting_OptCommand) - , ("LLVM clang command", settingsFileSetting SettingsFileSetting_ClangCommand) - - , ("Tables next to code", yesNo <$> ghcEnableTablesNextToCode) + settings <- traverse sequence $ + [ ("GCC extra via C opts", expr $ lookupValueOrError configFile "gcc-extra-via-c-opts") + , ("C compiler command", expr $ settingsFileSetting SettingsFileSetting_CCompilerCommand) + , ("C compiler flags", expr $ settingsFileSetting SettingsFileSetting_CCompilerFlags) + , ("C compiler link flags", expr $ settingsFileSetting SettingsFileSetting_CCompilerLinkFlags) + , ("C compiler supports -no-pie", expr $ settingsFileSetting SettingsFileSetting_CCompilerSupportsNoPie) + , ("Haskell CPP command", expr $ settingsFileSetting SettingsFileSetting_HaskellCPPCommand) + , ("Haskell CPP flags", expr $ settingsFileSetting SettingsFileSetting_HaskellCPPFlags) + , ("ld command", expr $ settingsFileSetting SettingsFileSetting_LdCommand) + , ("ld flags", expr $ settingsFileSetting SettingsFileSetting_LdFlags) + , ("ld supports compact unwind", expr $ lookupValueOrError configFile "ld-has-no-compact-unwind") + , ("ld supports build-id", expr $ lookupValueOrError configFile "ld-has-build-id") + , ("ld supports filelist", expr $ lookupValueOrError configFile "ld-has-filelist") + , ("ld is GNU ld", expr $ lookupValueOrError configFile "ld-is-gnu-ld") + , ("ar command", expr $ settingsFileSetting SettingsFileSetting_ArCommand) + , ("ar flags", expr $ lookupValueOrError configFile "ar-args") + , ("ar supports at file", expr $ yesNo <$> flag ArSupportsAtFile) + , ("ranlib command", expr $ settingsFileSetting SettingsFileSetting_RanlibCommand) + , ("touch command", expr $ settingsFileSetting SettingsFileSetting_TouchCommand) + , ("dllwrap command", expr $ settingsFileSetting SettingsFileSetting_DllWrapCommand) + , ("windres command", expr $ settingsFileSetting SettingsFileSetting_WindresCommand) + , ("libtool command", expr $ settingsFileSetting SettingsFileSetting_LibtoolCommand) + , ("unlit command", ("$topdir/bin/" <>) <$> getBuilderPath Unlit) + , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) + , ("target platform string", getSetting TargetPlatform) + , ("target os", expr $ lookupValueOrError configFile "haskell-target-os") + , ("target arch", expr $ lookupValueOrError configFile "haskell-target-arch") + , ("target word size", expr $ lookupValueOrError configFile "target-word-size") + , ("target has GNU nonexec stack", expr $ lookupValueOrError configFile "haskell-have-gnu-nonexec-stack") + , ("target has .ident directive", expr $ lookupValueOrError configFile "haskell-have-ident-directive") + , ("target has subsections via symbols", expr $ lookupValueOrError configFile "haskell-have-subsections-via-symbols") + , ("target has RTS linker", expr $ lookupValueOrError configFile "haskell-have-rts-linker") + , ("Unregisterised", expr $ yesNo <$> flag GhcUnregisterised) + , ("LLVM llc command", expr $ settingsFileSetting SettingsFileSetting_LlcCommand) + , ("LLVM opt command", expr $ settingsFileSetting SettingsFileSetting_OptCommand) + , ("LLVM clang command", expr $ settingsFileSetting SettingsFileSetting_ClangCommand) + + , ("integer library", pkgName <$> getIntegerPackage) + , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter) + , ("Use native code generator", expr $ yesNo <$> ghcWithNativeCodeGen) + , ("Support SMP", expr $ yesNo <$> ghcWithSMP) + , ("RTS ways", expr $ yesNo <$> flag LeadingUnderscore) + , ("Tables next to code", expr $ yesNo <$> ghcEnableTablesNextToCode) + , ("Leading underscore", expr $ yesNo <$> useLibFFIForAdjustors) + , ("Use LibFFI", expr $ yesNo <$> useLibFFIForAdjustors) + , ("Use Threads", yesNo . any (wayUnit Threaded) <$> getRtsWays) + , ("Use Debugging", expr $ yesNo . ghcDebugged <$> flavour) + , ("RTS expects libdw", yesNo <$> getFlag WithLibdw) ] let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of @@ -334,20 +341,6 @@ generateConfigHs = do cProjectPatchLevel1 <- getSetting ProjectPatchLevel1 cProjectPatchLevel2 <- getSetting ProjectPatchLevel2 cBooterVersion <- getSetting GhcVersion - intLib <- getIntegerPackage - debugged <- ghcDebugged <$> expr flavour - let cIntegerLibraryType - | intLib == integerGmp = "IntegerGMP" - | intLib == integerSimple = "IntegerSimple" - | otherwise = error $ "Unknown integer library: " ++ pkgName intLib - cGhcWithInterpreter <- expr $ yesNo <$> ghcWithInterpreter - cGhcWithNativeCodeGen <- expr $ yesNo <$> ghcWithNativeCodeGen - cGhcWithSMP <- expr $ yesNo <$> ghcWithSMP - cLeadingUnderscore <- expr $ yesNo <$> flag LeadingUnderscore - cLibFFI <- expr useLibFFIForAdjustors - rtsWays <- getRtsWays - cGhcRtsWithLibdw <- getFlag WithLibdw - let cGhcRTSWays = unwords $ map show rtsWays return $ unlines [ "{-# LANGUAGE CPP #-}" , "module Config where" @@ -356,10 +349,6 @@ generateConfigHs = do , "" , "#include \"ghc_boot_platform.h\"" , "" - , "data IntegerLibrary = IntegerGMP" - , " | IntegerSimple" - , " deriving Eq" - , "" , "cBuildPlatformString :: String" , "cBuildPlatformString = BuildPlatform_NAME" , "cHostPlatformString :: String" @@ -383,28 +372,7 @@ generateConfigHs = do , "cBooterVersion = " ++ show cBooterVersion , "cStage :: String" , "cStage = show (STAGE :: Int)" - , "cIntegerLibrary :: String" - , "cIntegerLibrary = " ++ show (pkgName intLib) - , "cIntegerLibraryType :: IntegerLibrary" - , "cIntegerLibraryType = " ++ cIntegerLibraryType - , "cGhcWithInterpreter :: String" - , "cGhcWithInterpreter = " ++ show cGhcWithInterpreter - , "cGhcWithNativeCodeGen :: String" - , "cGhcWithNativeCodeGen = " ++ show cGhcWithNativeCodeGen - , "cGhcWithSMP :: String" - , "cGhcWithSMP = " ++ show cGhcWithSMP - , "cGhcRTSWays :: String" - , "cGhcRTSWays = " ++ show cGhcRTSWays - , "cLeadingUnderscore :: String" - , "cLeadingUnderscore = " ++ show cLeadingUnderscore - , "cLibFFI :: Bool" - , "cLibFFI = " ++ show cLibFFI - , "cGhcThreaded :: Bool" - , "cGhcThreaded = " ++ show (any (wayUnit Threaded) rtsWays) - , "cGhcDebugged :: Bool" - , "cGhcDebugged = " ++ show debugged - , "cGhcRtsWithLibdw :: Bool" - , "cGhcRtsWithLibdw = " ++ show cGhcRtsWithLibdw ] + ] -- | Generate @ghcautoconf.h@ header. generateGhcAutoconfH :: Expr String diff --git a/includes/ghc.mk b/includes/ghc.mk index 71941c9d50..2421d9ca96 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -211,8 +211,23 @@ $(includes_SETTINGS) : includes/Makefile | $$(dir $$@)/. @echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@ @echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@ @echo ',("LLVM clang command", "$(SettingsClangCommand)")' >> $@ + @echo + @echo ',("integer library", "$(INTEGER_LIBRARY)")' >> $@ + @echo ',("Use interpreter", "$(GhcWithInterpreter)")' >> $@ + @echo ',("Use native code generator", "$(GhcWithNativeCodeGen)")' >> $@ + @echo ',("Support SMP", "$(GhcWithSMP)")' >> $@ + @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ @echo ',("Tables next to code", "$(GhcEnableTablesNextToCode)")' >> $@ - @echo ']' >> $@ + @echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@ + @echo ',("Use LibFFI", "$(UseLibFFIForAdjustors)")' >> $@ +# Note that GhcThreaded just reflects the Makefile variable setting. In +# particular, the stage1 compiler is never actually compiled with -threaded, but +# it will nevertheless have cGhcThreaded = True. The "+RTS --info" output will +# show what RTS GHC is really using. + @echo ",(\"Use Threads\", \"$(GhcThreaded)\")" >> $@ + @echo ",(\"Use Debugging\", \"$(GhcDebugged)\")" >> $@ + @echo ",(\"RTS expects libdw\", \"$(GhcRtsWithLibdw)\")" >> $@ + @echo "]" >> $@ # --------------------------------------------------------------------------- |