[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Add missing int64/word64-to-double/float rules (#23907)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Sep 15 05:45:13 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ba3b27c1 by Sylvain Henry at 2023-09-15T01:44:58-04:00
Add missing int64/word64-to-double/float rules (#23907)
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/203
- - - - -
9d8f3aad by doyougnu at 2023-09-15T01:45:00-04:00
utils: remove ghc-cabal
- Closes #16459
- - - - -
7be210dc by doyougnu at 2023-09-15T01:45:00-04:00
Needs review: remove ghc-cabal workaround in m4
- - - - -
12 changed files:
- compiler/GHC/Unit/Info.hs
- hadrian/doc/debugging.md
- hadrian/src/Rules/Documentation.hs
- libraries/base/GHC/Float.hs
- libraries/base/changelog.md
- m4/fp_prog_ar_needs_ranlib.m4
- + testsuite/tests/numeric/should_compile/T23907.hs
- + testsuite/tests/numeric/should_compile/T23907.stderr
- testsuite/tests/numeric/should_compile/all.T
- − utils/ghc-cabal/Main.hs
- − utils/ghc-cabal/Makefile
- − utils/ghc-cabal/ghc-cabal.cabal
Changes:
=====================================
compiler/GHC/Unit/Info.hs
=====================================
@@ -234,8 +234,7 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar
-- will eventually be unused.
--
-- This change elevates the need to add custom hooks
- -- and handling specifically for the `rts` package for
- -- example in ghc-cabal.
+ -- and handling specifically for the `rts` package
addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag)
addSuffix other_lib = other_lib ++ (expandTag tag)
=====================================
hadrian/doc/debugging.md
=====================================
@@ -40,7 +40,8 @@ Adding `-V`, `-VV`, `-VVV` can output more information from Shake and Hadrian fo
#### Type 2: `Error when running Shake build system:`
-Example:
+Note that `ghc-cabal` is no longer used so your output will likely differ. That
+being said, this example is still useful. Example:
```
Error when running Shake build system:
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -256,7 +256,6 @@ buildPackageDocumentation = do
-- Per-package haddocks
root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do
ctx <- pkgDocContext <$> getPkgDocTarget root file
- -- This is how @ghc-cabal@ used to produces "haddock-prologue.txt" files.
syn <- pkgSynopsis (Context.package ctx)
desc <- pkgDescription (Context.package ctx)
let prologue = if null desc then syn else desc
=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -1810,3 +1810,22 @@ foreign import prim "stg_doubleToWord64zh"
"Word# -> Natural -> Double#"
forall x. naturalToDouble# (NS x) = word2Double# x #-}
+
+-- We don't have word64ToFloat/word64ToDouble primops (#23908), only
+-- word2Float/word2Double, so we can only perform these transformations when
+-- word-size is 64-bit.
+#if WORD_SIZE_IN_BITS == 64
+{-# RULES
+
+"Int64# -> Integer -> Float#"
+ forall x. integerToFloat# (integerFromInt64# x) = int2Float# (int64ToInt# x)
+
+"Int64# -> Integer -> Double#"
+ forall x. integerToDouble# (integerFromInt64# x) = int2Double# (int64ToInt# x)
+
+"Word64# -> Integer -> Float#"
+ forall x. integerToFloat# (integerFromWord64# x) = word2Float# (word64ToWord# x)
+
+"Word64# -> Integer -> Double#"
+ forall x. integerToDouble# (integerFromWord64# x) = word2Double# (word64ToWord# x) #-}
+#endif
=====================================
libraries/base/changelog.md
=====================================
@@ -4,6 +4,7 @@
* Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))
* Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #174](https://github.com/haskell/core-libraries-committee/issues/175))
* The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
+ * Add rewrite rules for conversion between Int64/Word64 and Float/Double on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
## 4.19.0.0 *TBA*
* Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.
=====================================
m4/fp_prog_ar_needs_ranlib.m4
=====================================
@@ -27,16 +27,6 @@ AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],[
esac
fi
- # workaround for AC_PROG_RANLIB which sets RANLIB to `:' when
- # ranlib is missing on the target OS. The problem is that
- # ghc-cabal cannot execute `:' which is a shell built-in but can
- # execute `true' which is usually simple program supported by the
- # OS.
- # Fixes #8795
- if test "$RANLIB" = ":"
- then
- RANLIB="true"
- fi
REAL_RANLIB_CMD="$RANLIB"
if test $fp_cv_prog_ar_needs_ranlib = yes
then
=====================================
testsuite/tests/numeric/should_compile/T23907.hs
=====================================
@@ -0,0 +1,67 @@
+module T23907 (loop) where
+
+import Data.Word
+import Data.Bits
+
+{-# NOINLINE loop #-}
+loop :: Int -> Double -> SMGen -> (Double, SMGen)
+loop 0 !a !s = (a, s)
+loop n !a !s = loop (n - 1) (a + b) t where (b, t) = nextDouble s
+
+mix64 :: Word64 -> Word64
+mix64 z0 =
+ -- MurmurHash3Mixer
+ let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0
+ z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1
+ z3 = shiftXor 33 z2
+ in z3
+
+shiftXor :: Int -> Word64 -> Word64
+shiftXor n w = w `xor` (w `shiftR` n)
+
+shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
+shiftXorMultiply n k w = shiftXor n w * k
+
+nextWord64 :: SMGen -> (Word64, SMGen)
+nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma)
+ where
+ seed' = seed + gamma
+
+nextDouble :: SMGen -> (Double, SMGen)
+nextDouble g = case nextWord64 g of
+ (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g')
+
+data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd
+
+mkSMGen :: Word64 -> SMGen
+mkSMGen s = SMGen (mix64 s) (mixGamma (s + goldenGamma))
+
+goldenGamma :: Word64
+goldenGamma = 0x9e3779b97f4a7c15
+
+floatUlp :: Float
+floatUlp = 1.0 / fromIntegral (1 `shiftL` 24 :: Word32)
+
+doubleUlp :: Double
+doubleUlp = 1.0 / fromIntegral (1 `shiftL` 53 :: Word64)
+
+mix64variant13 :: Word64 -> Word64
+mix64variant13 z0 =
+ -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer
+ -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html
+ --
+ -- Stafford's Mix13
+ let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants
+ z2 = shiftXorMultiply 27 0x94d049bb133111eb z1
+ z3 = shiftXor 31 z2
+ in z3
+
+mixGamma :: Word64 -> Word64
+mixGamma z0 =
+ let z1 = mix64variant13 z0 .|. 1 -- force to be odd
+ n = popCount (z1 `xor` (z1 `shiftR` 1))
+ -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html
+ -- let's trust the text of the paper, not the code.
+ in if n >= 24
+ then z1
+ else z1 `xor` 0xaaaaaaaaaaaaaaaa
=====================================
testsuite/tests/numeric/should_compile/T23907.stderr
=====================================
@@ -0,0 +1,57 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 90, types: 62, coercions: 0, joins: 0/3}
+
+$WSMGen
+ = \ conrep conrep1 ->
+ case conrep of { W64# unbx ->
+ case conrep1 of { W64# unbx1 -> SMGen unbx unbx1 }
+ }
+
+Rec {
+$wloop
+ = \ ww ww1 ww2 ww3 ->
+ case ww of ds {
+ __DEFAULT ->
+ let { seed' = plusWord64# ww2 ww3 } in
+ let {
+ x#
+ = timesWord64#
+ (xor64# seed' (uncheckedShiftRL64# seed' 33#))
+ 18397679294719823053#Word64 } in
+ let {
+ x#1
+ = timesWord64#
+ (xor64# x# (uncheckedShiftRL64# x# 33#))
+ 14181476777654086739#Word64 } in
+ $wloop
+ (-# ds 1#)
+ (+##
+ ww1
+ (*##
+ (word2Double#
+ (word64ToWord#
+ (uncheckedShiftRL64#
+ (xor64# x#1 (uncheckedShiftRL64# x#1 33#)) 11#)))
+ 1.1102230246251565e-16##))
+ seed'
+ ww3;
+ 0# -> (# ww1, ww2, ww3 #)
+ }
+end Rec }
+
+loop
+ = \ ds a s ->
+ case ds of { I# ww ->
+ case a of { D# ww1 ->
+ case s of { SMGen ww2 ww3 ->
+ case $wloop ww ww1 ww2 ww3 of { (# ww4, ww5, ww6 #) ->
+ (D# ww4, SMGen ww5 ww6)
+ }
+ }
+ }
+ }
+
+
+
=====================================
testsuite/tests/numeric/should_compile/all.T
=====================================
@@ -20,3 +20,4 @@ test('T20448', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b
test('T19641', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
test('T23019', normal, compile, ['-O'])
+test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
=====================================
utils/ghc-cabal/Main.hs deleted
=====================================
@@ -1,520 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module Main (main) where
-
-import qualified Distribution.ModuleName as ModuleName
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Check hiding (doesFileExist)
-import Distribution.PackageDescription.Configuration
-import Distribution.Package
-import Distribution.Simple
-import Distribution.Simple.Configure
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.GHC
-import Distribution.Simple.PackageDescription
-import Distribution.Simple.Program
-import Distribution.Simple.Program.HcPkg
-import Distribution.Simple.Setup (ConfigFlags(configStripLibs), fromFlagOrDefault, toFlag)
-import Distribution.Simple.Utils (defaultPackageDesc, findHookedPackageDesc, writeFileAtomic,
- toUTF8LBS)
-import Distribution.Simple.Build (writeAutogenFiles)
-import Distribution.Simple.Register
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Text
-import Distribution.Types.MungedPackageId
-import Distribution.Types.LocalBuildInfo
-import Distribution.Verbosity
-import qualified Distribution.InstalledPackageInfo as Installed
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Utils.ShortText (fromShortText)
-import Distribution.Utils.Path (getSymbolicPath)
-
-import Control.Exception (bracket)
-import Control.Monad
-import Control.Applicative ((<|>))
-import Data.List (nub, intercalate, isPrefixOf, isSuffixOf)
-import Data.Maybe
-import Data.Char (isSpace)
-import System.IO
-import System.Directory (setCurrentDirectory, getCurrentDirectory, doesFileExist)
-import System.Environment
-import System.Exit (exitWith, ExitCode(..))
-import System.FilePath
-
-main :: IO ()
-main = do hSetBuffering stdout LineBuffering
- args <- getArgs
- case args of
- "hscolour" : dir : distDir : args' ->
- runHsColour dir distDir args'
- "check" : dir : [] ->
- doCheck dir
- "copy" : dir : distDir
- : strip : myDestDir : myPrefix : myLibdir : myDocdir
- : ghcLibWays : args' ->
- doCopy dir distDir
- strip myDestDir myPrefix myLibdir myDocdir
- ("dyn" `elem` words ghcLibWays)
- args'
- "register" : dir : distDir : ghc : ghcpkg : topdir
- : myDestDir : myPrefix : myLibdir : myDocdir
- : relocatableBuild : args' ->
- doRegister dir distDir ghc ghcpkg topdir
- myDestDir myPrefix myLibdir myDocdir
- relocatableBuild args'
- "configure" : dir : distDir : config_args ->
- generate dir distDir config_args
- "sdist" : dir : distDir : [] ->
- doSdist dir distDir
- ["--version"] ->
- defaultMainArgs ["--version"]
- _ -> die syntax_error
-
-syntax_error :: [String]
-syntax_error =
- ["syntax: ghc-cabal configure <directory> <distdir> <args>...",
- " ghc-cabal copy <directory> <distdir> <strip> <destdir> <prefix> <libdir> <docdir> <libways> <args>...",
- " ghc-cabal register <directory> <distdir> <ghc> <ghcpkg> <topdir> <destdir> <prefix> <libdir> <docdir> <relocatable> <args>...",
- " ghc-cabal hscolour <directory> <distdir> <args>...",
- " ghc-cabal check <directory>",
- " ghc-cabal sdist <directory> <distdir>",
- " ghc-cabal --version"]
-
-die :: [String] -> IO a
-die errs = do mapM_ (hPutStrLn stderr) errs
- exitWith (ExitFailure 1)
-
-withCurrentDirectory :: FilePath -> IO a -> IO a
-withCurrentDirectory directory io
- = bracket (getCurrentDirectory) (setCurrentDirectory)
- (const (setCurrentDirectory directory >> io))
-
--- We need to use the autoconfUserHooks, as the packages that use
--- configure can create a .buildinfo file, and we need any info that
--- ends up in it.
-userHooks :: UserHooks
-userHooks = autoconfUserHooks
-
-runDefaultMain :: IO ()
-runDefaultMain
- = do let verbosity = normal
- gpdFile <- defaultPackageDesc verbosity
- gpd <- readGenericPackageDescription verbosity gpdFile
- case buildType (flattenPackageDescription gpd) of
- Configure -> defaultMainWithHooks autoconfUserHooks
- -- time has a "Custom" Setup.hs, but it's actually Configure
- -- plus a "./Setup test" hook. However, Cabal is also
- -- "Custom", but doesn't have a configure script.
- Custom ->
- do configureExists <- doesFileExist "configure"
- if configureExists
- then defaultMainWithHooks autoconfUserHooks
- else defaultMain
- -- not quite right, but good enough for us:
- _ -> defaultMain
-
-doSdist :: FilePath -> FilePath -> IO ()
-doSdist directory distDir
- = withCurrentDirectory directory
- $ withArgs (["sdist", "--builddir", distDir])
- runDefaultMain
-
-doCheck :: FilePath -> IO ()
-doCheck directory
- = withCurrentDirectory directory
- $ do let verbosity = normal
- gpdFile <- defaultPackageDesc verbosity
- gpd <- readGenericPackageDescription verbosity gpdFile
- case filter isFailure $ checkPackage gpd Nothing of
- [] -> return ()
- errs -> mapM_ print errs >> exitWith (ExitFailure 1)
- where isFailure (PackageDistSuspicious {}) = False
- isFailure (PackageDistSuspiciousWarn {}) = False
- isFailure _ = True
-
-runHsColour :: FilePath -> FilePath -> [String] -> IO ()
-runHsColour directory distdir args
- = withCurrentDirectory directory
- $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args)
-
-doCopy :: FilePath -> FilePath
- -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Bool
- -> [String]
- -> IO ()
-doCopy directory distDir
- strip myDestDir myPrefix myLibdir myDocdir withSharedLibs
- args
- = withCurrentDirectory directory $ do
- let copyArgs = ["copy", "--builddir", distDir]
- ++ (if null myDestDir
- then []
- else ["--destdir", myDestDir])
- ++ args
- copyHooks = userHooks {
- copyHook = modHook False
- $ copyHook userHooks
- }
-
- defaultMainWithHooksArgs copyHooks copyArgs
- where
- modHook relocatableBuild f pd lbi us flags
- = do let verbosity = normal
- idts = updateInstallDirTemplates relocatableBuild
- myPrefix myLibdir myDocdir
- (installDirTemplates lbi)
- progs = withPrograms lbi
- stripProgram' = stripProgram {
- programFindLocation = \_ _ -> return (Just (strip,[])) }
-
- progs' <- configureProgram verbosity stripProgram' progs
- let lbi' = lbi {
- withPrograms = progs',
- installDirTemplates = idts,
- configFlags = cfg,
- stripLibs = fromFlagOrDefault False (configStripLibs cfg),
- withSharedLib = withSharedLibs
- }
-
- -- This hack allows to interpret the "strip"
- -- command-line argument being set to ':' to signify
- -- disabled library stripping
- cfg | strip == ":" = (configFlags lbi) { configStripLibs = toFlag False }
- | otherwise = configFlags lbi
-
- f pd lbi' us flags
-
-doRegister :: FilePath -> FilePath -> FilePath -> FilePath
- -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath
- -> String -> [String]
- -> IO ()
-doRegister directory distDir ghc ghcpkg topdir
- myDestDir myPrefix myLibdir myDocdir
- relocatableBuildStr args
- = withCurrentDirectory directory $ do
- relocatableBuild <- case relocatableBuildStr of
- "YES" -> return True
- "NO" -> return False
- _ -> die ["Bad relocatableBuildStr: " ++
- show relocatableBuildStr]
- let regArgs = "register" : "--builddir" : distDir : args
- regHooks = userHooks {
- regHook = modHook relocatableBuild
- $ regHook userHooks
- }
-
- defaultMainWithHooksArgs regHooks regArgs
- where
- modHook relocatableBuild f pd lbi us flags
- = do let verbosity = normal
- idts = updateInstallDirTemplates relocatableBuild
- myPrefix myLibdir myDocdir
- (installDirTemplates lbi)
- progs = withPrograms lbi
- ghcpkgconf = topdir </> "package.conf.d"
- ghcProgram' = ghcProgram {
- programPostConf = \_ cp -> return cp { programDefaultArgs = ["-B" ++ topdir] },
- programFindLocation = \_ _ -> return (Just (ghc,[])) }
- ghcPkgProgram' = ghcPkgProgram {
- programPostConf = \_ cp -> return cp { programDefaultArgs =
- ["--global-package-db", ghcpkgconf]
- ++ ["--force" | not (null myDestDir) ] },
- programFindLocation = \_ _ -> return (Just (ghcpkg,[])) }
- configurePrograms ps conf = foldM (flip (configureProgram verbosity)) conf ps
-
- progs' <- configurePrograms [ghcProgram', ghcPkgProgram'] progs
- instInfos <- dump (hcPkgInfo progs') verbosity GlobalPackageDB
- let installedPkgs' = PackageIndex.fromList instInfos
- let lbi' = lbi {
- installedPkgs = installedPkgs',
- installDirTemplates = idts,
- withPrograms = progs'
- }
- f pd lbi' us flags
-
-updateInstallDirTemplates :: Bool -> FilePath -> FilePath -> FilePath
- -> InstallDirTemplates
- -> InstallDirTemplates
-updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts
- = idts {
- prefix = toPathTemplate $
- if relocatableBuild
- then "$topdir"
- else myPrefix,
- libdir = toPathTemplate $
- if relocatableBuild
- then "$topdir"
- else myLibdir,
- dynlibdir = toPathTemplate $
- (if relocatableBuild
- then "$topdir"
- else myLibdir) </> "$libname",
- libsubdir = toPathTemplate "$libname",
- docdir = toPathTemplate $
- if relocatableBuild
- then "$topdir/../doc/html/libraries/$pkgid"
- else (myDocdir </> "$pkgid"),
- htmldir = toPathTemplate "$docdir"
- }
-
-externalPackageDeps :: LocalBuildInfo -> [(UnitId, MungedPackageId)]
-externalPackageDeps lbi =
- -- TODO: what about non-buildable components?
- nub [ (ipkgid, pkgid)
- | clbi <- Graph.toList (componentGraph lbi)
- , (ipkgid, pkgid) <- componentPackageDeps clbi
- , not (internal ipkgid) ]
- where
- -- True if this dependency is an internal one (depends on the library
- -- defined in the same package).
- internal ipkgid = any ((==ipkgid) . componentUnitId) (Graph.toList (componentGraph lbi))
-
-generate :: FilePath -> FilePath -> [String] -> IO ()
-generate directory distdir config_args
- = withCurrentDirectory directory
- $ do let verbosity = normal
- -- XXX We shouldn't just configure with the default flags
- -- XXX And this, and thus the "getPersistBuildConfig distdir" below,
- -- aren't going to work when the deps aren't built yet
- withArgs (["configure", "--distdir", distdir, "--ipid", "$pkg-$version"] ++ config_args)
- runDefaultMain
-
- lbi <- getPersistBuildConfig distdir
- let pd0 = localPkgDescr lbi
-
- writePersistBuildConfig distdir lbi
-
- hooked_bi <-
- if (buildType pd0 == Configure) || (buildType pd0 == Custom)
- then do
- cwd <- getCurrentDirectory
- -- Try to find the .buildinfo in the $dist/build folder where
- -- cabal 2.2+ will expect it, but fallback to the old default
- -- location if we don't find any. This is the case of the
- -- bindist, which doesn't ship the $dist/build folder.
- maybe_infoFile <- findHookedPackageDesc verbosity (cwd </> distdir </> "build")
- <|> fmap Just (defaultPackageDesc verbosity)
- case maybe_infoFile of
- Nothing -> return emptyHookedBuildInfo
- Just infoFile -> readHookedBuildInfo verbosity infoFile
- else
- return emptyHookedBuildInfo
-
- let pd = updatePackageDescription hooked_bi pd0
-
- -- generate Paths_<pkg>.hs and cabal-macros.h
- withAllComponentsInBuildOrder pd lbi $ \_ clbi ->
- writeAutogenFiles verbosity pd lbi clbi
-
- -- generate inplace-pkg-config
- withLibLBI pd lbi $ \lib clbi ->
- do cwd <- getCurrentDirectory
- let fixupIncludeDir dir | cwd `isPrefixOf` dir = [dir, cwd </> distdir </> "build" ++ drop (length cwd) dir]
- | otherwise = [dir]
- let ipid = mkUnitId (display (packageId pd))
- let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
- pd (mkAbiHash "inplace") lib lbi clbi
- final_ipi = installedPkgInfo {
- Installed.installedUnitId = ipid,
- Installed.compatPackageKey = display (packageId pd),
- Installed.includeDirs = concatMap fixupIncludeDir (Installed.includeDirs installedPkgInfo)
- }
- content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
- writeFileAtomic (distdir </> "inplace-pkg-config")
- (toUTF8LBS content)
-
- let
- comp = compiler lbi
- libBiModules lib = (libBuildInfo lib, foldMap (allLibModules lib) (componentNameCLBIs lbi $ CLibName defaultLibName))
- exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe)
- biModuless :: [(BuildInfo, [ModuleName.ModuleName])]
- biModuless = (map libBiModules . maybeToList $ library pd)
- ++ (map exeBiModules $ executables pd)
- buildableBiModuless = filter isBuildable biModuless
- where isBuildable (bi', _) = buildable bi'
- (bi, modules) = case buildableBiModuless of
- [] -> error "No buildable component found"
- [biModules] -> biModules
- _ -> error ("XXX ghc-cabal can't handle " ++
- "more than one buildinfo yet")
- -- XXX Another Just...
- Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)
-
- dep_pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi))
- forDeps f = concatMap f dep_pkgs
-
- -- copied from Distribution.Simple.PreProcess.ppHsc2Hs
- packageHacks = case compilerFlavor (compiler lbi) of
- GHC -> hackRtsPackage
- _ -> id
- -- We don't link in the actual Haskell libraries of our
- -- dependencies, so the -u flags in the ldOptions of the rts
- -- package mean linking fails on OS X (it's ld is a tad
- -- stricter than gnu ld). Thus we remove the ldOptions for
- -- GHC's rts package:
- hackRtsPackage index =
- case PackageIndex.lookupPackageName index (mkPackageName "rts") of
- [(_,[rts])] ->
- PackageIndex.insert rts{
- Installed.ldOptions = [],
- Installed.libraryDirs = filter (not . ("gcc-lib" `isSuffixOf`)) (Installed.libraryDirs rts)} index
- -- GHC <= 6.12 had $topdir/gcc-lib in their
- -- library-dirs for the rts package, which causes
- -- problems when we try to use the in-tree mingw,
- -- due to accidentally picking up the incompatible
- -- libraries there. So we filter out gcc-lib from
- -- the RTS's library-dirs here.
- _ -> error "No (or multiple) ghc rts package is registered!!"
-
- dep_ids = map snd (externalPackageDeps lbi)
- deps = map display dep_ids
- dep_direct = map (fromMaybe (error "ghc-cabal: dep_keys failed")
- . PackageIndex.lookupUnitId
- (installedPkgs lbi)
- . fst)
- . externalPackageDeps
- $ lbi
- dep_ipids = map (display . Installed.installedUnitId) dep_direct
- depLibNames
- | packageKeySupported comp = dep_ipids
- | otherwise = deps
- depNames = map (display . mungedName) dep_ids
-
- transitive_dep_ids = map Installed.sourcePackageId dep_pkgs
- transitiveDeps = map display transitive_dep_ids
- transitiveDepLibNames
- | packageKeySupported comp = map fixupRtsLibName transitiveDeps
- | otherwise = transitiveDeps
- fixupRtsLibName x | "rts-" `isPrefixOf` x = "rts"
- fixupRtsLibName x = x
- transitiveDepNames = map (display . packageName) transitive_dep_ids
-
- -- Note [Msys2 path translation bug]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- Msys2 has an annoying bug in their path conversion code.
- -- Officially anything starting with a drive letter should not be
- -- subjected to path translations, however it seems to only consider
- -- E:\\ and E:// to be Windows paths. Mixed mode paths such as E:/
- -- that are produced here get corrupted.
- --
- -- Tamar at Rage /t/translate> ./a.exe -optc-I"E://ghc-dev/msys64/"
- -- path: -optc-IE://ghc-dev/msys64/
- -- Tamar at Rage /t/translate> ./a.exe -optc-I"E:ghc-dev/msys64/"
- -- path: -optc-IE:ghc-dev/msys64/
- -- Tamar at Rage /t/translate> ./a.exe -optc-I"E:\ghc-dev/msys64/"
- -- path: -optc-IE:\ghc-dev/msys64/
- --
- -- As such, let's just normalize the filepaths which is a good thing
- -- to do anyway.
- libraryDirs = map normalise $ forDeps Installed.libraryDirs
- -- The mkLibraryRelDir function is a bit of a hack.
- -- Ideally it should be handled in the makefiles instead.
- mkLibraryRelDir "rts" = "rts/dist-install/build"
- mkLibraryRelDir "ghc" = "compiler/stage2/build"
- mkLibraryRelDir "Cabal" = "libraries/Cabal/Cabal/dist-install/build"
- mkLibraryRelDir "Cabal-syntax" = "libraries/Cabal/Cabal-syntax/dist-install/build"
- mkLibraryRelDir "containers" = "libraries/containers/containers/dist-install/build"
- mkLibraryRelDir l = "libraries/" ++ l ++ "/dist-install/build"
- libraryRelDirs = map mkLibraryRelDir transitiveDepNames
-
- -- this is a hack to accommodate Cabal 2.2+ more hygenic
- -- generated data. We'll inject `dist-install/build` after
- -- before the `include` directory, if any.
- injectDistInstall :: FilePath -> [FilePath]
- injectDistInstall x | takeBaseName x == "include" = [x, takeDirectory x ++ "/dist-install/build/" ++ takeBaseName x]
- injectDistInstall x = [x]
-
- -- See Note [Msys2 path translation bug].
- wrappedIncludeDirs <- wrap $ map normalise $ concatMap injectDistInstall $ forDeps Installed.includeDirs
-
- let variablePrefix = directory ++ '_':distdir
- mods = map display modules
- otherMods = map display (otherModules bi)
- buildDir' = map (\c -> if c=='\\' then '/' else c) $ buildDir lbi
- let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
- -- TODO: move inside withLibLBI
- variablePrefix ++ "_COMPONENT_ID = " ++ localCompatPackageKey lbi,
- variablePrefix ++ "_MODULES = " ++ unwords mods,
- variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods,
- variablePrefix ++ "_SYNOPSIS =" ++ (unwords $ lines $ fromShortText $ synopsis pd),
- variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (map getSymbolicPath $ hsSourceDirs bi),
- variablePrefix ++ "_DEPS = " ++ unwords deps,
- variablePrefix ++ "_DEP_IPIDS = " ++ unwords dep_ipids,
- variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames,
- variablePrefix ++ "_DEP_COMPONENT_IDS = " ++ unwords depLibNames,
- variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames,
- variablePrefix ++ "_TRANSITIVE_DEP_COMPONENT_IDS = " ++ unwords transitiveDepLibNames,
- variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords ( [ dir | dir <- includeDirs bi ]
- ++ [ buildDir' ++ "/" ++ dir | dir <- includeDirs bi
- , not (isAbsolute dir)]),
- variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
- variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
- variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi),
- variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi),
- variablePrefix ++ "_S_SRCS = " ++ unwords (asmSources bi),
- variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi),
- variablePrefix ++ "_CXX_SRCS = " ++ unwords (cxxSources bi),
- variablePrefix ++ "_CMM_SRCS = " ++ unwords (cmmSources bi),
- variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd),
- -- XXX This includes things it shouldn't, like:
- -- -odir dist-bootstrapping/build
- variablePrefix ++ "_HC_OPTS = " ++ escapeArgs
- ( programDefaultArgs ghcProg
- ++ hcOptions GHC bi
- ++ languageToFlags (compiler lbi) (defaultLanguage bi)
- ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
- ++ programOverrideArgs ghcProg),
- variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi),
- variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi),
- variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi),
- variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs,
- variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions),
- variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs,
- variablePrefix ++ "_DEP_LIB_REL_DIRS = " ++ unwords libraryRelDirs,
- variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = " ++ mkSearchPath libraryRelDirs,
- variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions),
- variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi),
- "",
- -- Sometimes we need to modify the automatically-generated package-data.mk
- -- bindings in a special way for the GHC build system, so allow that here:
- "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))"
- ]
- writeFile (distdir ++ "/package-data.mk") $ unlines xs
-
- writeFileUtf8 (distdir ++ "/haddock-prologue.txt") $ fromShortText $
- if null (fromShortText $ description pd) then synopsis pd
- else description pd
- where
- wrap = mapM wrap1
- wrap1 s
- | null s = die ["Wrapping empty value"]
- | '\'' `elem` s = die ["Single quote in value to be wrapped:", s]
- -- We want to be able to assume things like <space><quote> is the
- -- start of a value, so check there are no spaces in confusing
- -- positions
- | head s == ' ' = die ["Leading space in value to be wrapped:", s]
- | last s == ' ' = die ["Trailing space in value to be wrapped:", s]
- | otherwise = return ("\'" ++ s ++ "\'")
- mkSearchPath = intercalate [searchPathSeparator]
- boolToYesNo True = "YES"
- boolToYesNo False = "NO"
-
- -- | Version of 'writeFile' that always uses UTF8 encoding
- writeFileUtf8 f txt = withFile f WriteMode $ \hdl -> do
- hSetEncoding hdl utf8
- hPutStr hdl txt
-
--- | Like GHC.ResponseFile.escapeArgs but uses spaces instead of newlines to seperate arguments
-escapeArgs :: [String] -> String
-escapeArgs = unwords . map escapeArg
-
-escapeArg :: String -> String
-escapeArg = foldr escape ""
-
-escape :: Char -> String -> String
-escape c cs
- | isSpace c || c `elem` ['\\','\'','#','"']
- = '\\':c:cs
- | otherwise
- = c:cs
=====================================
utils/ghc-cabal/Makefile deleted
=====================================
@@ -1,15 +0,0 @@
-# -----------------------------------------------------------------------------
-#
-# (c) 2011 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
-# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
-#
-# -----------------------------------------------------------------------------
-
-dir = utils/ghc-cabal
-TOP = ../..
-include $(TOP)/mk/sub-makefile.mk
=====================================
utils/ghc-cabal/ghc-cabal.cabal deleted
=====================================
@@ -1,27 +0,0 @@
-Name: ghc-cabal
-Version: 0.1
-Copyright: XXX
-License: BSD3
--- XXX License-File: LICENSE
-Author: XXX
-Maintainer: XXX
-Synopsis: A utility for producing package metadata from Cabal package
- descriptions for GHC's build system
-Description: This program is responsible for producing @package-data.mk@ files
- for Cabal packages. These files are used by GHC's @make at -based
- build system to determine the source files included by package,
- package dependencies, and other metadata.
-Category: Development
-build-type: Simple
-cabal-version: >=1.10
-
-Executable ghc-cabal
- Default-Language: Haskell2010
- Main-Is: Main.hs
-
- Build-Depends: base >= 3 && < 5,
- bytestring >= 0.10 && < 0.12,
- Cabal >= 3.7 && < 3.9,
- Cabal-syntax >= 3.7 && < 3.9,
- directory >= 1.1 && < 1.4,
- filepath >= 1.2 && < 1.5
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db8c4254eeb0fbc7cad7576e1dca79e664beb4c4...7be210dcac7c8855d76600e3a6afbde1c9461a83
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db8c4254eeb0fbc7cad7576e1dca79e664beb4c4...7be210dcac7c8855d76600e3a6afbde1c9461a83
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/20230915/502ba95c/attachment-0001.html>
More information about the ghc-commits
mailing list