Skip to content
Commits on Source (10)
Hide whitespace changes
Inline Side-by-side
.gitlab-ci.yml
View file @ fbc376db
......@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
DOCKER_REV: ac65f31dcffb09cd7ca7aaa70f447fcbb19f427f
# Sequential version number capturing the versions of all tools fetched by
# .gitlab/win32-init.sh.
......@@ -176,7 +176,7 @@ validate-x86_64-linux-deb8-hadrian:
hadrian-ghc-in-ghci:
<<: *only-default
stage: build
image: ghcci/x86_64-linux-deb8:0.1
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV"
before_script:
# workaround for docker permissions
- sudo chown ghc:ghc -R .
......
aclocal.m4
View file @ fbc376db
......@@ -951,8 +951,8 @@ changequote([, ])dnl
])
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs
then
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.4],
[AC_MSG_ERROR([Happy version 1.19.4 or later is required to compile GHC.])])[]
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.10],
[AC_MSG_ERROR([Happy version 1.19.10 or later is required to compile GHC.])])[]
fi
HappyVersion=$fptools_cv_happy_version;
AC_SUBST(HappyVersion)
......
compiler/cmm/CLabel.hs
View file @ fbc376db
......@@ -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"
......
compiler/coreSyn/CorePrep.hs
View file @ fbc376db
......@@ -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
......
compiler/deSugar/DsForeign.hs
View file @ fbc376db
......@@ -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:
......
compiler/ghc.mk
View file @ fbc376db
......@@ -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.
# -----------------------------------------------------------------------------
......
compiler/hsSyn/HsDecls.hs
View file @ fbc376db
......@@ -679,11 +679,15 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl })
= famDeclHasCusk False fam_decl
hsDeclHasCusk
:: Bool -- True <=> the -XCUSKs extension is enabled
-> TyClDecl GhcRn
-> Bool
hsDeclHasCusk _cusks_enabled@False _ = False
hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl })
= famDeclHasCusk cusks_enabled False fam_decl
-- False: this is not: an associated type of a class with no cusk
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
hsDeclHasCusk _cusks_enabled@True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
......@@ -691,9 +695,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
HsParTy _ lty -> rhs_annotated lty
HsKindSig {} -> True
_ -> False
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk"
hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk _ (XTyClDecl _) = panic "hsDeclHasCusk"
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -787,6 +791,10 @@ declaration before checking all of the others, supporting polymorphic recursion.
See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy
and #9200 for lots of discussion of how we got here.
The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.
Under -XNoCUSKs, all declarations are treated as if they have no CUSK.
See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst
PRINCIPLE:
a type declaration has a CUSK iff we could produce a separate kind signature
for it, just like a type signature for a function,
......@@ -1080,11 +1088,13 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family,
famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled
-> Bool -- ^ True <=> this is an associated type family,
-- and the parent class has /no/ CUSK
-> FamilyDecl pass
-> Bool
famDeclHasCusk assoc_with_no_cusk
famDeclHasCusk _cusks_enabled@False _ _ = False
famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
......@@ -1095,7 +1105,7 @@ famDeclHasCusk assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does
famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk"
famDeclHasCusk _ _ (XFamilyDecl {}) = panic "famDeclHasCusk"
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......
compiler/llvmGen/LlvmCodeGen/Base.hs
View file @ fbc376db
......@@ -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
......
compiler/main/CodeOutput.hs
View file @ fbc376db
......@@ -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
......
compiler/main/DriverPipeline.hs
View file @ fbc376db
......@@ -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
......
compiler/main/DynFlags.hs
View file @ fbc376db
......@@ -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,
......@@ -2260,6 +2279,7 @@ languageExtensions (Just Haskell98)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.CUSKs,
LangExt.MonomorphismRestriction,
LangExt.NPlusKPatterns,
LangExt.DatatypeContexts,
......@@ -2276,6 +2296,7 @@ languageExtensions (Just Haskell2010)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
LangExt.CUSKs,
LangExt.MonomorphismRestriction,
LangExt.DatatypeContexts,
LangExt.TraditionalRecordSyntax,
......@@ -3704,7 +3725,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"
......@@ -4358,6 +4379,7 @@ xFlagsDeps = [
flagSpec "BinaryLiterals" LangExt.BinaryLiterals,
flagSpec "CApiFFI" LangExt.CApiFFI,
flagSpec "CPP" LangExt.Cpp,
flagSpec "CUSKs" LangExt.CUSKs,
flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods,
flagSpec "ConstraintKinds" LangExt.ConstraintKinds,
flagSpec "DataKinds" LangExt.DataKinds,
......@@ -5386,12 +5408,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 +5645,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 +5678,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 +5769,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 +5785,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
......
compiler/main/GhcMake.hs
View file @ fbc376db
......@@ -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
......
compiler/main/SysTools.hs
View file @ fbc376db
......@@ -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
......
compiler/nativeGen/AsmCodeGen.hs
View file @ fbc376db
......@@ -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
-- -----------------------------------------------------------------------------
......
compiler/nativeGen/PIC.hs
View file @ fbc376db
......@@ -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
......
compiler/rename/RnSource.hs
View file @ fbc376db
......@@ -1552,7 +1552,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn
-- See Note [Complete user-supplied kind signatures] in HsDecls
; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs
; cusks_enabled <- xoptM LangExt.CUSKs
; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs
rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
......
compiler/typecheck/TcTyClsDecls.hs
View file @ fbc376db
......@@ -510,8 +510,9 @@ kcTyClGroup decls
-- 3. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls]
; cusks_enabled <- xoptM LangExt.CUSKs
; let (cusk_decls, no_cusk_decls)
= partition (hsDeclHasCusk . unLoc) decls
= partition (hsDeclHasCusk cusks_enabled . unLoc) decls
; poly_cusk_tcs <- getInitialKinds True cusk_decls
......@@ -1040,17 +1041,25 @@ getInitialKind cusk (FamDecl { tcdFam = decl })
getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
, tcdTyVars = ktvs
, tcdRhs = rhs })
= do { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
case kind_annotation rhs of
= do { cusks_enabled <- xoptM LangExt.CUSKs
; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
case kind_annotation cusks_enabled rhs of
Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
Nothing -> newMetaKindVar
Nothing -> newMetaKindVar
; return [tycon] }
where
-- Keep this synchronized with 'hsDeclHasCusk'.
kind_annotation (dL->L _ ty) = case ty of
HsParTy _ lty -> kind_annotation lty
HsKindSig _ _ k -> Just k
_ -> Nothing
kind_annotation
:: Bool -- cusks_enabled?
-> LHsType GhcRn -- rhs
-> Maybe (LHsKind GhcRn)
kind_annotation False = const Nothing
kind_annotation True = go
where
go (dL->L _ ty) = case ty of
HsParTy _ lty -> go lty
HsKindSig _ _ k -> Just k
_ -> Nothing
getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
......@@ -1074,18 +1083,20 @@ getFamDeclInitialKind parent_cusk mb_parent_tycon
, fdTyVars = ktvs
, fdResultSig = (dL->L _ resultSig)
, fdInfo = info })
= kcLHsQTyVars name flav fam_cusk ktvs $
case resultSig of
KindSig _ ki -> tcLHsKindSig ctxt ki
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
_ -- open type families have * return kind by default
| tcFlavourIsOpen flav -> return liftedTypeKind
-- closed type families have their return kind inferred
-- by default
| otherwise -> newMetaKindVar
= do { cusks_enabled <- xoptM LangExt.CUSKs
; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $
case resultSig of
KindSig _ ki -> tcLHsKindSig ctxt ki
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
_ -- open type families have * return kind by default
| tcFlavourIsOpen flav -> return liftedTypeKind
-- closed type families have their return kind inferred
-- by default
| otherwise -> newMetaKindVar
}
where
assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk
fam_cusk = famDeclHasCusk assoc_with_no_cusk decl
fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl
flav = case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
......
docs/users_guide/glasgow_exts.rst
View file @ fbc376db
......@@ -9012,6 +9012,11 @@ do so.
Complete user-supplied kind signatures and polymorphic recursion
----------------------------------------------------------------
 
.. extension:: CUSKs
:shortdesc: Enable detection of complete user-supplied kind signatures.
:since: 8.10.1
Just as in type inference, kind inference for recursive types can only
use *monomorphic* recursion. Consider this (contrived) example: ::
 
......@@ -9110,6 +9115,13 @@ example, consider ::
According to the rules above ``X`` has a CUSK. Yet, the kind of ``k`` is undetermined.
It is thus quantified over, giving ``X`` the kind ``forall k1 (k :: k1). Proxy k -> Type``.
 
The detection of CUSKs is enabled by the :extension:`CUSKs` flag, which is
switched on by default. When :extension:`CUSKs` is switched off, there is
currently no way to enable polymorphic recursion in types. In the future, the
notion of a CUSK will be replaced by top-level kind signatures
(`GHC Proposal #36 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst>`__),
then, after a transition period, this extension will be turned off by default, and eventually removed.
Kind inference in closed type families
--------------------------------------
 
......
hadrian/doc/user-settings.md
View file @ fbc376db
......@@ -88,7 +88,7 @@ userArgs :: Args
userArgs = builder Ghc ? package cabal ? arg "-O0"
```
Builders such as `Ghc` are defined in `src/Builder.hs`, and all packages that
are currently built as part of the GHC are defined in `src/GHC.hs`.
are currently built as part of the GHC are defined in `src/Packages.hs`.
You can combine several custom command line settings using `mconcat`:
```haskell
......
hadrian/hadrian.cabal
View file @ fbc376db
......@@ -132,7 +132,7 @@ executable hadrian
, transformers >= 0.4 && < 0.6
, unordered-containers >= 0.2.1 && < 0.3
build-tools: alex >= 3.1
, happy >= 1.19.4
, happy >= 1.19.10
ghc-options: -Wall
-Wincomplete-record-updates
-Wredundant-constraints
......