[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Extend -reexported-module flag to support module renaming
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Aug 14 13:27:49 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
451380ef by Matthew Pickering at 2024-08-14T09:27:13-04:00
Extend -reexported-module flag to support module renaming
The -reexported-module flag now supports renaming -rexported-modules.
```
-rexported-module "A as B"
```
This feature is only relevant to multi-component sessions.
Fixes #25139
- - - - -
c2391f18 by Arnaud Spiwack at 2024-08-14T09:27:16-04:00
Don't restrict eta-reduction of linear functions
This commit simply removes code. All the supporting implementation has
been done as part of !12883.
Closes #25129
- - - - -
6118aa47 by sheaf at 2024-08-14T09:27:17-04:00
Allow @ character in C labels
Generated symbol names can include the '@' character, for example when using
`__attribute__((vectorcall))`.
- - - - -
0663dd06 by Sylvain Henry at 2024-08-14T09:27:30-04:00
Linker: replace blind tuple with a datatype + docs
- - - - -
25 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Linker/Unit.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- docs/users_guide/using.rst
- testsuite/tests/driver/multipleHomeUnits/all.T
- + testsuite/tests/driver/multipleHomeUnits/t25139/u1
- + testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A.hs
- + testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A1.hs
- + testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A2.hs
- + testsuite/tests/driver/multipleHomeUnits/t25139/u2
- + testsuite/tests/driver/multipleHomeUnits/t25139/u2src/U.hs
- + testsuite/tests/driver/multipleHomeUnits/t25139/u3
- + testsuite/tests/driver/multipleHomeUnits/t25139/u3src/C.hs
- + testsuite/tests/driver/multipleHomeUnits/t25139/u4
- + testsuite/tests/driver/multipleHomeUnits/t25139/u4src/U4.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3170,6 +3170,19 @@ examples are documented in the linear-type implementation wiki page
The rule "ex" must match . So the linter must accept `m' f`.
+* EXAMPLE 4: eta-reduction
+ Eta-expansion can change linear functions into unrestricted functions
+
+ f :: A %1 -> B
+
+ g :: A %Many -> B
+ g = \x -> f x
+
+ Eta-reduction undoes this and produces:
+
+ g :: A %Many -> B
+ g = f
+
Historical note: In the original linear-types implementation, we had tried to
make every optimisation pass produce code that passes `-dlinear-core-lint`. It
had proved very difficult. We kept finding corner case after corner
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2507,14 +2507,6 @@ case where `e` is trivial):
And here are a few more technical criteria for when it is *not* sound to
eta-reduce that are specific to Core and GHC:
-(L) With linear types, eta-reduction can break type-checking:
- f :: A ⊸ B
- g :: A -> B
- g = \x. f x
- The above is correct, but eta-reducing g would yield g=f, the linter will
- complain that g and f don't have the same type. NB: Not unsound in the
- dynamic semantics, but unsound according to the static semantics of Core.
-
(J) We may not undersaturate join points.
See Note [Invariants on join points] in GHC.Core, and #20599.
@@ -2774,7 +2766,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
| fun `elemUnVarSet` rec_ids -- Criterion (R)
= False -- Don't eta-reduce in fun in its own recursive RHSs
- | cantEtaReduceFun fun -- Criteria (L), (J), (W), (B)
+ | cantEtaReduceFun fun -- Criteria (J), (W), (B)
= False -- Function can't be eta reduced to arity 0
-- without violating invariants of Core and GHC
@@ -2844,7 +2836,7 @@ tryEtaReduce rec_ids bndrs body eval_sd
ok_arg _ _ _ _ = Nothing
-- | Can we eta-reduce the given function
--- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L).
+-- See Note [Eta reduction soundness], criteria (B), (J), and (W).
cantEtaReduceFun :: Id -> Bool
cantEtaReduceFun fun
= hasNoBinding fun -- (B)
@@ -2858,11 +2850,6 @@ cantEtaReduceFun fun
-- Don't undersaturate StrictWorkerIds.
-- See Note [CBV Function Ids] in GHC.Types.Id.Info.
- || isLinearType (idType fun) -- (L)
- -- Don't perform eta reduction on linear types.
- -- If `f :: A %1-> B` and `g :: A -> B`,
- -- then `g x = f x` is OK but `g = f` is not.
-
{- *********************************************************************
* *
=====================================
compiler/GHC/Driver/Config/Finder.hs
=====================================
@@ -9,6 +9,7 @@ import GHC.Driver.DynFlags
import GHC.Unit.Finder.Types
import GHC.Data.FastString
import GHC.Data.OsPath
+import qualified Data.Map as Map
-- | Create a new 'FinderOpts' from DynFlags.
initFinderOpts :: DynFlags -> FinderOpts
@@ -21,7 +22,7 @@ initFinderOpts flags = FinderOpts
, finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags
, finder_thisPackageName = mkFastString <$> thisPackageName flags
, finder_hiddenModules = hiddenModules flags
- , finder_reexportedModules = reexportedModules flags
+ , finder_reexportedModules = Map.fromList [(known_as, is_as) | ReexportedModule is_as known_as <- reverse (reexportedModules flags)]
, finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags
, finder_hieSuf = unsafeEncodeUtf $ hieSuf flags
, finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -42,6 +42,8 @@ module GHC.Driver.DynFlags (
targetProfile,
+ ReexportedModule(..),
+
-- ** Manipulating DynFlags
defaultDynFlags, -- Settings -> DynFlags
initDynFlags, -- DynFlags -> IO DynFlags
@@ -250,7 +252,7 @@ data DynFlags = DynFlags {
workingDirectory :: Maybe FilePath,
thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units
hiddenModules :: Set.Set ModuleName,
- reexportedModules :: Set.Set ModuleName,
+ reexportedModules :: [ReexportedModule],
-- ways
targetWays_ :: Ways, -- ^ Target way flags from the command line
@@ -578,7 +580,7 @@ defaultDynFlags mySettings =
workingDirectory = Nothing,
thisPackageName = Nothing,
hiddenModules = Set.empty,
- reexportedModules = Set.empty,
+ reexportedModules = [],
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -958,6 +960,17 @@ flattenIncludes specs =
includePathsQuoteImplicit specs ++
includePathsGlobal specs
+
+-- An argument to --reexported-module which can optionally specify a module renaming.
+data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName
+ , reexportTo :: ModuleName
+ }
+
+instance Outputable ReexportedModule where
+ ppr (ReexportedModule from to) =
+ if from == to then ppr from
+ else ppr from <+> text "as" <+> ppr to
+
{- Note [Implicit include paths]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The compile driver adds the path to the folder containing the source file being
=====================================
compiler/GHC/Driver/Errors/Types.hs
=====================================
@@ -24,7 +24,7 @@ import GHC.Prelude
import Data.Bifunctor
import Data.Typeable
-import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt)
+import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt, ReexportedModule)
import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage))
import GHC.Types.Error
import GHC.Unit.Module
@@ -152,7 +152,7 @@ data DriverMessage where
{-| DriverUnknown is a warning that arises when a user tries to
reexport a module which isn't part of that unit.
-}
- DriverUnknownReexportedModules :: UnitId -> [ModuleName] -> DriverMessage
+ DriverUnknownReexportedModules :: UnitId -> [ReexportedModule] -> DriverMessage
{-| DriverUnknownHiddenModules is a warning that arises when a user tries to
hide a module which isn't part of that unit.
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Phases
import GHC.Driver.Pipeline
import GHC.Driver.Session
+import GHC.Driver.DynFlags (ReexportedModule(..))
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
@@ -365,7 +366,7 @@ warnMissingHomeModules dflags targets mod_graph =
-- Check that any modules we want to reexport or hide are actually in the package.
warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
warnUnknownModules hsc_env dflags mod_graph = do
- reexported_warns <- filterM check_reexport (Set.toList reexported_mods)
+ reexported_warns <- filterM check_reexport reexported_mods
return $ final_msgs hidden_warns reexported_warns
where
diag_opts = initDiagOpts dflags
@@ -382,7 +383,7 @@ warnUnknownModules hsc_env dflags mod_graph = do
lookupModule mn = findImportedModule hsc_env mn NoPkgQual
check_reexport mn = do
- fr <- lookupModule mn
+ fr <- lookupModule (reexportFrom mn)
case fr of
Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)
_ -> return True
@@ -2217,9 +2218,9 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
| isHaskellSigFilename src_fn = HsigFile
| otherwise = HsSrcFile
- when (pi_mod_name /= wanted_mod) $
+ when (pi_mod_name /= moduleName mod) $
throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
- $ DriverFileModuleNameMismatch pi_mod_name wanted_mod
+ $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)
let instantiations = homeUnitInstantiations home_unit
when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3088,7 +3088,24 @@ addHiddenModule p =
addReexportedModule :: String -> DynP ()
addReexportedModule p =
- upd (\s -> s{ reexportedModules = Set.insert (mkModuleName p) (reexportedModules s) })
+ upd (\s -> s{ reexportedModules = (parseReexportedModule p) : (reexportedModules s) })
+
+parseReexportedModule :: String -- string to parse
+ -> ReexportedModule
+parseReexportedModule str
+ = case filter ((=="").snd) (readP_to_S parseItem str) of
+ [(r, "")] -> r
+ _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str)
+ where
+ parseItem = do
+ orig <- tok $ parseModuleName
+ (do _ <- tok $ string "as"
+ new <- tok $ parseModuleName
+ return (ReexportedModule orig new))
+ +++
+ return (ReexportedModule orig orig)
+
+ tok m = m >>= \x -> skipSpaces >> return x
-- If we're linking a binary, then only backends that produce object
=====================================
compiler/GHC/Linker/Dynamic.hs
=====================================
@@ -85,11 +85,11 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
| OSMinGW32 <- os = pkgs_with_rts
| gopt Opt_LinkRts dflags = pkgs_with_rts
| otherwise = pkgs_without_rts
- pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags
+ pkg_link_opts = hsLibs unit_link_opts ++ extraLibs unit_link_opts ++ otherFlags unit_link_opts
where
namever = ghcNameVersion dflags
ways_ = ways dflags
- (package_hs_libs, extra_libs, other_flags) = collectLinkOpts namever ways_ pkgs
+ unit_link_opts = collectLinkOpts namever ways_ pkgs
-- probably _stub.o files
-- and last temporary shared object file
=====================================
compiler/GHC/Linker/Static.hs
=====================================
@@ -156,10 +156,10 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
= ([],[])
pkg_link_opts <- do
- (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts namever ways_ unit_env dep_units
- return $ other_flags ++ dead_strip
- ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
- ++ extra_libs
+ unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units
+ return $ otherFlags unit_link_opts ++ dead_strip
+ ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs
+ ++ extraLibs unit_link_opts
-- -Wl,-u,<sym> contained in other_flags
-- needs to be put before -l<package>,
-- otherwise Solaris linker fails linking
=====================================
compiler/GHC/Linker/Unit.hs
=====================================
@@ -1,7 +1,8 @@
-- | Linking Haskell units
module GHC.Linker.Unit
- ( collectLinkOpts
+ ( UnitLinkOpts (..)
+ , collectLinkOpts
, collectArchives
, getUnitLinkOpts
, getLibs
@@ -24,20 +25,27 @@ import Control.Monad
import System.Directory
import System.FilePath
+-- | Linker flags collected from units
+data UnitLinkOpts = UnitLinkOpts
+ { hsLibs :: [String] -- ^ Haskell libraries (as a list of "-lHSfoo...")
+ , extraLibs :: [String] -- ^ External libraries (as a list of "-lfoo...")
+ , otherFlags :: [String] -- ^ Extra linker options
+ }
+ deriving (Show)
+
-- | Find all the link options in these and the preload packages,
-- returning (package hs lib options, extra library options, other flags)
-getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
+getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO UnitLinkOpts
getUnitLinkOpts namever ways unit_env pkgs = do
ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs
return (collectLinkOpts namever ways ps)
-collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> ([String], [String], [String])
-collectLinkOpts namever ways ps =
- (
- concatMap (map ("-l" ++) . unitHsLibs namever ways) ps,
- concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,
- concatMap (map ST.unpack . unitLinkerOptions) ps
- )
+collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> UnitLinkOpts
+collectLinkOpts namever ways ps = UnitLinkOpts
+ { hsLibs = concatMap (map ("-l" ++) . unitHsLibs namever ways) ps
+ , extraLibs = concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps
+ , otherFlags = concatMap (map ST.unpack . unitLinkerOptions) ps
+ }
collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath]
collectArchives namever ways pc =
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -189,7 +189,7 @@ isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C la
isCLabelString lbl
= all ok (unpackFS lbl)
where
- ok c = isAlphaNum c || c == '_' || c == '.'
+ ok c = isAlphaNum c || c == '_' || c == '.' || c == '@'
-- The '.' appears in e.g. "foo.so" in the
-- module part of a ExtName. Maybe it should be separate
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -165,8 +165,8 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
home_pkg_import (uid, opts)
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
- | mod_name `Set.member` finder_reexportedModules opts =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ | Just real_mod_name <- mod_name `M.lookup` finder_reexportedModules opts =
+ findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -102,7 +102,7 @@ data FinderOpts = FinderOpts
, finder_workingDirectory :: Maybe OsPath
, finder_thisPackageName :: Maybe FastString
, finder_hiddenModules :: Set.Set ModuleName
- , finder_reexportedModules :: Set.Set ModuleName
+ , finder_reexportedModules :: M.Map ModuleName ModuleName -- Reverse mapping, if you are looking for this name then look for this module.
, finder_hieDir :: Maybe OsPath
, finder_hieSuf :: OsString
, finder_hiDir :: Maybe OsPath
@@ -112,4 +112,4 @@ data FinderOpts = FinderOpts
, finder_objectSuf :: OsString
, finder_dynObjectSuf :: OsString
, finder_stubDir :: Maybe OsPath
- } deriving Show
+ }
=====================================
docs/users_guide/using.rst
=====================================
@@ -896,7 +896,7 @@ units easier.
The main use of this flag is to be able to recreate the difference between
an exposed and hidden module for installed packages.
-.. ghc-flag:: -reexported-module ⟨module name⟩
+.. ghc-flag:: -reexported-module ⟨reexport-spec⟩
:shortdesc: A module which should be reexported from this unit.
:type: dynamic
:category:
@@ -905,6 +905,16 @@ units easier.
are not defined in a unit but should be reexported. The effect is that other
units will see this module as if it was defined in this unit.
+ The simple form of the flag allows the reexport of a single module at the
+ same name::
+
+ -reexported-module A
+
+ the complicated version of the flag allows the module to be renamed when
+ reexported::
+
+ -reexported-module "A as B"
+
The use of this flag is to be able to replicate the reexported modules
feature of packages with multiple home units.
=====================================
testsuite/tests/driver/multipleHomeUnits/all.T
=====================================
@@ -70,6 +70,7 @@ test('multipleHomeUnits_recomp_th', [filter_stdout_lines(r'.*Compiling.*'), copy
test('multipleHomeUnits_shared', [extra_files([ 'A.hs', 'unitShared1', 'unitShared2'])], multiunit_compile, [['unitShared1', 'unitShared2'], '-fhide-source-paths'])
test('multipleHomeUnits_shared_ghci', [extra_files([ 'shared.script', 'A.hs', 'unitShared1', 'unitShared2']), extra_run_opts('-unit @unitShared1 -unit @unitShared2')], ghci_script, ['shared.script'])
+test('t25139', [extra_files(['t25139/'])], multiunit_compile, [['t25139/u1', 't25139/u2', 't25139/u3', 't25139/u4'], '-v0'])
test('T25122',
[ extra_files(
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u1
=====================================
@@ -0,0 +1,6 @@
+A A2
+-this-unit-id u1
+-working-dir t25139
+-i
+-iu1src
+
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A.hs
=====================================
@@ -0,0 +1,3 @@
+module A where
+
+a = 2
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A1.hs
=====================================
@@ -0,0 +1,3 @@
+module A1 where
+
+a1 = "a1"
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u1src/A2.hs
=====================================
@@ -0,0 +1,3 @@
+module A2 where
+
+a2 = "a2"
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u2
=====================================
@@ -0,0 +1,12 @@
+U
+-package-id u1
+-reexported-module "A as B"
+-reexported-module "A1 as B1"
+-reexported-module "A2 as B2"
+-reexported-module "A2 as B3"
+-reexported-module "A1 as B4"
+-reexported-module "A2 as B4"
+-this-unit-id u2
+-working-dir t25139
+-i
+-iu2src
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u2src/U.hs
=====================================
@@ -0,0 +1,3 @@
+module U where
+
+u = 1
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u3
=====================================
@@ -0,0 +1,7 @@
+C
+-package-id u2
+-this-unit-id u3
+-working-dir t25139
+-reexported-module "B as E"
+-i
+-iu3src
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u3src/C.hs
=====================================
@@ -0,0 +1,11 @@
+module C where
+
+import B
+import B1
+import B2
+import B3
+import qualified B4 as B4
+
+c = a
+
+im = B4.a2
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u4
=====================================
@@ -0,0 +1,8 @@
+U4
+-package-id u2
+-package-id u3
+-this-unit-id u4
+-working-dir t25139
+-i
+-iu4src
+
=====================================
testsuite/tests/driver/multipleHomeUnits/t25139/u4src/U4.hs
=====================================
@@ -0,0 +1,6 @@
+module U4 where
+
+import B
+import E
+
+u4 = a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aaaad2d114fc3f3d961b5ecf83d6a5b4b510eedc...0663dd067c91d12a721a04cdb1789df6f4947206
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aaaad2d114fc3f3d961b5ecf83d6a5b4b510eedc...0663dd067c91d12a721a04cdb1789df6f4947206
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/20240814/b841fba6/attachment-0001.html>
More information about the ghc-commits
mailing list