[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix sharing of 'IfaceTyConInfo' during core to iface type translation
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Mar 19 12:17:12 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
73be65ab by Fendor at 2024-03-19T01:42:53-04:00
Fix sharing of 'IfaceTyConInfo' during core to iface type translation
During heap analysis, we noticed that during generation of
'mi_extra_decls' we have lots of duplicates for the instances:
* `IfaceTyConInfo NotPromoted IfaceNormalTyCon`
* `IfaceTyConInfo IsPromoted IfaceNormalTyCon`
which should be shared instead of duplicated. This duplication increased
the number of live bytes by around 200MB while loading the agda codebase
into GHCi.
These instances are created during `CoreToIface` translation, in
particular `toIfaceTyCon`.
The generated core looks like:
toIfaceTyCon
= \ tc_sjJw ->
case $wtoIfaceTyCon tc_sjJw of
{ (# ww_sjJz, ww1_sjNL, ww2_sjNM #) ->
IfaceTyCon ww_sjJz (IfaceTyConInfo ww1_sjNL ww2_sjNM)
}
whichs removes causes the sharing to work propery.
Adding explicit sharing, with NOINLINE annotations, changes the core to:
toIfaceTyCon
= \ tc_sjJq ->
case $wtoIfaceTyCon tc_sjJq of { (# ww_sjNB, ww1_sjNC #) ->
IfaceTyCon ww_sjNB ww1_sjNC
}
which looks much more like sharing is happening.
We confirmed via ghc-debug that all duplications were eliminated and the
number of live bytes are noticeably reduced.
- - - - -
bd8209eb by Alan Zimmerman at 2024-03-19T01:43:28-04:00
EPA: Address more 9.10.1-alpha1 regressions from recent changes
Closes #24533
Hopefully for good this time
- - - - -
ebaaf32c by Matthew Pickering at 2024-03-19T08:16:58-04:00
Read global package database from settings file
Before this patch, the global package database was always assumed to be
in libdir </> package.conf.d.
This causes issues in GHC's build system because there are sometimes
situations where the package database you need to use is not located in
the same place as the settings file.
* The stage1 compiler needs to use stage1 libraries, so we should set
"Global Package DB" for the stage1 compiler to the stage1 package
database.
* Stage 2 cross compilers need to use stage2 libraries, so likewise, we
should set the package database path to `_build/stage2/lib/`
* The normal situation is where the stage2 compiler uses stage1
libraries. Then everything lines up.
* When installing we have rearranged everything so that the settings
file and package database line up properly, so then everything should
continue to work as before. In this case we set the relative package
db path to `package.conf.d`, so it resolves the same as before.
* ghc-pkg needs to be modified as well to look in the settings file fo
the package database rather than assuming the global package database
location relative to the lib folder.
* Cabal/cabal-install will work correctly because they query the global
package database using `--print-global-package-db`.
A reasonable question is why not generate the "right" settings files in
the right places in GHC's build system. In order to do this you would
need to engineer wrappers for all executables to point to a specific
libdir. There are also situations where the same package db is used by
two different compilers with two different settings files (think stage2
cross compiler and stage3 compiler).
In short, this 10 line patch allows for some reasonable simplifications
in Hadrian at very little cost to anything else.
Fixes #24502
- - - - -
7059ffa8 by Matthew Pickering at 2024-03-19T08:16:58-04:00
hadrian: Remove stage1 testsuite wrappers logic
Now instead of producing wrappers which pass the global package database
argument to ghc and ghc-pkg, we write the location of the correct
package database into the settings file so you can just use the intree
compiler directly.
- - - - -
14a7e8f4 by Bryan Richter at 2024-03-19T08:16:58-04:00
testsuite: Disable T21336a on wasm
- - - - -
15 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Settings/IO.hs
- hadrian/bindist/Makefile
- hadrian/src/Oracles/TestSettings.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Test.hs
- libraries/base/tests/IO/T21336/all.T
- libraries/ghc-boot/GHC/Settings/Utils.hs
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test24533.hs
- testsuite/tests/printer/Test24533.stdout
- utils/ghc-pkg/Main.hs
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3611,7 +3611,8 @@ compilerInfo dflags
("GHC Profiled", showBool hostIsProfiled),
("Debug on", showBool debugIsOn),
("LibDir", topDir dflags),
- -- The path of the global package database used by GHC
+ -- This is always an absolute path, unlike "Relative Global Package DB" which is
+ -- in the settings file.
("Global Package DB", globalPackageDatabasePath dflags)
]
where
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -361,12 +361,51 @@ data IfaceTyConInfo -- Used only to guide pretty-printing
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
--- This smart constructor allows sharing of the two most common
--- cases. See #19194
+-- | This smart constructor allows sharing of the two most common
+-- cases. See Note [Sharing IfaceTyConInfo]
mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo
-mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = IfaceTyConInfo IsPromoted IfaceNormalTyCon
-mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon
-mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo
+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+
+{-# NOINLINE promotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+promotedNormalTyConInfo :: IfaceTyConInfo
+promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
+
+{-# NOINLINE notPromotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+notPromotedNormalTyConInfo :: IfaceTyConInfo
+notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+{-
+Note [Sharing IfaceTyConInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example.
+But almost all of them are
+
+ IfaceTyConInfo IsPromoted IfaceNormalTyCon
+ IfaceTyConInfo NotPromoted IfaceNormalTyCon.
+
+The smart constructor `mkIfaceTyConInfo` arranges to share these instances,
+thus:
+
+ promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
+ notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+ mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo
+ mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+ mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort
+
+But ALAS, the (nested) CPR transform can lose this sharing, completely
+negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326.
+
+Sticking-plaster solution: add a NOINLINE pragma to those top-level constants.
+When we fix the CPR bug we can remove the NOINLINE pragmas.
+
+This one change leads to an 15% reduction in residency for GHC when embedding
+'mi_extra_decls': see !12222.
+-}
data IfaceMCoercion
= IfaceMRefl
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1237,12 +1237,12 @@ topdecl_cs : topdecl {% commentsPA $1 }
-----------------------------------------------------------------------------
topdecl :: { LHsDecl GhcPs }
- : cl_decl { sL1a $1 (TyClD noExtField (unLoc $1)) }
- | ty_decl { sL1a $1 (TyClD noExtField (unLoc $1)) }
- | standalone_kind_sig { sL1a $1 (KindSigD noExtField (unLoc $1)) }
- | inst_decl { sL1a $1 (InstD noExtField (unLoc $1)) }
- | stand_alone_deriving { sL1a $1 (DerivD noExtField (unLoc $1)) }
- | role_annot { sL1a $1 (RoleAnnotD noExtField (unLoc $1)) }
+ : cl_decl { L (getLoc $1) (TyClD noExtField (unLoc $1)) }
+ | ty_decl { L (getLoc $1) (TyClD noExtField (unLoc $1)) }
+ | standalone_kind_sig { L (getLoc $1) (KindSigD noExtField (unLoc $1)) }
+ | inst_decl { L (getLoc $1) (InstD noExtField (unLoc $1)) }
+ | stand_alone_deriving { L (getLoc $1) (DerivD noExtField (unLoc $1)) }
+ | role_annot { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }
| 'default' '(' comma_types0 ')' {% amsA' (sLL $1 $>
(DefD noExtField (DefaultDecl [mj AnnDefault $1,mop $2,mcp $4] $3))) }
| 'foreign' fdecl {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -943,11 +943,13 @@ checkTyVars pp_what equals_or_where tc tparms
-- Keep around an action for adjusting the annotations of extra parens
chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs
-> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
- chkParens ops cps bvis (L l (HsParTy _ ty))
+ chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))
= let
(o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+ lcs = epAnnComments l
+ lt' = setCommentsEpAnn lt lcs
in
- chkParens (o:ops) (c:cps) bvis ty
+ chkParens (o:ops) (c:cps) bvis (L lt' ty)
chkParens ops cps bvis ty = chk ops cps bvis ty
-- Check that the name space is correct!
=====================================
compiler/GHC/Settings/IO.hs
=====================================
@@ -112,8 +112,14 @@ initSettings top_dir = do
ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
arSupportsDashL <- getBooleanSetting "ar supports -L"
- let globalpkgdb_path = installed "package.conf.d"
- ghc_usage_msg_path = installed "ghc-usage.txt"
+
+ -- The package database is either a relative path to the location of the settings file
+ -- OR an absolute path.
+ -- In case the path is absolute then top_dir </> abs_path == abs_path
+ -- the path is relative then top_dir </> rel_path == top_dir </> rel_path
+ globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB"
+
+ let ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
-- For all systems, unlit, split, mangle are GHC utilities
=====================================
hadrian/bindist/Makefile
=====================================
@@ -141,6 +141,7 @@ lib/settings : config.mk
@echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@
@echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@
@echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@
+ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@
@echo "]" >> $@
# We need to install binaries relative to libraries.
=====================================
hadrian/src/Oracles/TestSettings.hs
=====================================
@@ -13,8 +13,6 @@ import Hadrian.Oracles.TextFile
import Oracles.Setting (topDirectory, setting, Setting(..))
import Packages
import Settings.Program (programContext)
-import Hadrian.Oracles.Path
-import System.Directory (makeAbsolute)
testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
@@ -81,15 +79,12 @@ testRTSSettings = do
file <- testConfigFile
words <$> lookupValueOrError Nothing file "GhcRTSWays"
-absoluteBuildRoot :: Action FilePath
-absoluteBuildRoot = (fixAbsolutePathOnWindows =<< liftIO . makeAbsolute =<< buildRoot)
-
-- | Directory to look for binaries.
-- We assume that required programs are present in the same binary directory
-- in which ghc is stored and that they have their conventional name.
getBinaryDirectory :: String -> Action FilePath
getBinaryDirectory "stage0" = takeDirectory <$> setting SystemGhc
-getBinaryDirectory "stage1" = liftM2 (-/-) absoluteBuildRoot (pure "stage1-test/bin/")
+getBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath stage0InTree)
getBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
getBinaryDirectory "stage3" = liftM2 (-/-) topDirectory (stageBinPath Stage2)
getBinaryDirectory "stage-cabal" = do
@@ -101,7 +96,7 @@ getBinaryDirectory compiler = pure $ takeDirectory compiler
-- | Get the path to the given @--test-compiler at .
getCompilerPath :: String -> Action FilePath
getCompilerPath "stage0" = setting SystemGhc
-getCompilerPath "stage1" = liftM2 (-/-) absoluteBuildRoot (pure ("stage1-test/bin/ghc" <.> exe))
+getCompilerPath "stage1" = liftM2 (-/-) topDirectory (fullPath stage0InTree ghc)
getCompilerPath "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
getCompilerPath "stage3" = liftM2 (-/-) topDirectory (fullPath Stage2 ghc)
getCompilerPath "stage-cabal" = do
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -234,8 +234,8 @@ generateRules = do
forM_ allStages $ \stage -> do
let prefix = root -/- stageString stage -/- "lib"
- go gen file = generate file (semiEmptyTarget stage) gen
- (prefix -/- "settings") %> go generateSettings
+ go gen file = generate file (semiEmptyTarget (succStage stage)) gen
+ (prefix -/- "settings") %> \out -> go (generateSettings out) out
where
file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out
@@ -355,21 +355,26 @@ templateRules = do
ghcWrapper :: Stage -> Expr String
ghcWrapper (Stage0 {}) = error "Stage0 GHC does not require a wrapper script to run."
ghcWrapper stage = do
- dbPath <- expr $ (</>) <$> topDirectory <*> packageDbPath (PackageDbLoc stage Final)
ghcPath <- expr $ (</>) <$> topDirectory
<*> programPath (vanillaContext (predStage stage) ghc)
return $ unwords $ map show $ [ ghcPath ]
- ++ (if stage == Stage1
- then ["-no-global-package-db"
- , "-package-env=-"
- , "-package-db " ++ dbPath
- ]
- else [])
++ [ "$@" ]
-generateSettings :: Expr String
-generateSettings = do
+generateSettings :: FilePath -> Expr String
+generateSettings settingsFile = do
ctx <- getContext
+ stage <- getStage
+
+ package_db_path <- expr $ do
+ let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final)
+ case stage of
+ Stage0 {} -> error "Unable to generate settings for stage0"
+ Stage1 -> get_pkg_db Stage1
+ Stage2 -> get_pkg_db Stage1
+ Stage3 -> get_pkg_db Stage2
+
+ let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path
+
settings <- traverse sequence $
[ ("C compiler command", queryTarget ccPath)
, ("C compiler flags", queryTarget ccFlags)
@@ -421,6 +426,7 @@ generateSettings = do
, ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore))
, ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors)
, ("RTS expects libdw", yesNo <$> getFlag UseLibdw)
+ , ("Relative Global Package DB", pure rel_pkg_db)
]
let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"
pure $ case settings of
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -124,28 +124,6 @@ testRules = do
testsuiteDeps
- -- we need to create wrappers to test the stage1 compiler
- -- as the stage1 compiler needs the stage2 libraries
- -- to have any hope of passing tests.
- root -/- "stage1-test/bin/*" %> \path -> do
-
- bin_path <- stageBinPath stage0InTree
- let prog = takeBaseName path
- stage0prog = bin_path -/- prog <.> exe
- need [stage0prog]
- abs_prog_path <- liftIO (IO.canonicalizePath stage0prog)
- -- Use the stage1 package database
- pkgDb <- liftIO . IO.makeAbsolute =<< packageDbPath (PackageDbLoc Stage1 Final)
- if prog `elem` ["ghc","runghc"] then do
- let flags = [ "-no-global-package-db", "-no-user-package-db", "-hide-package", "ghc" , "-package-env","-","-package-db",pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else if prog == "ghc-pkg" then do
- let flags = ["--no-user-package-db", "--global-package-db", pkgDb]
- writeFile' path $ unlines ["#!/bin/sh",unwords ((abs_prog_path : flags) ++ ["${1+\"$@\"}"])]
- makeExecutable path
- else createFileLink abs_prog_path path
-
-- Rules for building check-ppr, check-exact and
-- check-ppr-annotations with the compiler we are going to test
-- (in-tree or out-of-tree).
@@ -344,18 +322,6 @@ needTestsuitePackages stg = do
need =<< mapM (uncurry pkgFile) pkgs
cross <- flag CrossCompiling
when (not cross) $ needIservBins stg
- root <- buildRoot
- -- require the shims for testing stage1
- when (stg == stage0InTree) $ do
- -- Windows not supported as the wrapper scripts don't work on windows.. we could
- -- support it with a separate .bat or C wrapper code path but seems overkill when no-one will
- -- probably ever try and do this.
- when windowsHost $ do
- putFailure $ unlines [ "Testing stage1 compiler with windows is currently unsupported,"
- , "if you desire to do this then please open a ticket"]
- fail "Testing stage1 is not supported"
-
- need =<< sequence [(\f -> root -/- "stage1-test/bin" -/- takeFileName f) <$> (pkgFile stage0InTree p) | (Stage0 InTreeLibs,p) <- exepkgs]
-- stage 1 ghc lives under stage0/bin,
-- stage 2 ghc lives under stage1/bin, etc
=====================================
libraries/base/tests/IO/T21336/all.T
=====================================
@@ -3,6 +3,10 @@ test('T21336a',
[ unless(opsys('linux') or opsys('freebsd'), skip)
, js_broken(22261)
, fragile(22022)
+ # More than fragile, the test is failing consistently on wasm. See #22022.
+ # It would be nice to see if the test is NOT fragile on the other
+ # architectures, but right now I don't know how to check.
+ , when(arch('wasm32'), skip)
, extra_files(['FinalizerExceptionHandler.hs'])
],
compile_and_run, [''])
=====================================
libraries/ghc-boot/GHC/Settings/Utils.hs
=====================================
@@ -8,6 +8,7 @@ import qualified Data.Map as Map
import GHC.BaseDir
import GHC.Platform.ArchOS
+import System.FilePath
maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
@@ -42,6 +43,12 @@ getTargetArchOS settingsFile settings =
ArchOS <$> readRawSetting settingsFile settings "target arch"
<*> readRawSetting settingsFile settings "target os"
+getGlobalPackageDb :: FilePath -> RawSettings -> Either String FilePath
+getGlobalPackageDb settingsFile settings = do
+ rel_db <- getRawSetting settingsFile settings "Relative Global Package DB"
+ return (dropFileName settingsFile </> rel_db)
+
+
getRawSetting
:: FilePath -> RawSettings -> String -> Either String String
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -212,7 +212,10 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen AnnParens (EpaSpan { DumpSemis.hs:9:11 }) (EpaSpan { DumpSemis.hs:9:12 }))
+ (AnnParen
+ AnnParens
+ (EpaSpan { DumpSemis.hs:9:11 })
+ (EpaSpan { DumpSemis.hs:9:12 }))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
@@ -498,7 +501,10 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen AnnParens (EpaSpan { DumpSemis.hs:14:11 }) (EpaSpan { DumpSemis.hs:14:12 }))
+ (AnnParen
+ AnnParens
+ (EpaSpan { DumpSemis.hs:14:11 })
+ (EpaSpan { DumpSemis.hs:14:12 }))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
@@ -747,7 +753,10 @@
(EpaComments
[]))
(HsTupleTy
- (AnnParen AnnParens (EpaSpan { DumpSemis.hs:21:11 }) (EpaSpan { DumpSemis.hs:21:12 }))
+ (AnnParen
+ AnnParens
+ (EpaSpan { DumpSemis.hs:21:11 })
+ (EpaSpan { DumpSemis.hs:21:12 }))
(HsBoxedOrConstraintTuple)
[]))))))))))
,(L
=====================================
testsuite/tests/printer/Test24533.hs
=====================================
@@ -6,3 +6,9 @@ instance
Read b
) =>
Read (a, b)
+
+class Foo (a :: Type {- Weird -})
+
+instance Eq Foo where
+ -- Weird
+ Foo == Foo = True
=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -13,8 +13,8 @@
[]
(Just
((,)
- { Test24533.hs:9:1 }
- { Test24533.hs:8:13 })))
+ { Test24533.hs:15:1 }
+ { Test24533.hs:14:16-19 })))
(EpaCommentsBalanced
[(L
(EpaSpan
@@ -273,6 +273,323 @@
[]
[]
[]
+ (Nothing)))))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:1-33 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (TyClD
+ (NoExtField)
+ (ClassDecl
+ ((,,)
+ [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:10:1-5 }))]
+ (EpNoLayout)
+ (NoAnnSortKey))
+ (Nothing)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:7-9 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (HsQTvs
+ (NoExtField)
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:11-33 })
+ (AnnListItem
+ [])
+ (EpaComments
+ [(L
+ (EpaSpan
+ { Test24533.hs:10:22-32 })
+ (EpaComment
+ (EpaBlockComment
+ "{- Weird -}")
+ { Test24533.hs:10:17-20 }))]))
+ (KindedTyVar
+ [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:10:11 }))
+ ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:10:33 }))
+ ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:10:14-15 }))]
+ (HsBndrRequired
+ (NoExtField))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:12 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: a}))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:17-20 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:10:17-20 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Type}))))))])
+ (Prefix)
+ []
+ []
+ {Bag(LocatedA (HsBind GhcPs)):
+ []}
+ []
+ []
+ [])))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:(12,1)-(14,19) })
+ (AnnListItem
+ [])
+ (EpaComments
+ [(L
+ (EpaSpan
+ { Test24533.hs:13:3-10 })
+ (EpaComment
+ (EpaLineComment
+ "-- Weird")
+ { Test24533.hs:12:17-21 }))]))
+ (InstD
+ (NoExtField)
+ (ClsInstD
+ (NoExtField)
+ (ClsInstDecl
+ ((,,)
+ (Nothing)
+ [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:12:1-8 }))
+ ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:12:17-21 }))]
+ (NoAnnSortKey))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:10-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:10-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsAppTy
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:10-11 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:10-11 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Eq}))))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:13-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:12:13-15 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))))))))
+ {Bag(LocatedA (HsBind GhcPs)):
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (FunBind
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:7-8 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: ==}))
+ (MG
+ (FromSource)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-19 })
+ (AnnList
+ (Nothing)
+ (Nothing)
+ (Nothing)
+ []
+ [])
+ (EpaComments
+ []))
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (Match
+ []
+ (FunRhs
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:7-8 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: ==}))
+ (Infix)
+ (NoSrcStrict))
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-5 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (VisPat
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-5 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (ConPat
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:3-5 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (PrefixCon
+ []
+ [])))))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:10-12 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (VisPat
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:10-12 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (ConPat
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:10-12 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (PrefixCon
+ []
+ [])))))]
+ (GRHSs
+ (EpaComments
+ [])
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:14-19 })
+ (NoEpAnns)
+ (EpaComments
+ []))
+ (GRHS
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:14-19 })
+ (GrhsAnn
+ (Nothing)
+ (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:14:14 })))
+ (EpaComments
+ []))
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:16-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsVar
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.hs:14:16-19 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: True}))))))]
+ (EmptyLocalBinds
+ (NoExtField)))))]))))]}
+ []
+ []
+ []
(Nothing)))))]))
@@ -291,8 +608,8 @@
[]
(Just
((,)
- { Test24533.ppr.hs:3:41 }
- { Test24533.ppr.hs:3:40 })))
+ { Test24533.ppr.hs:6:20 }
+ { Test24533.ppr.hs:6:16-19 })))
(EpaCommentsBalanced
[(L
(EpaSpan
@@ -545,4 +862,311 @@
[]
[]
[]
- (Nothing)))))]))
\ No newline at end of file
+ (Nothing)))))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:1-21 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (TyClD
+ (NoExtField)
+ (ClassDecl
+ ((,,)
+ [(AddEpAnn AnnClass (EpaSpan { Test24533.ppr.hs:4:1-5 }))]
+ (EpNoLayout)
+ (NoAnnSortKey))
+ (Nothing)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:7-9 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (HsQTvs
+ (NoExtField)
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:11-21 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (KindedTyVar
+ [(AddEpAnn AnnOpenP (EpaSpan { Test24533.ppr.hs:4:11 }))
+ ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.ppr.hs:4:21 }))
+ ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.ppr.hs:4:14-15 }))]
+ (HsBndrRequired
+ (NoExtField))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:12 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: a}))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:17-20 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:4:17-20 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Type}))))))])
+ (Prefix)
+ []
+ []
+ {Bag(LocatedA (HsBind GhcPs)):
+ []}
+ []
+ []
+ [])))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:(5,1)-(6,19) })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (InstD
+ (NoExtField)
+ (ClsInstD
+ (NoExtField)
+ (ClsInstDecl
+ ((,,)
+ (Nothing)
+ [(AddEpAnn AnnInstance (EpaSpan { Test24533.ppr.hs:5:1-8 }))
+ ,(AddEpAnn AnnWhere (EpaSpan { Test24533.ppr.hs:5:17-21 }))]
+ (NoAnnSortKey))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:10-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsSig
+ (NoExtField)
+ (HsOuterImplicit
+ (NoExtField))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:10-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsAppTy
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:10-11 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:10-11 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Eq}))))
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:13-15 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsTyVar
+ []
+ (NotPromoted)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:5:13-15 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))))))))
+ {Bag(LocatedA (HsBind GhcPs)):
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (FunBind
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:7-8 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: ==}))
+ (MG
+ (FromSource)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-19 })
+ (AnnList
+ (Nothing)
+ (Nothing)
+ (Nothing)
+ []
+ [])
+ (EpaComments
+ []))
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (Match
+ []
+ (FunRhs
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:7-8 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: ==}))
+ (Infix)
+ (NoSrcStrict))
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-5 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (VisPat
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-5 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (ConPat
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:3-5 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (PrefixCon
+ []
+ [])))))
+ ,(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:10-12 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (VisPat
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:10-12 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (ConPat
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:10-12 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: Foo}))
+ (PrefixCon
+ []
+ [])))))]
+ (GRHSs
+ (EpaComments
+ [])
+ [(L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:14-19 })
+ (NoEpAnns)
+ (EpaComments
+ []))
+ (GRHS
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:14-19 })
+ (GrhsAnn
+ (Nothing)
+ (AddEpAnn AnnEqual (EpaSpan { Test24533.ppr.hs:6:14 })))
+ (EpaComments
+ []))
+ []
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:16-19 })
+ (AnnListItem
+ [])
+ (EpaComments
+ []))
+ (HsVar
+ (NoExtField)
+ (L
+ (EpAnn
+ (EpaSpan { Test24533.ppr.hs:6:16-19 })
+ (NameAnnTrailing
+ [])
+ (EpaComments
+ []))
+ (Unqual
+ {OccName: True}))))))]
+ (EmptyLocalBinds
+ (NoExtField)))))]))))]}
+ []
+ []
+ []
+ (Nothing)))))]))
+
+
=====================================
utils/ghc-pkg/Main.hs
=====================================
@@ -28,7 +28,7 @@ import qualified GHC.Unit.Database as GhcPkg
import GHC.Unit.Database hiding (mkMungePathUrl)
import GHC.HandleEncoding
import GHC.BaseDir (getBaseDir)
-import GHC.Settings.Utils (getTargetArchOS, maybeReadFuzzy)
+import GHC.Settings.Utils (getTargetArchOS, maybeReadFuzzy, getGlobalPackageDb, RawSettings)
import GHC.Platform.Host (hostPlatformArchOS)
import GHC.UniqueSubdir (uniqueSubdir)
import qualified GHC.Data.ShortText as ST
@@ -582,6 +582,21 @@ allPackagesInStack = concatMap packages
stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
stackUpTo to_modify = dropWhile ((/= to_modify) . location)
+readFromSettingsFile :: FilePath
+ -> (FilePath -> RawSettings -> Either String b)
+ -> IO (Either String b)
+readFromSettingsFile settingsFile f = do
+ settingsStr <- readFile settingsFile
+ pure $ do
+ mySettings <- case maybeReadFuzzy settingsStr of
+ Just s -> pure $ Map.fromList s
+ -- It's excusable to not have a settings file (for now at
+ -- least) but completely inexcusable to have a malformed one.
+ Nothing -> Left $ "Can't parse settings file " ++ show settingsFile
+ case f settingsFile mySettings of
+ Right archOS -> Right archOS
+ Left e -> Left e
+
getPkgDatabases :: Verbosity
-> GhcPkg.DbOpenMode mode DbModifySelector
-> Bool -- use the user db
@@ -605,24 +620,38 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- location is passed to the binary using the --global-package-db flag by the
-- wrapper script.
let err_msg = "missing --global-package-db option, location of global package database unknown\n"
- global_conf <-
+ (top_dir, global_conf) <-
case [ f | FlagGlobalConfig f <- my_flags ] of
-- See Note [Base Dir] for more information on the base dir / top dir.
[] -> do mb_dir <- getBaseDir
case mb_dir of
Nothing -> die err_msg
Just dir -> do
- r <- lookForPackageDBIn dir
- case r of
- Nothing -> die ("Can't find package database in " ++ dir)
- Just path -> return path
- fs -> return (last fs)
-
- -- The value of the $topdir variable used in some package descriptions
- -- Note that the way we calculate this is slightly different to how it
- -- is done in ghc itself. We rely on the convention that the global
- -- package db lives in ghc's libdir.
- top_dir <- absolutePath (takeDirectory global_conf)
+ -- Look for where it is given in the settings file, if marked there.
+ let settingsFile = dir </> "settings"
+ exists_settings_file <- doesFileExist settingsFile
+ erel_db <-
+ if exists_settings_file
+ then readFromSettingsFile settingsFile getGlobalPackageDb
+ else pure (Left ("Settings file doesn't exist: " ++ settingsFile))
+
+ case erel_db of
+ Right rel_db -> return (dir, dir </> rel_db)
+ -- If the version of GHC doesn't have this field or the settings file
+ -- doesn't exist for some reason, look in the libdir.
+ Left err -> do
+ r <- lookForPackageDBIn dir
+ case r of
+ Nothing -> die (unlines [err, ("Fallback: Can't find package database in " ++ dir)])
+ Just path -> return (dir, path)
+ fs -> do
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ let pkg_db = last fs
+ top_dir <- absolutePath (takeDirectory pkg_db)
+ return (top_dir, pkg_db)
let no_user_db = FlagNoUserDb `elem` my_flags
@@ -641,16 +670,11 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
warn "cannot know target platform so guessing target == host (native compiler)."
pure hostPlatformArchOS
- True -> do
- settingsStr <- readFile settingsFile
- mySettings <- case maybeReadFuzzy settingsStr of
- Just s -> pure $ Map.fromList s
- -- It's excusable to not have a settings file (for now at
- -- least) but completely inexcusable to have a malformed one.
- Nothing -> die $ "Can't parse settings file " ++ show settingsFile
- case getTargetArchOS settingsFile mySettings of
- Right archOS -> pure archOS
+ True ->
+ readFromSettingsFile settingsFile getTargetArchOS >>= \case
+ Right v -> pure v
Left e -> die e
+
let subdir = uniqueSubdir targetArchOS
getFirstSuccess :: [IO a] -> IO (Maybe a)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb64a4282009f5707290d4d5c04a818b542467a3...14a7e8f4e8e040a6409d16b54b3aee4902240cc0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb64a4282009f5707290d4d5c04a818b542467a3...14a7e8f4e8e040a6409d16b54b3aee4902240cc0
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/20240319/b3227722/attachment-0001.html>
More information about the ghc-commits
mailing list