[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: hadrian-ghci-multi: Pass -this-package-name in unit response files
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Nov 25 11:59:53 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6e1fbda7 by Ben Gamari at 2024-11-25T03:55:44-05:00
hadrian-ghci-multi: Pass -this-package-name in unit response files
As noted in #25509, the `-this-package-name` must be passed for each
package to ensure that GHC can response references to the packages'
exposed modules via package-qualified imports. Fix this.
Closes #25509.
- - - - -
a05e4a9b by Simon Hengel at 2024-11-25T03:56:33-05:00
Refactoring: Use `OnOff` more consistently for `Extension`
- - - - -
e6abf191 by Matthew Pickering at 2024-11-25T06:59:01-05:00
driver: Always link against "base" package when one shot linking
The default value for base-unit-id is stored in the settings file.
At install time, this can be set by using the BASE_UNIT_ID environment
variable.
At runtime, the value can be set by `-base-unit-id` flag.
For whether all this is a good idea, see #25382
Fixes #25382
- - - - -
c90ad82d by Cheng Shao at 2024-11-25T06:59:01-05:00
ci: minor nix-in-docker improvements
This patch makes some minor improvements re nix-in-docker logic in the
ci configuration:
- Update `nixos/nix` to the latest version
- Apply $CPUS to `cores`/`max-jobs` to avoid oversubscribing while
allowing a reasonable degree of parallelism
- Remove redundant `--extra-experimental-features nix-command` in
later `nix shell` invocations, it's already configured in
`/etc/nix/nix.conf`
- - - - -
13e98ee3 by Cheng Shao at 2024-11-25T06:59:04-05:00
ci: avoid depending on stack job for test-bootstrap jobs
This patch makes test-bootstrap related ci jobs only depend on
hadrian-ghc-in-ghci job to finish, consistent with other jobs in the
full-build stage generated by gen_ci.hs. This allows the jobs to be
spawned earlier and improve overall pipeline parallelism.
- - - - -
5869af9e by Arnaud Spiwack at 2024-11-25T06:59:17-05:00
Add test for #25515
- - - - -
1006727a by Arnaud Spiwack at 2024-11-25T06:59:17-05:00
Desugar record notation with correct multiplicities
Simply uses the multiplicity as stored in the field. As I'm writing
this commit, the only possible multiplicity is 1, but !13525 is
changing this. It's actually easier to take !13525 into account.
Fixes #25515.
- - - - -
fe261953 by Wang Xin at 2024-11-25T06:59:21-05:00
Add -mcmodel=medium moduleflag to generated LLVM IR on LoongArch
platform
This commit requires that the LLVM used contains the code of commit
9dd1d451d9719aa91b3bdd59c0c667983e1baf05. Actually we should not rely
on LLVM, so the only way to solve this problem is to implement the
LoongArch backend.
- - - - -
48541640 by Wang Xin at 2024-11-25T06:59:21-05:00
Add new type for codemodel
- - - - -
22 changed files:
- .gitlab-ci.yml
- .gitlab/hello.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Settings/IO.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Unit/State.hs
- distrib/configure.ac.in
- docs/users_guide/packages.rst
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/ToolArgs.hs
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T25382.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/linear/should_compile/T25515.hs
- testsuite/tests/linear/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -289,7 +289,7 @@ lint-author:
- *drafts-can-fail-lint
lint-ci-config:
- image: nixos/nix:2.14.1
+ image: nixos/nix:2.25.2
extends: .lint
# We don't need history/submodules in this job
variables:
@@ -299,10 +299,16 @@ lint-ci-config:
- echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
# Note [Nix-in-Docker]
# ~~~~~~~~~~~~~~~~~~~~
- # FIXME: This is a workaround for a Nix-in-Docker issue. See
+ # The nixos/nix default config is max-jobs=1 and cores=$(logical
+ # cores num) which doesn't play nice with our $CPUS convention. We
+ # fix it before invoking any nix build to avoid oversubscribing
+ # while allowing a reasonable degree of parallelism.
+ # FIXME: Disabling build-users-group=nixbld is a workaround for a Nix-in-Docker issue. See
# https://gitlab.haskell.org/ghc/head.hackage/-/issues/38#note_560487 for
# discussion.
- - nix-shell -p gnused --run "sed -i -e 's/nixbld//' /etc/nix/nix.conf"
+ - echo "cores = $CPUS" >> /etc/nix/nix.conf
+ - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
+ - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
script:
- nix run .gitlab/generate-ci#generate-jobs
# 1 if .gitlab/generate_jobs changed the output of the generated config
@@ -632,6 +638,8 @@ hackage-doc-tarball:
source-tarball:
stage: full-build
+ needs:
+ - hadrian-ghc-in-ghci
tags:
- x86_64-linux
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV"
@@ -653,6 +661,8 @@ source-tarball:
generate-hadrian-bootstrap-sources:
stage: full-build
+ needs:
+ - hadrian-ghc-in-ghci
tags:
- x86_64-linux
image: "$DOCKER_IMAGE"
@@ -1107,7 +1117,7 @@ project-version:
.ghcup-metadata:
stage: deploy
- image: nixos/nix:2.14.1
+ image: nixos/nix:2.25.2
dependencies: null
tags:
- x86_64-linux
@@ -1117,7 +1127,9 @@ project-version:
before_script:
- echo "experimental-features = nix-command flakes" >> /etc/nix/nix.conf
# FIXME: See Note [Nix-in-Docker]
- - nix-shell -p gnused --run "sed -i -e 's/nixbld//' /etc/nix/nix.conf"
+ - echo "cores = $CPUS" >> /etc/nix/nix.conf
+ - echo "max-jobs = $CPUS" >> /etc/nix/nix.conf
+ - nix run nixpkgs#gnused -- -i -e 's/ nixbld//' /etc/nix/nix.conf
- nix-channel --update
- cat version.sh
# Calculate the project version
@@ -1182,7 +1194,7 @@ ghcup-metadata-nightly:
artifacts: false
- job: project-version
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: $NIGHTLY
@@ -1220,7 +1232,7 @@ ghcup-metadata-release:
# No explicit needs for release pipeline as we assume we need everything and everything will pass.
extends: .ghcup-metadata
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: '$RELEASE_JOB == "yes"'
=====================================
.gitlab/hello.hs
=====================================
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -Wall -Wno-missing-fields #-}
+import GHC.Unit.Types (stringToUnitId)
import GHC hiding (parseModule)
import GHC.Data.StringBuffer
import GHC.Driver.Config.Parser
@@ -26,7 +27,8 @@ fakeSettings =
sToolSettings = ToolSettings {},
sTargetPlatform =
genericPlatform,
- sPlatformMisc = PlatformMisc {}
+ sPlatformMisc = PlatformMisc {},
+ sUnitSettings = UnitSettings { unitSettings_baseUnitId = stringToUnitId "base" }
}
fakeDynFlags :: DynFlags
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -221,7 +221,12 @@ cmmMetaLlvmPrelude = do
case platformArch platform of
ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32]
_ -> []
- module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas
+ let codel_model_metas =
+ case platformArch platform of
+ -- FIXME: We should not rely on LLVM
+ ArchLoongArch64 -> [mkCodeModelMeta CMMedium]
+ _ -> []
+ module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas)
let metas = tbaa_metas ++ module_flags_metas
cfg <- getConfig
renderLlvm (ppLlvmMetas cfg metas)
@@ -244,6 +249,15 @@ mkStackAlignmentMeta :: Integer -> ModuleFlag
mkStackAlignmentMeta alignment =
ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32)
+-- LLVM's @LLVM::CodeModel::Model@ enumeration
+data CodeModel = CMMedium
+
+-- Pass -mcmodel=medium option to LLVM on LoongArch64
+mkCodeModelMeta :: CodeModel -> ModuleFlag
+mkCodeModelMeta codemodel =
+ ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32)
+ where
+ n = case codemodel of CMMedium -> 3 -- as of LLVM 17
-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -62,6 +62,10 @@ module GHC.Driver.DynFlags (
versionedAppDir, versionedFilePath,
extraGccViaCFlags, globalPackageDatabasePath,
+ --
+ baseUnitId,
+
+
-- * Include specifications
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
addImplicitQuoteInclude,
@@ -165,6 +169,8 @@ data DynFlags = DynFlags {
-- formerly Settings
ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion,
fileSettings :: {-# UNPACK #-} !FileSettings,
+ unitSettings :: {-# UNPACK #-} !UnitSettings,
+
targetPlatform :: Platform, -- Filled in by SysTools
toolSettings :: {-# UNPACK #-} !ToolSettings,
platformMisc :: {-# UNPACK #-} !PlatformMisc,
@@ -634,6 +640,7 @@ defaultDynFlags mySettings =
splitInfo = Nothing,
ghcNameVersion = sGhcNameVersion mySettings,
+ unitSettings = sUnitSettings mySettings,
fileSettings = sFileSettings mySettings,
toolSettings = sToolSettings mySettings,
targetPlatform = sTargetPlatform mySettings,
@@ -729,16 +736,6 @@ newtype FlushOut = FlushOut (IO ())
defaultFlushOut :: FlushOut
defaultFlushOut = FlushOut $ hFlush stdout
-
-
-data OnOff a = On a
- | Off a
- deriving (Eq, Show)
-
-instance Outputable a => Outputable (OnOff a) where
- ppr (On x) = text "On" <+> ppr x
- ppr (Off x) = text "Off" <+> ppr x
-
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension
@@ -1484,6 +1481,11 @@ versionedAppDir appname platform = do
versionedFilePath :: ArchOS -> FilePath
versionedFilePath platform = uniqueSubdir platform
+-- | Access the unit-id of the version of `base` which we will automatically link
+-- against.
+baseUnitId :: DynFlags -> UnitId
+baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)
+
-- SDoc
-------------------------------------------
-- | Initialize the pretty-printing options
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Driver.Flags
, minusWcompatOpts
, unusedBindsFlags
+ , OnOff(..)
, TurnOnFlag
, turnOn
, turnOff
@@ -77,6 +78,14 @@ instance Binary Language where
instance NFData Language where
rnf x = x `seq` ()
+data OnOff a = On a
+ | Off a
+ deriving (Eq, Show)
+
+instance Outputable a => Outputable (OnOff a) where
+ ppr (On x) = text "On" <+> ppr x
+ ppr (Off x) = text "Off" <+> ppr x
+
type TurnOnFlag = Bool -- True <=> we are turning the flag on
-- False <=> we are turning the flag off
turnOn :: TurnOnFlag; turnOn = True
@@ -269,78 +278,77 @@ extensionNames ext = mk (extensionDeprecation ext) (extensionName ext : exte
++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)
where mk depr = map (\name -> (depr, name))
-
-impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
+impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
- = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll)
- , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll)
- , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
- , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances)
- , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses)
- , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854
- , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies)
+ = [ (LangExt.RankNTypes, On LangExt.ExplicitForAll)
+ , (LangExt.QuantifiedConstraints, On LangExt.ExplicitForAll)
+ , (LangExt.ScopedTypeVariables, On LangExt.ExplicitForAll)
+ , (LangExt.LiberalTypeSynonyms, On LangExt.ExplicitForAll)
+ , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll)
+ , (LangExt.FlexibleInstances, On LangExt.TypeSynonymInstances)
+ , (LangExt.FunctionalDependencies, On LangExt.MultiParamTypeClasses)
+ , (LangExt.MultiParamTypeClasses, On LangExt.ConstrainedClassMethods) -- c.f. #7854
+ , (LangExt.TypeFamilyDependencies, On LangExt.TypeFamilies)
- , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off!
+ , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude) -- NB: turn off!
- , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)
+ , (LangExt.DerivingVia, On LangExt.DerivingStrategies)
- , (LangExt.GADTs, turnOn, LangExt.GADTSyntax)
- , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.GADTs, On LangExt.GADTSyntax)
+ , (LangExt.GADTs, On LangExt.MonoLocalBinds)
+ , (LangExt.TypeFamilies, On LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures
- , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds
+ , (LangExt.TypeFamilies, On LangExt.KindSignatures) -- Type families use kind signatures
+ , (LangExt.PolyKinds, On LangExt.KindSignatures) -- Ditto polymorphic kinds
-- TypeInType is now just a synonym for a couple of other extensions.
- , (LangExt.TypeInType, turnOn, LangExt.DataKinds)
- , (LangExt.TypeInType, turnOn, LangExt.PolyKinds)
- , (LangExt.TypeInType, turnOn, LangExt.KindSignatures)
+ , (LangExt.TypeInType, On LangExt.DataKinds)
+ , (LangExt.TypeInType, On LangExt.PolyKinds)
+ , (LangExt.TypeInType, On LangExt.KindSignatures)
-- Standalone kind signatures are a replacement for CUSKs.
- , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
+ , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
- , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)
+ , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable)
-- We turn this on so that we can export associated type
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
- , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces)
- , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)
+ , (LangExt.TypeFamilies, On LangExt.ExplicitNamespaces)
+ , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces)
- , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes)
+ , (LangExt.ImpredicativeTypes, On LangExt.RankNTypes)
-- Record wild-cards implies field disambiguation
-- Otherwise if you write (C {..}) you may well get
-- stuff like " 'a' not in scope ", which is a bit silly
-- if the compiler has just filled in field 'a' of constructor 'C'
- , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.RecordWildCards, On LangExt.DisambiguateRecordFields)
- , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)
+ , (LangExt.ParallelArrays, On LangExt.ParallelListComp)
- , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)
+ , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)
-- Duplicate record fields require field disambiguation
- , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields)
- , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)
- , (LangExt.Strict, turnOn, LangExt.StrictData)
+ , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes)
+ , (LangExt.Strict, On LangExt.StrictData)
-- Historically only UnboxedTuples was required for unboxed sums to work.
-- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.
- , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)
+ , (LangExt.UnboxedTuples, On LangExt.UnboxedSums)
-- The extensions needed to declare an H98 unlifted data type
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)
+ , (LangExt.UnliftedDatatypes, On LangExt.DataKinds)
+ , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures)
-- See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind
- , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.LinearTypes, On LangExt.MonoLocalBinds)
]
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -80,6 +80,9 @@ module GHC.Driver.Session (
safeDirectImpsReq, safeImplicitImpsReq,
unsafeFlags, unsafeFlagsForInfer,
+ -- ** base
+ baseUnitId,
+
-- ** System tool settings and locations
Settings(..),
sProgramName,
@@ -390,6 +393,7 @@ settings :: DynFlags -> Settings
settings dflags = Settings
{ sGhcNameVersion = ghcNameVersion dflags
, sFileSettings = fileSettings dflags
+ , sUnitSettings = unitSettings dflags
, sTargetPlatform = targetPlatform dflags
, sToolSettings = toolSettings dflags
, sPlatformMisc = platformMisc dflags
@@ -488,6 +492,10 @@ opt_las dflags = toolSettings_opt_las $ toolSettings dflags
opt_i :: DynFlags -> [String]
opt_i dflags= toolSettings_opt_i $ toolSettings dflags
+
+setBaseUnitId :: String -> DynP ()
+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }
+
-----------------------------------------------------------------------------
{-
@@ -2053,6 +2061,7 @@ package_flags_deps = [
(NoArg (setGeneralFlag Opt_DistrustAllPackages))
, make_ord_flag defFlag "trust" (HasArg trustPackage)
, make_ord_flag defFlag "distrust" (HasArg distrustPackage)
+ , make_ord_flag defFlag "base-unit-id" (HasArg setBaseUnitId)
]
where
setPackageEnv env = upd $ \s -> s { packageEnv = Just env }
@@ -2925,13 +2934,18 @@ unSetExtensionFlag f = upd (unSetExtensionFlag' f)
setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags
setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps
where
- deps = [ if turn_on then setExtensionFlag' d
- else unSetExtensionFlag' d
- | (f', turn_on, d) <- impliedXFlags, f' == f ]
+ deps :: [DynFlags -> DynFlags]
+ deps = [ setExtension d
+ | (f', d) <- impliedXFlags, f' == f ]
-- When you set f, set the ones it implies
-- NB: use setExtensionFlag recursively, in case the implied flags
-- implies further flags
+ setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags
+ setExtension = \ case
+ On extension -> setExtensionFlag' extension
+ Off extension -> unSetExtensionFlag' extension
+
unSetExtensionFlag' f dflags = xopt_unset dflags f
-- When you un-set f, however, we don't un-set the things it implies
-- (except for -fno-glasgow-exts, which is treated specially)
=====================================
compiler/GHC/Settings.hs
=====================================
@@ -5,6 +5,7 @@ module GHC.Settings
( Settings (..)
, ToolSettings (..)
, FileSettings (..)
+ , UnitSettings(..)
, GhcNameVersion (..)
, Platform (..)
, PlatformMisc (..)
@@ -73,6 +74,7 @@ import GHC.Prelude
import GHC.Utils.CliOption
import GHC.Utils.Fingerprint
import GHC.Platform
+import GHC.Unit.Types
data Settings = Settings
{ sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion
@@ -80,12 +82,15 @@ data Settings = Settings
, sTargetPlatform :: Platform -- Filled in by SysTools
, sToolSettings :: {-# UNPACK #-} !ToolSettings
, sPlatformMisc :: {-# UNPACK #-} !PlatformMisc
+ , sUnitSettings :: !UnitSettings
-- You shouldn't need to look things up in rawSettings directly.
-- They should have their own fields instead.
, sRawSettings :: [(String, String)]
}
+data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId }
+
-- | Settings for other executables GHC calls.
--
-- Probably should further split down by phase, or split between
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Utils.Panic
import GHC.ResponseFile
import GHC.Settings
import GHC.SysTools.BaseDir
+import GHC.Unit.Types
import Data.Char
import Control.Monad.Trans.Except
@@ -174,6 +175,8 @@ initSettings top_dir = do
ghcWithInterpreter <- getBooleanSetting "Use interpreter"
useLibFFI <- getBooleanSetting "Use LibFFI"
+ baseUnitId <- getSetting "base unit-id"
+
return $ Settings
{ sGhcNameVersion = GhcNameVersion
{ ghcNameVersion_programName = "ghc"
@@ -188,6 +191,11 @@ initSettings top_dir = do
, fileSettings_globalPackageDatabase = globalpkgdb_path
}
+ , sUnitSettings = UnitSettings
+ {
+ unitSettings_baseUnitId = stringToUnitId baseUnitId
+ }
+
, sToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
, toolSettings_ldSupportsFilelist = ldSupportsFilelist
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -575,12 +575,7 @@ tcExpr expr@(RecordCon { rcon_con = L loc con_name
; checkTc (conLikeHasBuilder con_like) $
nonBidirectionalErr (conLikeName con_like)
- ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
- -- It is currently not possible for a record to have
- -- multiplicities. When they do, `tcRecordBinds` will take
- -- scaled types instead. Meanwhile, it's safe to take
- -- `scaledThing` above, as we know all the multiplicities are
- -- Many.
+ ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
; let rcon_tc = mkHsWrap con_wrap con_expr
expr' = RecordCon { rcon_ext = rcon_tc
@@ -1632,7 +1627,7 @@ This extends OK when the field types are universally quantified.
tcRecordBinds
:: ConLike
- -> [TcType] -- Expected type for each field
+ -> [Scaled TcType] -- Expected type for each field
-> HsRecordBinds GhcRn
-> TcM (HsRecordBinds GhcTc)
@@ -1661,18 +1656,18 @@ fieldCtxt :: FieldLabelString -> SDoc
fieldCtxt field_name
= text "In the" <+> quotes (ppr field_name) <+> text "field of a record"
-tcRecordField :: ConLike -> Assoc Name Type
+tcRecordField :: ConLike -> Assoc Name (Scaled Type)
-> LFieldOcc GhcRn -> LHsExpr GhcRn
-> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs
- | Just field_ty <- assocMaybe flds_w_tys sel_name
+ | Just (Scaled field_mult field_ty) <- assocMaybe flds_w_tys sel_name
= addErrCtxt (fieldCtxt field_lbl) $
- do { rhs' <- tcCheckPolyExprNC rhs field_ty
+ do { rhs' <- tcScalingUsage field_mult $ tcCheckPolyExprNC rhs field_ty
; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs'))
field_ty
; let field_id = mkUserLocal (nameOccName sel_name)
(nameUnique sel_name)
- ManyTy field_ty (locA loc)
+ field_mult field_ty (locA loc)
-- Yuk: the field_id has the *unique* of the selector Id
-- (so we can find it easily)
-- but is a LocalId with the appropriate type of the RHS
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -403,9 +403,7 @@ pprImpliedExtensions extension = case implied of
xs -> parens $ "implied by" <+> unquotedListWith "and" xs
where implied = map (quotes . ppr)
. filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)
- . map (\(impl, _, _) -> impl)
- . filter (\(_, t, orig) -> orig == extension && t == turnOn)
- $ impliedXFlags
+ $ [impl | (impl, On orig) <- impliedXFlags, orig == extension]
pprPrefixUnqual :: Name -> SDoc
pprPrefixUnqual name =
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -364,9 +364,13 @@ initUnitConfig dflags cached_dbs home_units =
autoLink
| not (gopt Opt_AutoLinkPackages dflags) = []
- -- By default we add ghc-internal & rts to the preload units (when they are
+ -- By default we add base, ghc-internal and rts to the preload units (when they are
-- found in the unit database) except when we are building them
- | otherwise = filter (hu_id /=) [ghcInternalUnitId, rtsUnitId]
+ --
+ -- Since "base" is not wired in, then the unit-id is discovered
+ -- from the settings file by default, but can be overriden by power-users
+ -- by specifying `-base-unit-id` flag.
+ | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId]
-- if the home unit is indefinite, it means we are type-checking it only
-- (not producing any code). Hence we can use virtual units instantiated
=====================================
distrib/configure.ac.in
=====================================
@@ -366,6 +366,17 @@ if test "x$UseLibdw" = "xYES" ; then
fi
AC_SUBST(UseLibdw)
+dnl What is the version of the base library which we are going to use?
+dnl The user can use BASE_UNIT_ID at install time to point the compiler to
+dnl link against a different base package by default.
+dnl If the package is unavailable it will simply not be linked against.
+BaseUnitId=@BaseUnitId@
+if test -n "$BASE_UNIT_ID"; then
+ BaseUnitId="$BASE_UNIT_ID"
+fi
+
+AC_SUBST(BaseUnitId)
+
FP_SETTINGS
# We get caught by
=====================================
docs/users_guide/packages.rst
=====================================
@@ -239,9 +239,27 @@ The GHC command line options that control packages are:
:type: dynamic
:category:
- By default, GHC will automatically link in the ``base`` and ``rts``
+ By default, GHC will automatically link in the ``base``, ``ghc-internal`` and ``rts``
packages. This flag disables that behaviour.
+ The unit-id of the ``base`` package which is automatically linked can be set using
+ the :ghc-flag:`-base-unit-id ⟨unit-id⟩` flag.
+
+.. ghc-flag:: -base-unit-id ⟨unit-id⟩
+ :shortdesc: The unit-id of the "base" package, which will be automatically linked.
+ :type: dynamic
+ :category:
+
+ By default the compiler will link against the ``base``, ``ghc-internal``,
+ and ``rts`` package, this flag controls what the ``base`` package linked
+ against is.
+
+ You should only need to pass this flag if you really know what you are doing.
+ Distributors can set a default unit-id for base at install time by specifying
+ the ``BASE_UNIT_ID`` environment variable.
+
+
+
.. ghc-flag:: -this-unit-id ⟨unit-id⟩
:shortdesc: Compile to be part of unit (i.e. package)
⟨unit-id⟩
=====================================
hadrian/bindist/Makefile
=====================================
@@ -142,6 +142,7 @@ lib/settings : config.mk
@echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@
@echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@
@echo ',("Relative Global Package DB", "package.conf.d")' >> $@
+ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@
@echo "]" >> $@
# We need to install binaries relative to libraries.
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -134,6 +134,7 @@ CrossCompiling = @CrossCompiling@
CrossCompilePrefix = @CrossCompilePrefix@
GhcUnregisterised = @Unregisterised@
EnableDistroToolchain = @SettingsUseDistroMINGW@
+BaseUnitId = @BaseUnitId@
# The THREADED_RTS requires `BaseReg` to be in a register and the
# `GhcUnregisterised` mode doesn't allow that.
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -435,6 +435,7 @@ bindistRules = do
, interpolateVar "UseLibdw" $ fmap yesNo $ interp $ getFlag UseLibdw
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
+ , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
@@ -471,6 +472,14 @@ generateSettings settingsFile = do
Stage2 -> get_pkg_db Stage1
Stage3 -> get_pkg_db Stage2
+ -- The unit-id of the base package which is always linked against (#25382)
+ base_unit_id <- expr $ do
+ case stage of
+ Stage0 {} -> error "Unable to generate settings for stage0"
+ Stage1 -> pkgUnitId Stage1 base
+ Stage2 -> pkgUnitId Stage1 base
+ Stage3 -> pkgUnitId Stage2 base
+
let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
settings <- traverse sequence $
@@ -531,6 +540,7 @@ generateSettings settingsFile = do
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
, ("Relative Global Package DB", pure rel_pkg_db)
+ , ("base unit-id", pure base_unit_id)
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -99,7 +99,8 @@ multiSetup pkg_s = do
writeFile' (resp_file root p) (intercalate "\n" (normalise_ghc arg_list
++ modules cd
++ concatMap rexp (reexportModules cd)
- ++ ["-outputdir", hidir]))
+ ++ ["-outputdir", hidir,
+ "-this-package-name", pkgName p]))
return (resp_file root p)
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -808,3 +808,8 @@ T23339B:
"$(TEST_HC)" -tmpdir "$(PWD)/tmp" $(TEST_HC_OPTS) -v0 T23339B.hs -finfo-table-map
# Check that the file is kept and is the right one
find . -name "*.c" -exec cat {} \; | grep "init__ip_init"
+
+# Test that base is linked against implicitly
+T25382:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c T25382.hs
+ "$(TEST_HC)" $(TEST_HC_OPTS) T25382.o -o main
=====================================
testsuite/tests/driver/T25382.hs
=====================================
@@ -0,0 +1,7 @@
+module Main where
+
+import Data.Complex
+
+main = do
+ x <- readLn :: IO (Complex Int)
+ print $ realPart x
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -330,3 +330,4 @@ test('T23944', [unless(have_dynamic(), skip), extra_files(['T23944A.hs'])], mult
test('T24286', [cxx_src, unless(have_profiling(), skip), extra_files(['T24286.cpp'])], compile, ['-prof -no-hs-main'])
test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t24839_sub.S"])], compile_and_run, ['t24839_sub.S'])
test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
+test('T25382', normal, makefile_test, [])
=====================================
testsuite/tests/linear/should_compile/T25515.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE LinearTypes #-}
+
+module T25515 where
+
+data C = MkC { unc :: Int }
+
+f :: Int %1 -> C
+f x = MkC { unc = x }
=====================================
testsuite/tests/linear/should_compile/all.T
=====================================
@@ -47,3 +47,4 @@ test('LinearLet', normal, compile, [''])
test('LinearLetPoly', normal, compile, [''])
test('LinearListComprehension', normal, compile, ['-dlinear-core-lint'])
test('OmitFieldPat', normal, compile, ['-dcore-lint'])
+test('T25515', normal, compile, ['-dcore-lint'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5002fa3d7de76eef72a34414a21949d93e9cfe63...48541640867ffc3fd23ae91cc3949be6a0f3cf81
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5002fa3d7de76eef72a34414a21949d93e9cfe63...48541640867ffc3fd23ae91cc3949be6a0f3cf81
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241125/ad19d4a9/attachment-0001.html>
More information about the ghc-commits
mailing list