Skip to content
Commits on Source (9)
  • KevinBuhr's avatar
    Add regression test for old parser issue #504 · 357be128
    KevinBuhr authored and Ben Gamari's avatar Ben Gamari committed
    357be128
  • John Ericson's avatar
    hadrian: Make settings stage specific · 015a21b8
    John Ericson authored and Ben Gamari's avatar Ben Gamari committed
    015a21b8
  • John Ericson's avatar
    Dont refer to `cLeadingUnderscore` in test · f9e4ea40
    John Ericson authored and Ben Gamari's avatar Ben Gamari committed
    Can't use this config entry because it's about to go away
    f9e4ea40
  • John Ericson's avatar
    Remove all target-specific portions of Config.hs · e529c65e
    John Ericson authored and Ben Gamari's avatar Ben Gamari committed
    1. If GHC is to be multi-target, these cannot be baked in at compile
       time.
    
    2. Compile-time flags have a higher maintenance than run-time flags.
    
    3. The old way makes build system implementation (various bootstrapping
       details) with the thing being built. E.g. GHC doesn't need to care
       about which integer library *will* be used---this is purely a crutch
       so the build system doesn't need to pass flags later when using that
       library.
    
    4. Experience with cross compilation in Nixpkgs has shown things work
       nicer when compiler's can *optionally* delegate the bootstrapping the
       package manager. The package manager knows the entire end-goal build
       plan, and thus can make top-down decisions on bootstrapping. GHC can
       just worry about GHC, not even core library like base and ghc-prim!
    e529c65e
  • Oleg Grenrus's avatar
    Update terminal title while running test-suite · 5cf8032e
    Oleg Grenrus authored and Ben Gamari's avatar Ben Gamari committed
    Useful progress indicator even when `make test VERBOSE=1`,
    and when you do something else, but have terminal title visible.
    5cf8032e
  • Vladislav Zavialov's avatar
    Add a minimized regression test for #12928 · c72c369b
    Vladislav Zavialov authored and Ben Gamari's avatar Ben Gamari committed
    c72c369b
  • Vladislav Zavialov's avatar
    Guard CUSKs behind a language pragma · a5fdd185
    Vladislav Zavialov authored and Ben Gamari's avatar Ben Gamari committed
    GHC Proposal #36 describes a transition plan away from CUSKs and to
    top-level kind signatures:
    
    1. Introduce a new extension, -XCUSKs, on by default, that detects CUSKs
       as they currently exist.
    2. We turn off the -XCUSKs extension in a few releases and remove it
       sometime thereafter.
    
    This patch implements phase 1 of this plan, introducing a new language
    extension to control whether CUSKs are enabled. When top-level kind
    signatures are implemented, we can transition to phase 2.
    a5fdd185
  • Vladislav Zavialov's avatar
    Restore the --coerce option in 'happy' configuration · 684dc290
    Vladislav Zavialov authored and Ben Gamari's avatar Ben Gamari committed
    happy-1.19.10 has been released with a fix for --coerce in the presence
    of higher rank types. This should result in about 10% performance
    improvement in the parser.
    684dc290
  • Alp Mestanogullari's avatar
    Hadrian: 'need' source files for various docs in Rules.Documentation · a416ae26
    Alp Mestanogullari authored and Ben Gamari's avatar Ben Gamari committed
    Previously, changing one of the .rst files from the user guide would not cause
    the user guide to be rebuilt. This patch take a first stab at declaring the
    documentation source files that our documentation rules depend on, focusing
    on the .rst files only for now.
    
    We eventually might want to rebuild docs when we, say, change the haddock style
    file, but this level of tracking isn't really necessary for now.
    
    This fixes #16645.
    a416ae26
...@@ -2,7 +2,7 @@ variables: ...@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1" GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images # 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 # Sequential version number capturing the versions of all tools fetched by
# .gitlab/win32-init.sh. # .gitlab/win32-init.sh.
...@@ -176,7 +176,7 @@ validate-x86_64-linux-deb8-hadrian: ...@@ -176,7 +176,7 @@ validate-x86_64-linux-deb8-hadrian:
hadrian-ghc-in-ghci: hadrian-ghc-in-ghci:
<<: *only-default <<: *only-default
stage: build 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: before_script:
# workaround for docker permissions # workaround for docker permissions
- sudo chown ghc:ghc -R . - sudo chown ghc:ghc -R .
......
...@@ -951,8 +951,8 @@ changequote([, ])dnl ...@@ -951,8 +951,8 @@ changequote([, ])dnl
]) ])
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs
then then
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.4], FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.10],
[AC_MSG_ERROR([Happy version 1.19.4 or later is required to compile GHC.])])[] [AC_MSG_ERROR([Happy version 1.19.10 or later is required to compile GHC.])])[]
fi fi
HappyVersion=$fptools_cv_happy_version; HappyVersion=$fptools_cv_happy_version;
AC_SUBST(HappyVersion) AC_SUBST(HappyVersion)
......
...@@ -120,7 +120,6 @@ import Module ...@@ -120,7 +120,6 @@ import Module
import Name import Name
import Unique import Unique
import PrimOp import PrimOp
import Config
import CostCentre import CostCentre
import Outputable import Outputable
import FastString import FastString
...@@ -1151,35 +1150,35 @@ and are not externally visible. ...@@ -1151,35 +1150,35 @@ and are not externally visible.
-} -}
instance Outputable CLabel where 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) pprCLabel _ (LocalBlockLabel u)
= tempLabelPrefixOrUnderscore <> pprUniqueAlways u = tempLabelPrefixOrUnderscore <> pprUniqueAlways u
pprCLabel platform (AsmTempLabel u) pprCLabel dynFlags (AsmTempLabel u)
| not (platformUnregisterised platform) | not (platformUnregisterised $ targetPlatform dynFlags)
= tempLabelPrefixOrUnderscore <> pprUniqueAlways u = tempLabelPrefixOrUnderscore <> pprUniqueAlways u
pprCLabel platform (AsmTempDerivedLabel l suf) pprCLabel dynFlags (AsmTempDerivedLabel l suf)
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dynFlags
= ptext (asmTempLabelPrefix platform) = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)
<> case l of AsmTempLabel u -> pprUniqueAlways u <> case l of AsmTempLabel u -> pprUniqueAlways u
LocalBlockLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u
_other -> pprCLabel platform l _other -> pprCLabel dynFlags l
<> ftext suf <> ftext suf
pprCLabel platform (DynamicLinkerLabel info lbl) pprCLabel dynFlags (DynamicLinkerLabel info lbl)
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dynFlags
= pprDynamicLinkerAsmLabel platform info lbl = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl
pprCLabel _ PicBaseLabel pprCLabel dynFlags PicBaseLabel
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dynFlags
= text "1b" = text "1b"
pprCLabel platform (DeadStripPreventer lbl) pprCLabel dynFlags (DeadStripPreventer lbl)
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dynFlags
= =
{- {-
`lbl` can be temp one but we need to ensure that dsp label will stay `lbl` can be temp one but we need to ensure that dsp label will stay
...@@ -1187,23 +1186,24 @@ pprCLabel platform (DeadStripPreventer lbl) ...@@ -1187,23 +1186,24 @@ pprCLabel platform (DeadStripPreventer lbl)
optional `_` (underscore) because this is how you mark non-temp symbols optional `_` (underscore) because this is how you mark non-temp symbols
on some platforms (Darwin) on some platforms (Darwin)
-} -}
maybe_underscore $ text "dsp_" maybe_underscore dynFlags $ text "dsp_"
<> pprCLabel platform lbl <> text "_dsp" <> pprCLabel dynFlags lbl <> text "_dsp"
pprCLabel _ (StringLitLabel u) pprCLabel dynFlags (StringLitLabel u)
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dynFlags
= pprUniqueAlways u <> ptext (sLit "_str") = pprUniqueAlways u <> ptext (sLit "_str")
pprCLabel platform lbl pprCLabel dynFlags lbl
= getPprStyle $ \ sty -> = getPprStyle $ \ sty ->
if cGhcWithNativeCodeGen == "YES" && asmStyle sty if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty
then maybe_underscore (pprAsmCLbl platform lbl) then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl
else pprCLbl lbl else pprCLbl lbl
maybe_underscore :: SDoc -> SDoc maybe_underscore :: DynFlags -> SDoc -> SDoc
maybe_underscore doc maybe_underscore dynFlags doc =
| underscorePrefix = pp_cSEP <> doc if sLeadingUnderscore $ settings dynFlags
| otherwise = doc then pp_cSEP <> doc
else doc
pprAsmCLbl :: Platform -> CLabel -> SDoc pprAsmCLbl :: Platform -> CLabel -> SDoc
pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _) pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
...@@ -1363,9 +1363,6 @@ tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> ...@@ -1363,9 +1363,6 @@ tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels. -- Machine-dependent knowledge about labels.
underscorePrefix :: Bool -- leading underscore on assembler labels?
underscorePrefix = (cLeadingUnderscore == "YES")
asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels
asmTempLabelPrefix platform = case platformOS platform of asmTempLabelPrefix platform = case platformOS platform of
OSDarwin -> sLit "L" OSDarwin -> sLit "L"
......
...@@ -55,7 +55,6 @@ import Pair ...@@ -55,7 +55,6 @@ import Pair
import Outputable import Outputable
import Platform import Platform
import FastString import FastString
import Config
import Name ( NamedThing(..), nameSrcSpan ) import Name ( NamedThing(..), nameSrcSpan )
import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import Data.Bits import Data.Bits
......
...@@ -50,7 +50,6 @@ import Outputable ...@@ -50,7 +50,6 @@ import Outputable
import FastString import FastString
import DynFlags import DynFlags
import Platform import Platform
import Config
import OrdList import OrdList
import Pair import Pair
import Util import Util
...@@ -542,7 +541,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc ...@@ -542,7 +541,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
| otherwise = text ('a':show n) | otherwise = text ('a':show n)
-- generate a libffi-style stub if this is a "wrapper" and libffi is enabled -- 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 type_string
-- libffi needs to know the result type too: -- libffi needs to know the result type too:
......
...@@ -55,10 +55,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. ...@@ -55,10 +55,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo >> $@ @echo >> $@
@echo '#include "ghc_boot_platform.h"' >> $@ @echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@ @echo >> $@
@echo 'data IntegerLibrary = IntegerGMP' >> $@
@echo ' | IntegerSimple' >> $@
@echo ' deriving Eq' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@ @echo 'cBuildPlatformString :: String' >> $@
@echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@
@echo 'cHostPlatformString :: String' >> $@ @echo 'cHostPlatformString :: String' >> $@
...@@ -82,52 +78,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. ...@@ -82,52 +78,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo 'cBooterVersion = "$(GhcVersion)"' >> $@ @echo 'cBooterVersion = "$(GhcVersion)"' >> $@
@echo 'cStage :: String' >> $@ @echo 'cStage :: String' >> $@
@echo 'cStage = show (STAGE :: Int)' >> $@ @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. @echo done.
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
......
...@@ -679,11 +679,15 @@ countTyClDecls decls ...@@ -679,11 +679,15 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature? -- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures] -- See Note [CUSKs: complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl GhcRn -> Bool hsDeclHasCusk
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) :: Bool -- True <=> the -XCUSKs extension is enabled
= famDeclHasCusk False fam_decl -> 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 -- 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' -- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs = hsTvbAllKinded tyvars && rhs_annotated rhs
where where
...@@ -691,9 +695,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) ...@@ -691,9 +695,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
HsParTy _ lty -> rhs_annotated lty HsParTy _ lty -> rhs_annotated lty
HsKindSig {} -> True HsKindSig {} -> True
_ -> False _ -> False
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" hsDeclHasCusk _ (XTyClDecl _) = panic "hsDeclHasCusk"
-- Pretty-printing TyClDecl -- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -787,6 +791,10 @@ declaration before checking all of the others, supporting polymorphic recursion. ...@@ -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 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. 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: PRINCIPLE:
a type declaration has a CUSK iff we could produce a separate kind signature a type declaration has a CUSK iff we could produce a separate kind signature
for it, just like a type signature for a function, for it, just like a type signature for a function,
...@@ -1080,11 +1088,13 @@ data FamilyInfo pass ...@@ -1080,11 +1088,13 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature? -- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures] -- 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 -- and the parent class has /no/ CUSK
-> FamilyDecl pass -> FamilyDecl pass
-> Bool -> Bool
famDeclHasCusk assoc_with_no_cusk famDeclHasCusk _cusks_enabled@False _ _ = False
famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info (FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars , fdTyVars = tyvars
, fdResultSig = L _ resultSig }) , fdResultSig = L _ resultSig })
...@@ -1095,7 +1105,7 @@ famDeclHasCusk assoc_with_no_cusk ...@@ -1095,7 +1105,7 @@ famDeclHasCusk assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs -- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does -- 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? -- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool hasReturnKindSignature :: FamilyResultSig a -> Bool
......
...@@ -390,17 +390,15 @@ ghcInternalFunctions = do ...@@ -390,17 +390,15 @@ ghcInternalFunctions = do
-- | Pretty print a 'CLabel'. -- | Pretty print a 'CLabel'.
strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do strCLabel_llvm lbl = do
platform <- getLlvmPlatform
dflags <- getDynFlags dflags <- getDynFlags
let sdoc = pprCLabel platform lbl let sdoc = pprCLabel dflags lbl
str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
return (fsLit str) return (fsLit str)
strDisplayName_llvm :: CLabel -> LlvmM LMString strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm lbl = do strDisplayName_llvm lbl = do
platform <- getLlvmPlatform
dflags <- getDynFlags dflags <- getDynFlags
let sdoc = pprCLabel platform lbl let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1 depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style str = Outp.renderWithStyle dflags sdoc style
...@@ -416,9 +414,8 @@ dropInfoSuffix = go ...@@ -416,9 +414,8 @@ dropInfoSuffix = go
strProcedureName_llvm :: CLabel -> LlvmM LMString strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm lbl = do strProcedureName_llvm lbl = do
platform <- getLlvmPlatform
dflags <- getDynFlags dflags <- getDynFlags
let sdoc = pprCLabel platform lbl let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1 depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.neverQualify depth style = Outp.mkUserStyle dflags Outp.neverQualify depth
str = Outp.renderWithStyle dflags sdoc style str = Outp.renderWithStyle dflags sdoc style
......
...@@ -24,7 +24,6 @@ import Packages ...@@ -24,7 +24,6 @@ import Packages
import Cmm ( RawCmmGroup ) import Cmm ( RawCmmGroup )
import HscTypes import HscTypes
import DynFlags import DynFlags
import Config
import Stream (Stream) import Stream (Stream)
import qualified Stream import qualified Stream
import FileCleanup import FileCleanup
...@@ -156,7 +155,7 @@ outputAsm :: DynFlags -> Module -> ModLocation -> FilePath ...@@ -156,7 +155,7 @@ outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
-> IO () -> IO ()
outputAsm dflags this_mod location filenm cmm_stream outputAsm dflags this_mod location filenm cmm_stream
| cGhcWithNativeCodeGen == "YES" | sGhcWithNativeCodeGen $ settings dflags
= do ncg_uniqs <- mkSplitUniqSupply 'n' = do ncg_uniqs <- mkSplitUniqSupply 'n'
debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
...@@ -226,8 +225,9 @@ outputForeignStubs dflags mod location stubs ...@@ -226,8 +225,9 @@ outputForeignStubs dflags mod location stubs
mk_include i = "#include \"" ++ i ++ "\"\n" mk_include i = "#include \"" ++ i ++ "\"\n"
-- wrapper code mentions the ffi_arg type, which comes from ffi.h -- wrapper code mentions the ffi_arg type, which comes from ffi.h
ffi_includes | cLibFFI = "#include \"ffi.h\"\n" ffi_includes
| otherwise = "" | sLibFFI $ settings dflags = "#include \"ffi.h\"\n"
| otherwise = ""
stub_h_file_exists stub_h_file_exists
<- outputForeignStubs_help stub_h stub_h_output_w <- outputForeignStubs_help stub_h stub_h_output_w
......
...@@ -49,7 +49,6 @@ import Outputable ...@@ -49,7 +49,6 @@ import Outputable
import Module import Module
import ErrUtils import ErrUtils
import DynFlags import DynFlags
import Config
import Panic import Panic
import Util import Util
import StringBuffer ( hGetStringBuffer ) import StringBuffer ( hGetStringBuffer )
...@@ -369,7 +368,7 @@ link ghcLink dflags ...@@ -369,7 +368,7 @@ link ghcLink dflags
= lookupHook linkHook l dflags ghcLink dflags = lookupHook linkHook l dflags ghcLink dflags
where where
l LinkInMemory _ _ _ l LinkInMemory _ _ _
= if cGhcWithInterpreter == "YES" = if sGhcWithInterpreter $ settings dflags
then -- Not Linking...(demand linker will do the job) then -- Not Linking...(demand linker will do the job)
return Succeeded return Succeeded
else panicBadLink LinkInMemory else panicBadLink LinkInMemory
......
...@@ -87,6 +87,7 @@ module DynFlags ( ...@@ -87,6 +87,7 @@ module DynFlags (
-- ** System tool settings and locations -- ** System tool settings and locations
Settings(..), Settings(..),
IntegerLibrary(..),
targetPlatform, programName, projectVersion, targetPlatform, programName, projectVersion,
ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
versionedAppDir, versionedAppDir,
...@@ -1302,6 +1303,11 @@ type LlvmTargets = [(String, LlvmTarget)] ...@@ -1302,6 +1303,11 @@ type LlvmTargets = [(String, LlvmTarget)]
type LlvmPasses = [(Int, String)] type LlvmPasses = [(Int, String)]
type LlvmConfig = (LlvmTargets, LlvmPasses) type LlvmConfig = (LlvmTargets, LlvmPasses)
data IntegerLibrary
= IntegerGMP
| IntegerSimple
deriving (Read, Show, Eq)
data Settings = Settings { data Settings = Settings {
sTargetPlatform :: Platform, -- Filled in by SysTools sTargetPlatform :: Platform, -- Filled in by SysTools
sGhcUsagePath :: FilePath, -- ditto sGhcUsagePath :: FilePath, -- ditto
...@@ -1358,7 +1364,18 @@ data Settings = Settings { ...@@ -1358,7 +1364,18 @@ data Settings = Settings {
-- Formerly Config.hs, target specific -- Formerly Config.hs, target specific
sTargetPlatformString :: String, -- TODO Recalculate string from richer info? 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 targetPlatform :: DynFlags -> Platform
...@@ -1615,16 +1632,18 @@ instance Outputable PackageFlag where ...@@ -1615,16 +1632,18 @@ instance Outputable PackageFlag where
ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)
ppr (HidePackage str) = text "-hide-package" <+> text str ppr (HidePackage str) = text "-hide-package" <+> text str
defaultHscTarget :: Platform -> HscTarget defaultHscTarget :: Settings -> HscTarget
defaultHscTarget = defaultObjectTarget defaultHscTarget = defaultObjectTarget
-- | The 'HscTarget' value corresponding to the default way to create -- | The 'HscTarget' value corresponding to the default way to create
-- object files on the current platform. -- object files on the current platform.
defaultObjectTarget :: Platform -> HscTarget defaultObjectTarget :: Settings -> HscTarget
defaultObjectTarget platform defaultObjectTarget settings
| platformUnregisterised platform = HscC | platformUnregisterised platform = HscC
| cGhcWithNativeCodeGen == "YES" = HscAsm | sGhcWithNativeCodeGen settings = HscAsm
| otherwise = HscLlvm | otherwise = HscLlvm
where
platform = sTargetPlatform settings
-- Determines whether we will be compiling -- Determines whether we will be compiling
-- info tables that reside just before the entry code, or with an -- info tables that reside just before the entry code, or with an
...@@ -1887,8 +1906,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = ...@@ -1887,8 +1906,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
DynFlags { DynFlags {
ghcMode = CompManager, ghcMode = CompManager,
ghcLink = LinkBinary, ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings), hscTarget = defaultHscTarget mySettings,
integerLibrary = cIntegerLibraryType, integerLibrary = sIntegerLibraryType mySettings,
verbosity = 0, verbosity = 0,
optLevel = 0, optLevel = 0,
debugLevel = 0, debugLevel = 0,
...@@ -2260,6 +2279,7 @@ languageExtensions (Just Haskell98) ...@@ -2260,6 +2279,7 @@ languageExtensions (Just Haskell98)
= [LangExt.ImplicitPrelude, = [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled] -- See Note [When is StarIsType enabled]
LangExt.StarIsType, LangExt.StarIsType,
LangExt.CUSKs,
LangExt.MonomorphismRestriction, LangExt.MonomorphismRestriction,
LangExt.NPlusKPatterns, LangExt.NPlusKPatterns,
LangExt.DatatypeContexts, LangExt.DatatypeContexts,
...@@ -2276,6 +2296,7 @@ languageExtensions (Just Haskell2010) ...@@ -2276,6 +2296,7 @@ languageExtensions (Just Haskell2010)
= [LangExt.ImplicitPrelude, = [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled] -- See Note [When is StarIsType enabled]
LangExt.StarIsType, LangExt.StarIsType,
LangExt.CUSKs,
LangExt.MonomorphismRestriction, LangExt.MonomorphismRestriction,
LangExt.DatatypeContexts, LangExt.DatatypeContexts,
LangExt.TraditionalRecordSyntax, LangExt.TraditionalRecordSyntax,
...@@ -3704,7 +3725,7 @@ dynamic_flags_deps = [ ...@@ -3704,7 +3725,7 @@ dynamic_flags_deps = [
, make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d ->
d { ghcLink=NoLink }) >> setTarget HscNothing)) d { ghcLink=NoLink }) >> setTarget HscNothing))
, make_ord_flag defFlag "fbyte-code" (NoArg (setTarget HscInterpreted)) , 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)) defaultHscTarget))
, make_dep_flag defFlag "fglasgow-exts" , make_dep_flag defFlag "fglasgow-exts"
(NoArg enableGlasgowExts) "Use individual extensions instead" (NoArg enableGlasgowExts) "Use individual extensions instead"
...@@ -4358,6 +4379,7 @@ xFlagsDeps = [ ...@@ -4358,6 +4379,7 @@ xFlagsDeps = [
flagSpec "BinaryLiterals" LangExt.BinaryLiterals, flagSpec "BinaryLiterals" LangExt.BinaryLiterals,
flagSpec "CApiFFI" LangExt.CApiFFI, flagSpec "CApiFFI" LangExt.CApiFFI,
flagSpec "CPP" LangExt.Cpp, flagSpec "CPP" LangExt.Cpp,
flagSpec "CUSKs" LangExt.CUSKs,
flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods,
flagSpec "ConstraintKinds" LangExt.ConstraintKinds, flagSpec "ConstraintKinds" LangExt.ConstraintKinds,
flagSpec "DataKinds" LangExt.DataKinds, flagSpec "DataKinds" LangExt.DataKinds,
...@@ -5386,12 +5408,12 @@ interpretPackageEnv dflags = do ...@@ -5386,12 +5408,12 @@ interpretPackageEnv dflags = do
-- If we're linking a binary, then only targets that produce object -- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored). -- code are allowed (requests for other target types are ignored).
setTarget :: HscTarget -> DynP () setTarget :: HscTarget -> DynP ()
setTarget l = setTargetWithPlatform (const l) setTarget l = setTargetWithSettings (const l)
setTargetWithPlatform :: (Platform -> HscTarget) -> DynP () setTargetWithSettings :: (Settings -> HscTarget) -> DynP ()
setTargetWithPlatform f = upd set setTargetWithSettings f = upd set
where where
set dfs = let l = f (targetPlatform dfs) set dfs = let l = f (settings dfs)
in if ghcLink dfs /= LinkBinary || isObjectTarget l in if ghcLink dfs /= LinkBinary || isObjectTarget l
then dfs{ hscTarget = l } then dfs{ hscTarget = l }
else dfs else dfs
...@@ -5623,13 +5645,13 @@ compilerInfo dflags ...@@ -5623,13 +5645,13 @@ compilerInfo dflags
("Build platform", cBuildPlatformString), ("Build platform", cBuildPlatformString),
("Host platform", cHostPlatformString), ("Host platform", cHostPlatformString),
("Target platform", sTargetPlatformString $ settings dflags), ("Target platform", sTargetPlatformString $ settings dflags),
("Have interpreter", cGhcWithInterpreter), ("Have interpreter", showBool $ sGhcWithInterpreter $ settings dflags),
("Object splitting supported", showBool False), ("Object splitting supported", showBool False),
("Have native code generator", cGhcWithNativeCodeGen), ("Have native code generator", showBool $ sGhcWithNativeCodeGen $ settings dflags),
("Support SMP", cGhcWithSMP), ("Support SMP", showBool $ sGhcWithSMP $ settings dflags),
("Tables next to code", showBool $ sTablesNextToCode $ settings dflags), ("Tables next to code", showBool $ sTablesNextToCode $ settings dflags),
("RTS ways", cGhcRTSWays), ("RTS ways", sGhcRTSWays $ settings dflags),
("RTS expects libdw", showBool cGhcRtsWithLibdw), ("RTS expects libdw", showBool $ sGhcRtsWithLibdw $ settings dflags),
-- Whether or not we support @-dynamic-too@ -- Whether or not we support @-dynamic-too@
("Support dynamic-too", showBool $ not isWindows), ("Support dynamic-too", showBool $ not isWindows),
-- Whether or not we support the @-j@ flag with @--make@. -- Whether or not we support the @-j@ flag with @--make@.
...@@ -5656,7 +5678,7 @@ compilerInfo dflags ...@@ -5656,7 +5678,7 @@ compilerInfo dflags
("GHC Dynamic", showBool dynamicGhc), ("GHC Dynamic", showBool dynamicGhc),
-- Whether or not GHC was compiled using -prof -- Whether or not GHC was compiled using -prof
("GHC Profiled", showBool rtsIsProfiled), ("GHC Profiled", showBool rtsIsProfiled),
("Leading underscore", cLeadingUnderscore), ("Leading underscore", showBool $ sLeadingUnderscore $ settings dflags),
("Debug on", show debugIsOn), ("Debug on", show debugIsOn),
("LibDir", topDir dflags), ("LibDir", topDir dflags),
-- The path of the global package database used by GHC -- The path of the global package database used by GHC
...@@ -5747,7 +5769,7 @@ makeDynFlagsConsistent dflags ...@@ -5747,7 +5769,7 @@ makeDynFlagsConsistent dflags
in loop dflags' warn in loop dflags' warn
| hscTarget dflags == HscC && | hscTarget dflags == HscC &&
not (platformUnregisterised (targetPlatform dflags)) not (platformUnregisterised (targetPlatform dflags))
= if cGhcWithNativeCodeGen == "YES" = if sGhcWithNativeCodeGen $ settings dflags
then let dflags' = dflags { hscTarget = HscAsm } then let dflags' = dflags { hscTarget = HscAsm }
warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" warn = "Compiler not unregisterised, so using native code generator rather than compiling via C"
in loop dflags' warn in loop dflags' warn
...@@ -5763,7 +5785,7 @@ makeDynFlagsConsistent dflags ...@@ -5763,7 +5785,7 @@ makeDynFlagsConsistent dflags
= loop (dflags { hscTarget = HscC }) = loop (dflags { hscTarget = HscC })
"Compiler unregisterised, so compiling via C" "Compiler unregisterised, so compiling via C"
| hscTarget dflags == HscAsm && | hscTarget dflags == HscAsm &&
cGhcWithNativeCodeGen /= "YES" not (sGhcWithNativeCodeGen $ settings dflags)
= let dflags' = dflags { hscTarget = HscLlvm } = let dflags' = dflags { hscTarget = HscLlvm }
warn = "No native code generator, so using LLVM" warn = "No native code generator, so using LLVM"
in loop dflags' warn in loop dflags' warn
......
...@@ -1953,7 +1953,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots ...@@ -1953,7 +1953,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- See Note [-fno-code mode] #8025 -- See Note [-fno-code mode] #8025
map1 <- if hscTarget dflags == HscNothing map1 <- if hscTarget dflags == HscNothing
then enableCodeGenForTH then enableCodeGenForTH
(defaultObjectTarget (targetPlatform dflags)) (defaultObjectTarget (settings dflags))
map0 map0
else return map0 else return map0
return $ concat $ nodeMapElts map1 return $ concat $ nodeMapElts map1
......
...@@ -259,6 +259,29 @@ initSysTools top_dir ...@@ -259,6 +259,29 @@ initSysTools top_dir
platformIsCrossCompiling = crossCompiling 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 { return $ Settings {
sTargetPlatform = platform, sTargetPlatform = platform,
sTmpDir = normalise tmpdir, sTmpDir = normalise tmpdir,
...@@ -306,8 +329,20 @@ initSysTools top_dir ...@@ -306,8 +329,20 @@ initSysTools top_dir
sOpt_lc = [], sOpt_lc = [],
sOpt_i = [], sOpt_i = [],
sPlatformConstants = platformConstants, sPlatformConstants = platformConstants,
sTargetPlatformString = targetPlatformString, 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 ...@@ -383,10 +418,12 @@ linkDynLib dflags0 o_files dep_packages
-- against libHSrts, then both end up getting loaded, -- against libHSrts, then both end up getting loaded,
-- and things go wrong. We therefore link the libraries -- and things go wrong. We therefore link the libraries
-- with the same RTS flags that we link GHC with. -- with the same RTS flags that we link GHC with.
dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 dflags1 = if sGhcThreaded $ settings dflags0
else dflags0 then addWay' WayThreaded dflags0
dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 else dflags0
else dflags1 dflags2 = if sGhcDebugged $ settings dflags1
then addWay' WayDebug dflags1
else dflags1
dflags = updateWays dflags2 dflags = updateWays dflags2
verbFlags = getVerbFlags dflags verbFlags = getVerbFlags dflags
......
...@@ -852,7 +852,7 @@ makeImportsDoc dflags imports ...@@ -852,7 +852,7 @@ makeImportsDoc dflags imports
| otherwise | otherwise
= Outputable.empty = Outputable.empty
doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle) doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle)
astyle = mkCodeStyle AsmStyle astyle = mkCodeStyle AsmStyle
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -565,19 +565,19 @@ pprGotDeclaration _ _ _ ...@@ -565,19 +565,19 @@ pprGotDeclaration _ _ _
-- --
pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc 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 | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
= case positionIndependent dflags of = case positionIndependent dflags of
False -> False ->
vcat [ vcat [
text ".symbol_stub", text ".symbol_stub",
text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel platform lbl, text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tjmp *L" <> pprCLabel platform lbl text "\tjmp *L" <> pprCLabel dflags lbl
<> text "$lazy_ptr", <> text "$lazy_ptr",
text "L" <> pprCLabel platform lbl text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:", <> text "$stub_binder:",
text "\tpushl $L" <> pprCLabel platform lbl text "\tpushl $L" <> pprCLabel dflags lbl
<> text "$lazy_ptr", <> text "$lazy_ptr",
text "\tjmp dyld_stub_binding_helper" text "\tjmp dyld_stub_binding_helper"
] ]
...@@ -585,16 +585,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS ...@@ -585,16 +585,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS
vcat [ vcat [
text ".section __TEXT,__picsymbolstub2," text ".section __TEXT,__picsymbolstub2,"
<> text "symbol_stubs,pure_instructions,25", <> text "symbol_stubs,pure_instructions,25",
text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"), text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel platform lbl, text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tcall ___i686.get_pc_thunk.ax", text "\tcall ___i686.get_pc_thunk.ax",
text "1:", text "1:",
text "\tmovl L" <> pprCLabel platform lbl text "\tmovl L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%edx", <> text "$lazy_ptr-1b(%eax),%edx",
text "\tjmp *%edx", text "\tjmp *%edx",
text "L" <> pprCLabel platform lbl text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:", <> text "$stub_binder:",
text "\tlea L" <> pprCLabel platform lbl text "\tlea L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%eax", <> text "$lazy_ptr-1b(%eax),%eax",
text "\tpushl %eax", text "\tpushl %eax",
text "\tjmp dyld_stub_binding_helper" text "\tjmp dyld_stub_binding_helper"
...@@ -602,16 +602,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS ...@@ -602,16 +602,16 @@ pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS
$+$ vcat [ text ".section __DATA, __la_sym_ptr" $+$ vcat [ text ".section __DATA, __la_sym_ptr"
<> (if positionIndependent dflags then int 2 else int 3) <> (if positionIndependent dflags then int 2 else int 3)
<> text ",lazy_symbol_pointers", <> text ",lazy_symbol_pointers",
text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"), text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),
text "\t.indirect_symbol" <+> pprCLabel platform lbl, text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\t.long L" <> pprCLabel platform lbl text "\t.long L" <> pprCLabel dflags lbl
<> text "$stub_binder"] <> text "$stub_binder"]
| Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
= vcat [ = vcat [
text ".non_lazy_symbol_pointer", text ".non_lazy_symbol_pointer",
char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:", char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",
text "\t.indirect_symbol" <+> pprCLabel platform lbl, text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\t.long\t0"] text "\t.long\t0"]
| otherwise | otherwise
...@@ -632,12 +632,12 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _ ...@@ -632,12 +632,12 @@ pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
-- --
-- NB: No DSO-support yet -- NB: No DSO-support yet
pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl pprImportedSymbol dflags (Platform { platformOS = OSAIX }) importedLbl
= case dynamicLinkerLabelInfo importedLbl of = case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl) Just (SymbolPtr, lbl)
-> vcat [ -> vcat [
text "LC.." <> pprCLabel platform lbl <> char ':', text "LC.." <> pprCLabel dflags lbl <> char ':',
text "\t.long" <+> pprCLabel platform lbl ] text "\t.long" <+> pprCLabel dflags lbl ]
_ -> empty _ -> empty
-- ELF / Linux -- ELF / Linux
...@@ -669,15 +669,15 @@ pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl ...@@ -669,15 +669,15 @@ pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl
-- the NCG will keep track of all DynamicLinkerLabels it uses -- the NCG will keep track of all DynamicLinkerLabels it uses
-- and output each of them using pprImportedSymbol. -- and output each of them using pprImportedSymbol.
pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ }) pprImportedSymbol dflags platform@(Platform { platformArch = ArchPPC_64 _ })
importedLbl importedLbl
| osElfTarget (platformOS platform) | osElfTarget (platformOS platform)
= case dynamicLinkerLabelInfo importedLbl of = case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl) Just (SymbolPtr, lbl)
-> vcat [ -> vcat [
text ".section \".toc\", \"aw\"", text ".section \".toc\", \"aw\"",
text ".LC_" <> pprCLabel platform lbl <> char ':', text ".LC_" <> pprCLabel dflags lbl <> char ':',
text "\t.quad" <+> pprCLabel platform lbl ] text "\t.quad" <+> pprCLabel dflags lbl ]
_ -> empty _ -> empty
pprImportedSymbol dflags platform importedLbl pprImportedSymbol dflags platform importedLbl
...@@ -691,8 +691,8 @@ pprImportedSymbol dflags platform importedLbl ...@@ -691,8 +691,8 @@ pprImportedSymbol dflags platform importedLbl
in vcat [ in vcat [
text ".section \".got2\", \"aw\"", text ".section \".got2\", \"aw\"",
text ".LC_" <> pprCLabel platform lbl <> char ':', text ".LC_" <> pprCLabel dflags lbl <> char ':',
ptext symbolSize <+> pprCLabel platform lbl ] ptext symbolSize <+> pprCLabel dflags lbl ]
-- PLT code stubs are generated automatically by the dynamic linker. -- PLT code stubs are generated automatically by the dynamic linker.
_ -> empty _ -> empty
......
...@@ -1552,7 +1552,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, ...@@ -1552,7 +1552,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn do { (defn', fvs) <- rnDataDefn doc defn
-- See Note [Complete user-supplied kind signatures] in HsDecls -- 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 rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs } , tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
......
...@@ -510,8 +510,9 @@ kcTyClGroup decls ...@@ -510,8 +510,9 @@ kcTyClGroup decls
-- 3. Generalise the inferred kinds -- 3. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls] -- See Note [Kind checking for type and class decls]
; cusks_enabled <- xoptM LangExt.CUSKs
; let (cusk_decls, no_cusk_decls) ; let (cusk_decls, no_cusk_decls)
= partition (hsDeclHasCusk . unLoc) decls = partition (hsDeclHasCusk cusks_enabled . unLoc) decls
; poly_cusk_tcs <- getInitialKinds True cusk_decls ; poly_cusk_tcs <- getInitialKinds True cusk_decls
...@@ -1040,17 +1041,25 @@ getInitialKind cusk (FamDecl { tcdFam = decl }) ...@@ -1040,17 +1041,25 @@ getInitialKind cusk (FamDecl { tcdFam = decl })
getInitialKind cusk (SynDecl { tcdLName = dL->L _ name getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
, tcdTyVars = ktvs , tcdTyVars = ktvs
, tcdRhs = rhs }) , tcdRhs = rhs })
= do { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $ = do { cusks_enabled <- xoptM LangExt.CUSKs
case kind_annotation rhs of ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
case kind_annotation cusks_enabled rhs of
Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
Nothing -> newMetaKindVar Nothing -> newMetaKindVar
; return [tycon] } ; return [tycon] }
where where
-- Keep this synchronized with 'hsDeclHasCusk'. -- Keep this synchronized with 'hsDeclHasCusk'.
kind_annotation (dL->L _ ty) = case ty of kind_annotation
HsParTy _ lty -> kind_annotation lty :: Bool -- cusks_enabled?
HsKindSig _ _ k -> Just k -> LHsType GhcRn -- rhs
_ -> Nothing -> 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 _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
getInitialKind _ (XTyClDecl _) = panic "getInitialKind" getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
...@@ -1074,18 +1083,20 @@ getFamDeclInitialKind parent_cusk mb_parent_tycon ...@@ -1074,18 +1083,20 @@ getFamDeclInitialKind parent_cusk mb_parent_tycon
, fdTyVars = ktvs , fdTyVars = ktvs
, fdResultSig = (dL->L _ resultSig) , fdResultSig = (dL->L _ resultSig)
, fdInfo = info }) , fdInfo = info })
= kcLHsQTyVars name flav fam_cusk ktvs $ = do { cusks_enabled <- xoptM LangExt.CUSKs
case resultSig of ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $
KindSig _ ki -> tcLHsKindSig ctxt ki case resultSig of
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki KindSig _ ki -> tcLHsKindSig ctxt ki
_ -- open type families have * return kind by default TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
| tcFlavourIsOpen flav -> return liftedTypeKind _ -- open type families have * return kind by default
-- closed type families have their return kind inferred | tcFlavourIsOpen flav -> return liftedTypeKind
-- by default -- closed type families have their return kind inferred
| otherwise -> newMetaKindVar -- by default
| otherwise -> newMetaKindVar
}
where where
assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk 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 flav = case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
......
...@@ -9012,6 +9012,11 @@ do so. ...@@ -9012,6 +9012,11 @@ do so.
Complete user-supplied kind signatures and polymorphic recursion 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 Just as in type inference, kind inference for recursive types can only
use *monomorphic* recursion. Consider this (contrived) example: :: use *monomorphic* recursion. Consider this (contrived) example: ::
   
...@@ -9110,6 +9115,13 @@ example, consider :: ...@@ -9110,6 +9115,13 @@ example, consider ::
According to the rules above ``X`` has a CUSK. Yet, the kind of ``k`` is undetermined. 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``. 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 Kind inference in closed type families
-------------------------------------- --------------------------------------
   
......
...@@ -132,7 +132,7 @@ executable hadrian ...@@ -132,7 +132,7 @@ executable hadrian
, transformers >= 0.4 && < 0.6 , transformers >= 0.4 && < 0.6
, unordered-containers >= 0.2.1 && < 0.3 , unordered-containers >= 0.2.1 && < 0.3
build-tools: alex >= 3.1 build-tools: alex >= 3.1
, happy >= 1.19.4 , happy >= 1.19.10
ghc-options: -Wall ghc-options: -Wall
-Wincomplete-record-updates -Wincomplete-record-updates
-Wredundant-constraints -Wredundant-constraints
......
...@@ -138,6 +138,9 @@ buildSphinxHtml path = do ...@@ -138,6 +138,9 @@ buildSphinxHtml path = do
root <- buildRootRules root <- buildRootRules
root -/- htmlRoot -/- path -/- "index.html" %> \file -> do root -/- htmlRoot -/- path -/- "index.html" %> \file -> do
let dest = takeDirectory file let dest = takeDirectory file
rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
need (map (rstFilesDir -/-) rstFiles)
build $ target docContext (Sphinx Html) [pathPath path] [dest] build $ target docContext (Sphinx Html) [pathPath path] [dest]
------------------------------------ Haddock ----------------------------------- ------------------------------------ Haddock -----------------------------------
...@@ -242,6 +245,9 @@ buildSphinxPdf path = do ...@@ -242,6 +245,9 @@ buildSphinxPdf path = do
root <- buildRootRules root <- buildRootRules
root -/- pdfRoot -/- path <.> "pdf" %> \file -> do root -/- pdfRoot -/- path <.> "pdf" %> \file -> do
withTempDir $ \dir -> do withTempDir $ \dir -> do
let rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
need (map (rstFilesDir -/-) rstFiles)
build $ target docContext (Sphinx Latex) [pathPath path] [dir] build $ target docContext (Sphinx Latex) [pathPath path] [dir]
build $ target docContext Xelatex [path <.> "tex"] [dir] build $ target docContext Xelatex [path <.> "tex"] [dir]
copyFileUntracked (dir -/- path <.> "pdf") file copyFileUntracked (dir -/- path <.> "pdf") file
......