From b0493ab4841a0eab12ea9d20b26166860dc6d6bf Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Wed, 31 Jul 2024 10:16:12 -0400 Subject: [PATCH] simplify list constructions using join and format with ormolu (#549) --- CI.hs | 2 +- ghc-lib-gen/src/Ghclibgen.hs | 1860 +++++++++++++++++----------------- 2 files changed, 952 insertions(+), 910 deletions(-) diff --git a/CI.hs b/CI.hs index 1f00b7ad..cf6162b1 100755 --- a/CI.hs +++ b/CI.hs @@ -63,7 +63,7 @@ data DaFlavor = DaFlavor -- Last tested gitlab.haskell.org/ghc/ghc.git at current :: String -current = "12d3b66cedd3c80e7c1e030238c92d26631cab8d" -- 2024-07-17 +current = "23f50640e705c132f1a0689d4850866d0f0d76a6" -- 2024-07-29 ghcFlavorOpt :: GhcFlavor -> String ghcFlavorOpt = \case diff --git a/ghc-lib-gen/src/Ghclibgen.hs b/ghc-lib-gen/src/Ghclibgen.hs index d1e1ca3d..8dea8305 100644 --- a/ghc-lib-gen/src/Ghclibgen.hs +++ b/ghc-lib-gen/src/Ghclibgen.hs @@ -1,7 +1,6 @@ -- Copyright (c) 2019-2024, Digital Asset (Switzerland) GmbH and/or -- its affiliates. All rights reserved. SPDX-License-Identifier: -- (Apache-2.0 OR BSD-3-Clause) - {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,80 +12,85 @@ {-# OPTIONS_GHC -Wx-partial #-} #endif -module Ghclibgen ( - applyPatchHeapClosures - , applyPatchAclocal - , applyPatchHsVersions - , applyPatchGhcPrim - , applyPatchHaddockHs - , applyPatchRtsBytecodes - , applyPatchGHCiInfoTable - , applyPatchGHCiMessage - , applyPatchDerivedConstants - , applyPatchDisableCompileTimeOptimizations - , applyPatchRtsIncludePaths - , applyPatchStage - , applyPatchNoMonoLocalBinds - , applyPatchCmmParseNoImplicitPrelude - , applyPatchHadrianCabalProject - , applyPatchGhcInternalEventWindowsHsc - , applyPatchTemplateHaskellLanguageHaskellTHSyntax - , applyPatchTemplateHaskellCabal - , applyPatchFptoolsAlex - , applyPatchFpFindCxxStdLib - , generatePrerequisites - , mangleCSymbols - , generateGhcLibCabal - , generateGhcLibParserCabal - , setupModuleDepsPlaceholders -) where +module Ghclibgen + ( applyPatchHeapClosures, + applyPatchAclocal, + applyPatchHsVersions, + applyPatchGhcPrim, + applyPatchHaddockHs, + applyPatchRtsBytecodes, + applyPatchGHCiInfoTable, + applyPatchGHCiMessage, + applyPatchDerivedConstants, + applyPatchDisableCompileTimeOptimizations, + applyPatchRtsIncludePaths, + applyPatchStage, + applyPatchNoMonoLocalBinds, + applyPatchCmmParseNoImplicitPrelude, + applyPatchHadrianCabalProject, + applyPatchGhcInternalEventWindowsHsc, + applyPatchTemplateHaskellLanguageHaskellTHSyntax, + applyPatchTemplateHaskellCabal, + applyPatchFptoolsAlex, + applyPatchFpFindCxxStdLib, + generatePrerequisites, + mangleCSymbols, + generateGhcLibCabal, + generateGhcLibParserCabal, + setupModuleDepsPlaceholders, + ) +where import Control.Exception (handle) import Control.Monad.Extra -import System.Process.Extra -import System.FilePath hiding ((), normalise, dropTrailingPathSeparator) -import System.FilePath.Posix ((), normalise, dropTrailingPathSeparator) -- Make sure we generate / on all platforms. -import System.Directory -import System.Directory.Extra -import System.IO.Error (isEOFError) -import System.IO.Extra -import Data.List.Extra hiding (find) +-- Make sure we generate / on all platforms. + import Data.Char +import Data.List.Extra hiding (find) +import qualified Data.List.NonEmpty +import qualified Data.Map as Map import Data.Maybe import Data.Ord -import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Data.List.NonEmpty - import qualified Data.Text as T import qualified Data.Text.IO as T - import GhclibgenFlavor +import System.Directory +import System.Directory.Extra +import System.FilePath hiding (dropTrailingPathSeparator, normalise, ()) +import System.FilePath.Posix (dropTrailingPathSeparator, normalise, ()) +import System.IO.Error (isEOFError) +import System.IO.Extra +import System.Process.Extra -- Cabal files from libraries inside GHC that are merged together. cabalFileLibraries :: GhcFlavor -> [FilePath] -cabalFileLibraries ghcFlavor = [ - "libraries/template-haskell/template-haskell.cabal" - , "libraries/ghc-heap/ghc-heap.cabal" - , "libraries/ghc-boot-th/ghc-boot-th.cabal" - , "libraries/ghc-boot/ghc-boot.cabal" - , "libraries/ghci/ghci.cabal" - , "compiler/ghc.cabal" - ] ++ - [ "libraries/ghc-platform/ghc-platform.cabal" | ghcSeries ghcFlavor > GHC_9_8 ] +cabalFileLibraries ghcFlavor = + join + [ [ "libraries/template-haskell/template-haskell.cabal", + "libraries/ghc-heap/ghc-heap.cabal", + "libraries/ghc-boot-th/ghc-boot-th.cabal", + "libraries/ghc-boot/ghc-boot.cabal", + "libraries/ghci/ghci.cabal", + "compiler/ghc.cabal" + ], + ["libraries/ghc-platform/ghc-platform.cabal" | ghcSeries ghcFlavor > GHC_9_8] + ] -- C-preprocessor "include dirs" for 'ghc-lib-parser'. ghcLibParserIncludeDirs :: GhcFlavor -> [FilePath] -ghcLibParserIncludeDirs ghcFlavor = (case ghcSeries ghcFlavor of - series | series > GHC_9_10 -> [ "libraries/ghc-internal/include", "rts/include", "rts/include/stg" ] - series | series > GHC_9_8 -> [ "rts/include", "rts/include/stg" ] - series | series >= GHC_9_4 -> [ "rts/include" ] -- ghcconfig.h, ghcversion.h - series | series < GHC_9_4 -> [ "includes" ] -- ghcconfig.h, MachDeps.h, MachRegs.h, CodeGen.Platform.hs - _ -> error "ghcLibParserIncludeDirs: impossible case!" - ) ++ - [ hadrianGeneratedRoot ghcFlavor, stage0Compiler, "compiler" ] ++ - [ "compiler/utils" | ghcSeries ghcFlavor < GHC_8_10 ] ++ - [ "libraries/containers/containers/include" | ghcSeries ghcFlavor >= GHC_9_8 ] -- containers.h +ghcLibParserIncludeDirs ghcFlavor = + join + [ case ghcSeries ghcFlavor of + series | series > GHC_9_10 -> ["libraries/ghc-internal/include", "rts/include", "rts/include/stg"] + series | series > GHC_9_8 -> ["rts/include", "rts/include/stg"] + series | series >= GHC_9_4 -> ["rts/include"] -- ghcconfig.h, ghcversion.h + series | series < GHC_9_4 -> ["includes"] -- ghcconfig.h, MachDeps.h, MachRegs.h, CodeGen.Platform.hs + _ -> error "ghcLibParserIncludeDirs: impossible case!", + [hadrianGeneratedRoot ghcFlavor, stage0Compiler, "compiler"], + ["compiler/utils" | ghcSeries ghcFlavor < GHC_8_10], + ["libraries/containers/containers/include" | ghcSeries ghcFlavor >= GHC_9_8] -- containers.h + ] -- C-preprocessor "include dirs" for 'ghc-lib'. ghcLibIncludeDirs :: GhcFlavor -> [FilePath] @@ -103,22 +107,24 @@ sortDiffListByLength all excludes = -- The "hs-source-dirs" universe. allHsSrcDirs :: Bool -> GhcFlavor -> [Cabal] -> [FilePath] allHsSrcDirs forDepends ghcFlavor lib = - [ stage0Compiler ] ++ - [ dir | forDepends, dir <- [ stage0Ghci, stage0GhcHeap ] ] ++ - [ stage0GhcBoot | ghcSeries ghcFlavor >= GHC_8_10 ] ++ - map takeDirectory (cabalFileLibraries ghcFlavor) ++ - map (dropTrailingPathSeparator . normalise) (askFiles lib "hs-source-dirs:") + join + [ [stage0Compiler], + [dir | forDepends, dir <- [stage0Ghci, stage0GhcHeap]], + [stage0GhcBoot | ghcSeries ghcFlavor >= GHC_8_10], + map takeDirectory (cabalFileLibraries ghcFlavor), + map (dropTrailingPathSeparator . normalise) (askFiles lib "hs-source-dirs:") + ] -- The "hs-source-dirs" for 'ghc-lib-parser'. ghcLibParserHsSrcDirs :: Bool -> GhcFlavor -> [Cabal] -> [FilePath] ghcLibParserHsSrcDirs forDepends ghcFlavor lib = let all = Set.fromList $ allHsSrcDirs forDepends ghcFlavor lib exclusions = - case ghcSeries ghcFlavor of - GHC_8_8 -> [ "compiler/codeGen", "compiler/hieFile", "compile/llvmGen", "compiler/stranal", "compiler/rename", "compiler/stgSyn", "compiler/llvmGen" ] - GHC_8_10 -> [ "compiler/nativeGen", "compiler/deSugar", "compiler/hieFile", "compiler/llvmGen", "compiler/stranal", "compiler/rename", "compiler/stgSyn" ] - _ -> [] - in sortDiffListByLength all $ Set.fromList [ dir | not forDepends, dir <- exclusions ] + case ghcSeries ghcFlavor of + GHC_8_8 -> ["compiler/codeGen", "compiler/hieFile", "compile/llvmGen", "compiler/stranal", "compiler/rename", "compiler/stgSyn", "compiler/llvmGen"] + GHC_8_10 -> ["compiler/nativeGen", "compiler/deSugar", "compiler/hieFile", "compiler/llvmGen", "compiler/stranal", "compiler/rename", "compiler/stgSyn"] + _ -> [] + in sortDiffListByLength all $ Set.fromList [dir | not forDepends, dir <- exclusions] -- The "hs-source-dirs" for 'ghc-lib'. ghcLibHsSrcDirs :: Bool -> GhcFlavor -> [Cabal] -> [FilePath] @@ -126,16 +132,16 @@ ghcLibHsSrcDirs forDepends ghcFlavor lib = let all = Set.fromList $ allHsSrcDirs forDepends ghcFlavor lib exclusions = case ghcSeries ghcFlavor of - GHC_8_8 -> [ "libraries/template-haskell", "libraries/ghc-boot-th", "compiler/basicTypes", "libraries/ghc-boot", "libraries/ghc-heap", "compiler/parser", "compiler/types" ] - GHC_8_10 -> [ "ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "compiler/basicTypes", "libraries/ghc-heap", "compiler/parser", "compiler/types" ] - GHC_9_0 -> [ "ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap" ] - GHC_9_2 -> [ "ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap" ] - GHC_9_4 -> [ "ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap", "libraries/ghci" ] - GHC_9_6 -> [ "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghci" ] - GHC_9_8 -> [ "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform" ] - GHC_9_10 -> [ "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform", "libraries/ghci" ] - GHC_9_12 -> [ "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform", "libraries/ghci", "libraries/ghc-internal/src" ] - in sortDiffListByLength all $ Set.fromList [ dir | not forDepends, dir <- exclusions ] + GHC_8_8 -> ["libraries/template-haskell", "libraries/ghc-boot-th", "compiler/basicTypes", "libraries/ghc-boot", "libraries/ghc-heap", "compiler/parser", "compiler/types"] + GHC_8_10 -> ["ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "compiler/basicTypes", "libraries/ghc-heap", "compiler/parser", "compiler/types"] + GHC_9_0 -> ["ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap"] + GHC_9_2 -> ["ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap"] + GHC_9_4 -> ["ghc-lib/stage0/libraries/ghc-boot/build", "libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-heap", "libraries/ghci"] + GHC_9_6 -> ["libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghci"] + GHC_9_8 -> ["libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform"] + GHC_9_10 -> ["libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform", "libraries/ghci"] + GHC_9_12 -> ["libraries/template-haskell", "libraries/ghc-boot-th", "libraries/ghc-boot", "libraries/ghc-heap", "libraries/ghc-platform/src", "libraries/ghc-platform", "libraries/ghci", "libraries/ghc-internal/src"] + in sortDiffListByLength all $ Set.fromList [dir | not forDepends, dir <- exclusions] -- File path constants. @@ -145,15 +151,25 @@ ghcLibGeneratedPath :: FilePath stage0Root, stage0Compiler, stage0Rts, stage0Libraries, stage0Lib :: FilePath stage0GhcHeap, stage0GhcBoot, stage0Ghci :: FilePath dataDir = stage0Lib + cabalFileBinary = "ghc/ghc-bin.cabal" + ghcLibGeneratedPath = "ghc-lib/generated" + stage0Root = "ghc-lib/stage0" + stage0Lib = stage0Root "lib" + stage0Libraries = stage0Root "libraries" + stage0Compiler = stage0Root "compiler/build" + stage0Rts = stage0Root "rts/build" + stage0GhcBoot = stage0Libraries "ghc-boot/build" + stage0GhcHeap = stage0Libraries "ghc-heap/build" + stage0Ghci = stage0Libraries "ghci/build" -- Sources generated by Hadrian are written under this directory. @@ -169,113 +185,77 @@ dataFiles ghcFlavor = -- From ghc/ghc.mk: "The GHC programs need to depend on all the -- helper programs they might call and the settings files they -- use." - [ "settings", "llvm-targets", "llvm-passes"] ++ - [ "platformConstants" | ghcSeries ghcFlavor < GHC_9_2 ] + join + [ ["settings", "llvm-targets", "llvm-passes"], + ["platformConstants" | ghcSeries ghcFlavor < GHC_9_2] + ] -- See 'hadrian/src/Rules/Generate.hs'. cabalFileDependencies :: GhcFlavor -> [FilePath] cabalFileDependencies ghcFlavor = - [ f | ghcSeries ghcFlavor > GHC_9_4, f <- cabalFileBinary : cabalFileLibraries ghcFlavor ] + [f | ghcSeries ghcFlavor > GHC_9_4, f <- cabalFileBinary : cabalFileLibraries ghcFlavor] rtsDependencies :: GhcFlavor -> [FilePath] rtsDependencies ghcFlavor = - if ghcSeries ghcFlavor >= GHC_9_4 then - ((stage0Rts "include") ) <$> ["ghcautoconf.h", "ghcplatform.h", "DerivedConstants.h"] - else - includesDependencies ghcFlavor ++ derivedConstantsDependencies ghcFlavor + if ghcSeries ghcFlavor >= GHC_9_4 + then + ((stage0Rts "include") ) <$> ["ghcautoconf.h", "ghcplatform.h", "DerivedConstants.h"] + else + includesDependencies ghcFlavor ++ derivedConstantsDependencies ghcFlavor where includesDependencies :: GhcFlavor -> [FilePath] includesDependencies ghcFlavor = - (hadrianGeneratedRoot ghcFlavor ) <$> [ "ghcautoconf.h", "ghcplatform.h", "ghcversion.h"] + (hadrianGeneratedRoot ghcFlavor ) <$> ["ghcautoconf.h", "ghcplatform.h", "ghcversion.h"] derivedConstantsDependencies :: GhcFlavor -> [FilePath] derivedConstantsDependencies ghcFlavor = - (hadrianGeneratedRoot ghcFlavor ) <$> ("DerivedConstants.h" : [ x | ghcSeries ghcFlavor <= GHC_9_0, x <- [ "GHCConstantsHaskellExports.hs", "GHCConstantsHaskellWrappers.hs", "GHCConstantsHaskellType.hs" ] ] ) + (hadrianGeneratedRoot ghcFlavor ) <$> ("DerivedConstants.h" : [x | ghcSeries ghcFlavor <= GHC_9_0, x <- ["GHCConstantsHaskellExports.hs", "GHCConstantsHaskellWrappers.hs", "GHCConstantsHaskellType.hs"]]) compilerDependencies :: GhcFlavor -> [FilePath] compilerDependencies ghcFlavor = - (stage0Compiler ) <$> - [ "primop-can-fail.hs-incl" | series < GHC_9_10 ] ++ - [ "primop-code-size.hs-incl" - , "primop-commutable.hs-incl" - , "primop-data-decl.hs-incl" - , "primop-fixity.hs-incl" ] ++ - [ if series < GHC_9_10 then - "primop-has-side-effects.hs-incl" - else - "primop-effects.hs-incl" - ] ++ - [ "primop-list.hs-incl" - , "primop-out-of-line.hs-incl" - , "primop-primop-info.hs-incl" - , "primop-strictness.hs-incl" - , "primop-tag.hs-incl" - , "primop-vector-tycons.hs-incl" - , "primop-vector-tys-exports.hs-incl" - , "primop-vector-tys.hs-incl" - , "primop-vector-uniques.hs-incl" - ] ++ - [ "primop-docs.hs-incl" | series >= GHC_9_0 ] ++ - [ incl | series >= GHC_9_10 - , incl <- [ - "primop-is-work-free.hs-incl" - , "primop-is-cheap.hs-incl" - ] - ] ++ - [ "primop-deprecations.hs-incl" | series > GHC_9_10 ] ++ - [ "GHC/Platform/Constants.hs" | series >= GHC_9_2 ] + map (stage0Compiler ) . join $ + [ ["primop-can-fail.hs-incl" | series < GHC_9_10], + ["primop-code-size.hs-incl", "primop-commutable.hs-incl", "primop-data-decl.hs-incl", "primop-fixity.hs-incl"], + [if series < GHC_9_10 then "primop-has-side-effects.hs-incl" else "primop-effects.hs-incl"], + ["primop-list.hs-incl", "primop-out-of-line.hs-incl", "primop-primop-info.hs-incl", "primop-strictness.hs-incl", "primop-tag.hs-incl", "primop-vector-tycons.hs-incl", "primop-vector-tys-exports.hs-incl", "primop-vector-tys.hs-incl", "primop-vector-uniques.hs-incl"], + ["primop-docs.hs-incl" | series >= GHC_9_0], + [incl | series >= GHC_9_10, incl <- ["primop-is-work-free.hs-incl", "primop-is-cheap.hs-incl"]], + ["primop-deprecations.hs-incl" | series > GHC_9_10], + ["GHC/Platform/Constants.hs" | series >= GHC_9_2] + ] where series = ghcSeries ghcFlavor platformH :: GhcFlavor -> [FilePath] platformH ghcFlavor = - [ stage0Compiler "ghc_boot_platform.h" | ghcSeries ghcFlavor < GHC_8_10 ] + [stage0Compiler "ghc_boot_platform.h" | ghcSeries ghcFlavor < GHC_8_10] packageCode :: GhcFlavor -> [FilePath] packageCode ghcFlavor = - [ stage0Compiler "GHC/Settings/Config.hs" | ghcSeries ghcFlavor >= GHC_9_0 ] ++ - [ stage0Compiler "Config.hs" | ghcSeries ghcFlavor < GHC_9_0 ] ++ - [ stage0GhcBoot "GHC" x | ghcSeries ghcFlavor >= GHC_8_10, x <- ["Version.hs", "Platform/Host.hs"] ] + join [[stage0Compiler "GHC/Settings/Config.hs" | ghcSeries ghcFlavor >= GHC_9_0], [stage0Compiler "Config.hs" | ghcSeries ghcFlavor < GHC_9_0], [stage0GhcBoot "GHC" x | ghcSeries ghcFlavor >= GHC_8_10, x <- ["Version.hs", "Platform/Host.hs"]]] fingerprint :: GhcFlavor -> [FilePath] fingerprint ghcFlavor = - [ "compiler/utils/Fingerprint.hsc" | ghcSeries ghcFlavor < GHC_8_10 ] + ["compiler/utils/Fingerprint.hsc" | ghcSeries ghcFlavor < GHC_8_10] cHeaders :: GhcFlavor -> [String] cHeaders ghcFlavor = - [ f | series > GHC_9_8, f <- ("rts/include/stg/MachRegs" ) <$> ["arm32.h", "arm64.h", "loongarch64.h", "ppc.h", "riscv64.h", "s390x.h", "wasm32.h", "x86.h"] ] ++ - [ "libraries/containers/containers/include/containers.h" | series >= GHC_9_8 ] ++ - [ "compiler" "ghc-llvm-version.h" | series >= GHC_9_4 && series <= GHC_9_8 ] ++ - [ f | series >= GHC_9_4, f <- (("rts/include" ) <$> ["ghcconfig.h", "ghcversion.h" ]) ++ (("compiler" ) <$>[ "MachRegs.h", "CodeGen.Platform.h", "Bytecodes.h", "ClosureTypes.h", "FunTypes.h", "Unique.h" ]) ] ++ - [ f | series < GHC_9_4, f <- (("includes" ) <$> [ "MachDeps.h", "stg/MachRegs.h", "CodeGen.Platform.hs"]) ++ (("compiler" ) <$> [ "Unique.h", "HsVersions.h" ]) ] ++ - [ f | series < GHC_8_10, f <- ("compiler" ) <$> [ "nativeGen/NCG.h", "utils/md5.h"] ] + join [[f | series > GHC_9_8, f <- ("rts/include/stg/MachRegs" ) <$> ["arm32.h", "arm64.h", "loongarch64.h", "ppc.h", "riscv64.h", "s390x.h", "wasm32.h", "x86.h"]], ["libraries/containers/containers/include/containers.h" | series >= GHC_9_8], ["compiler" "ghc-llvm-version.h" | series >= GHC_9_4 && series <= GHC_9_8], [f | series >= GHC_9_4, f <- (("rts/include" ) <$> ["ghcconfig.h", "ghcversion.h"]) ++ (("compiler" ) <$> ["MachRegs.h", "CodeGen.Platform.h", "Bytecodes.h", "ClosureTypes.h", "FunTypes.h", "Unique.h"])], [f | series < GHC_9_4, f <- (("includes" ) <$> ["MachDeps.h", "stg/MachRegs.h", "CodeGen.Platform.hs"]) ++ (("compiler" ) <$> ["Unique.h", "HsVersions.h"])], [f | series < GHC_8_10, f <- ("compiler" ) <$> ["nativeGen/NCG.h", "utils/md5.h"]]] where series = ghcSeries ghcFlavor parsersAndLexers :: GhcFlavor -> [FilePath] -parsersAndLexers ghcFlavor = ("compiler" ) <$> - [ x | ghcSeries ghcFlavor < GHC_9_0, x <- ("parser" ) <$> [ "Parser.y", "Lexer.x"] ] ++ - [ x | ghcSeries ghcFlavor >= GHC_9_0, x <- ("GHC" ) <$> [ "Parser.y", "Parser/Lexer.x" ] ] ++ - [ x | ghcSeries ghcFlavor >= GHC_9_4, x <- ("GHC" ) <$> [ "Parser/HaddockLex.x", "Parser.hs-boot" ] ] +parsersAndLexers ghcFlavor = + ("compiler" ) + <$> join [[x | ghcSeries ghcFlavor < GHC_9_0, x <- ("parser" ) <$> ["Parser.y", "Lexer.x"]], [x | ghcSeries ghcFlavor >= GHC_9_0, x <- ("GHC" ) <$> ["Parser.y", "Parser/Lexer.x"]], [x | ghcSeries ghcFlavor >= GHC_9_4, x <- ("GHC" ) <$> ["Parser/HaddockLex.x", "Parser.hs-boot"]]] ghcLibParserExtraFiles :: GhcFlavor -> [FilePath] ghcLibParserExtraFiles ghcFlavor = - cabalFileDependencies ghcFlavor ++ - rtsDependencies ghcFlavor ++ - compilerDependencies ghcFlavor ++ - platformH ghcFlavor ++ - fingerprint ghcFlavor ++ - packageCode ghcFlavor ++ - parsersAndLexers ghcFlavor ++ - cHeaders ghcFlavor + join [cabalFileDependencies ghcFlavor, rtsDependencies ghcFlavor, compilerDependencies ghcFlavor, platformH ghcFlavor, fingerprint ghcFlavor, packageCode ghcFlavor, parsersAndLexers ghcFlavor, cHeaders ghcFlavor] ghcLibExtraFiles :: GhcFlavor -> [FilePath] ghcLibExtraFiles ghcFlavor = - rtsDependencies ghcFlavor ++ - compilerDependencies ghcFlavor ++ - platformH ghcFlavor ++ - fingerprint ghcFlavor ++ - cHeaders ghcFlavor + join [rtsDependencies ghcFlavor, compilerDependencies ghcFlavor, platformH ghcFlavor, fingerprint ghcFlavor, cHeaders ghcFlavor] -- We generate some "placeholder" modules in `calcParserModues` They -- get written here. @@ -333,11 +313,14 @@ setupModuleDepsPlaceholders _ = do calcModuleDeps :: [FilePath] -> [FilePath] -> [FilePath] -> GhcFlavor -> FilePath -> String -> String calcModuleDeps includeDirs _hsSrcDirs hsSrcIncludes ghcFlavor cabalPackageDb ghcMakeModeOutputFile = - unwords $ - ["ghc -M -dep-suffix '' -dep-makefile " ++ ghcMakeModeOutputFile] ++ - ["-clear-package-db -global-package-db -user-package-db -package-db " ++ cabalPackageDb] ++ ["-package semaphore-compat" | series >= GHC_9_8] ++ - includeDirs ++ hsSrcIncludes ++ - [placeholderModulesDir "Main.hs"] + unwords . join $ + [ ["ghc -M -dep-suffix '' -dep-makefile " ++ ghcMakeModeOutputFile], + ["-clear-package-db -global-package-db -user-package-db -package-db " ++ cabalPackageDb], + ["-package semaphore-compat" | series >= GHC_9_8], + includeDirs, + hsSrcIncludes, + [placeholderModulesDir "Main.hs"] + ] where series = ghcSeries ghcFlavor @@ -403,21 +386,23 @@ applyPatchGhcInternalEventWindowsHsc :: GhcFlavor -> IO () applyPatchGhcInternalEventWindowsHsc ghcFlavor = do let series = ghcSeries ghcFlavor when (series > GHC_9_10) $ do - writeFile "libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc" . - replace - (unlines [ - "#if defined(DEBUG_TRACE)" - , "import {-# SOURCE #-} GHC.Internal.Debug.Trace (traceEventIO)" - , "#endif" ] + writeFile "libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc" + . replace + ( unlines + [ "#if defined(DEBUG_TRACE)", + "import {-# SOURCE #-} GHC.Internal.Debug.Trace (traceEventIO)", + "#endif" + ] ) - "" . - replace - (unlines [ - "#if defined(DEBUG)" - , "import GHC.Internal.Foreign.C" - , "import GHC.Internal.System.Posix.Internals (c_write)" - , "import GHC.Internal.Conc.Sync (myThreadId)" - , "#endif" ] + "" + . replace + ( unlines + [ "#if defined(DEBUG)", + "import GHC.Internal.Foreign.C", + "import GHC.Internal.System.Posix.Internals (c_write)", + "import GHC.Internal.Conc.Sync (myThreadId)", + "#endif" + ] ) "" =<< readFile' "libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc" @@ -432,45 +417,46 @@ applyPatchTemplateHaskellLanguageHaskellTHSyntax ghcFlavor = do -- defined in `Language.Haskell.TH.Syntax`. let series = ghcSeries ghcFlavor when (series >= GHC_9_8 && series <= GHC_9_10) $ do - writeFile "libraries/template-haskell/Language/Haskell/TH/Syntax.hs" . - replace + writeFile "libraries/template-haskell/Language/Haskell/TH/Syntax.hs" + . replace "{-# LANGUAGE TemplateHaskellQuotes #-}" - "" . - replace + "" + . replace "TYPE, RuntimeRep(..), Multiplicity (..) )" - "TYPE, RuntimeRep(..) )" . - replace + "TYPE, RuntimeRep(..) )" + . replace "import Foreign.C.Types" - (unlines [ "import Foreign.C.Types", "import GHC.Stack" ] ) . - replace + (unlines ["import Foreign.C.Types", "import GHC.Stack"]) + . replace "mkFixedName = 'Fixed.MkFixed" - "mkFixedName = mkNameG DataName \"base\" \"Data.Fixed\" \"MkFixed\"" . - replace + "mkFixedName = mkNameG DataName \"base\" \"Data.Fixed\" \"MkFixed\"" + . replace "addrToByteArrayName = 'addrToByteArray" - (unlines [ - "addrToByteArrayName = helper" - , " where" - , " helper :: HasCallStack => Name" - , " helper =" - , " case getCallStack ?callStack of" - , " [] -> error \"addrToByteArrayName: empty call stack\"" - , " (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule \"addrToByteArray\"" - ]) . - replace - (unlines [ "trueName = 'True", "falseName = 'False" ] ) - (unlines [ "trueName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"True\"", "falseName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"False\"" ] ) . - replace - (unlines [ "nothingName = 'Nothing", "justName = 'Just" ] ) - (unlines [ "nothingName = mkNameG DataName \"base\" \"GHC.Maybe\" \"Nothing\"", "justName = mkNameG DataName \"base\" \"GHC.Maybe\" \"Just\"" ] ) . - replace - (unlines [ "leftName = 'Left", "rightName = 'Right" ] ) - (unlines [ "leftName = mkNameG DataName \"base\" \"Data.Either\" \"Left\"", "rightName = mkNameG DataName \"base\" \"Data.Either\" \"Right\"" ] ) . - replace + ( unlines + [ "addrToByteArrayName = helper", + " where", + " helper :: HasCallStack => Name", + " helper =", + " case getCallStack ?callStack of", + " [] -> error \"addrToByteArrayName: empty call stack\"", + " (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule \"addrToByteArray\"" + ] + ) + . replace + (unlines ["trueName = 'True", "falseName = 'False"]) + (unlines ["trueName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"True\"", "falseName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"False\""]) + . replace + (unlines ["nothingName = 'Nothing", "justName = 'Just"]) + (unlines ["nothingName = mkNameG DataName \"base\" \"GHC.Maybe\" \"Nothing\"", "justName = mkNameG DataName \"base\" \"GHC.Maybe\" \"Just\""]) + . replace + (unlines ["leftName = 'Left", "rightName = 'Right"]) + (unlines ["leftName = mkNameG DataName \"base\" \"Data.Either\" \"Left\"", "rightName = mkNameG DataName \"base\" \"Data.Either\" \"Right\""]) + . replace "nonemptyName = '(:|)" - "nonemptyName = mkNameG DataName \"base\" \"GHC.Base\" \":|\"" . - replace - (unlines [ "oneName = 'One", "manyName = 'Many" ] ) - (unlines [ "oneName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"One\"", "manyName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"Many\"" ] ) + "nonemptyName = mkNameG DataName \"base\" \"GHC.Base\" \":|\"" + . replace + (unlines ["oneName = 'One", "manyName = 'Many"]) + (unlines ["oneName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"One\"", "manyName = mkNameG DataName \"ghc-prim\" \"GHC.Types\" \"Many\""]) =<< readFile' "libraries/template-haskell/Language/Haskell/TH/Syntax.hs" applyPatchTemplateHaskellCabal :: GhcFlavor -> IO () @@ -481,57 +467,60 @@ applyPatchTemplateHaskellCabal ghcFlavor = do -- (2022/7/05) a temporary change is made to provide for vendoring -- filepath inside template-haskell. This breaks our simple cabal -- parsing so workaround while this situation exists. - writeFile "libraries/template-haskell/template-haskell.cabal.in" . - replace - (unlines [ - " if flag(vendor-filepath)" - , " other-modules:" - , " System.FilePath" - , " System.FilePath.Posix" - , " System.FilePath.Windows" - , " hs-source-dirs: ../filepath ." - , " default-extensions:" - , " ImplicitPrelude" - , " else" - , " build-depends: filepath" - , " hs-source-dirs: ." - ]) - " filepath" . - replace - (unlines [ - " if flag(vendor-filepath)" - , " other-modules:" - , " System.FilePath" - , " System.FilePath.Posix" - , " System.FilePath.Windows" - , " hs-source-dirs: ./vendored-filepath ." - , " default-extensions:" - , " ImplicitPrelude" - , " else" - , " build-depends: filepath" - , " hs-source-dirs: ." - ]) - " filepath" + writeFile "libraries/template-haskell/template-haskell.cabal.in" + . replace + ( unlines + [ " if flag(vendor-filepath)", + " other-modules:", + " System.FilePath", + " System.FilePath.Posix", + " System.FilePath.Windows", + " hs-source-dirs: ../filepath .", + " default-extensions:", + " ImplicitPrelude", + " else", + " build-depends: filepath", + " hs-source-dirs: ." + ] + ) + " filepath" + . replace + ( unlines + [ " if flag(vendor-filepath)", + " other-modules:", + " System.FilePath", + " System.FilePath.Posix", + " System.FilePath.Windows", + " hs-source-dirs: ./vendored-filepath .", + " default-extensions:", + " ImplicitPrelude", + " else", + " build-depends: filepath", + " hs-source-dirs: ." + ] + ) + " filepath" =<< readFile' "libraries/template-haskell/template-haskell.cabal.in" - when (series > GHC_9_10) $ do - writeFile "libraries/template-haskell/template-haskell.cabal.in" . - replace - (unlines [ - " other-modules:" - , " System.FilePath" - , " System.FilePath.Posix" - , " System.FilePath.Windows" - , " hs-source-dirs: ./vendored-filepath ." - , " default-extensions:" - , " ImplicitPrelude" - ]) - (unlines[ - " build-depends:" - , " filepath" - , " hs-source-dirs: ." - ]) + writeFile "libraries/template-haskell/template-haskell.cabal.in" + . replace + ( unlines + [ " other-modules:", + " System.FilePath", + " System.FilePath.Posix", + " System.FilePath.Windows", + " hs-source-dirs: ./vendored-filepath .", + " default-extensions:", + " ImplicitPrelude" + ] + ) + ( unlines + [ " build-depends:", + " filepath", + " hs-source-dirs: ." + ] + ) =<< readFile' "libraries/template-haskell/template-haskell.cabal.in" when (series >= GHC_9_6 && series <= GHC_9_10) $ do @@ -545,22 +534,23 @@ applyPatchTemplateHaskellCabal ghcFlavor = do -- Fortunately, it seems we can continue to get away with what we -- we've been doing up to now and simply say in ghc-lib-parser -- cabal that it `build-depends` on filepath. - writeFile "libraries/template-haskell/template-haskell.cabal.in" . - replace - (unlines [ - " other-modules:" - , " System.FilePath" - , " System.FilePath.Posix" - , " System.FilePath.Windows" - , " hs-source-dirs: ./vendored-filepath ." - ]) - (unlines[ - " build-depends:" - , " filepath" - , " hs-source-dirs: ." - ]) - =<< readFile' "libraries/template-haskell/template-haskell.cabal.in" - + writeFile "libraries/template-haskell/template-haskell.cabal.in" + . replace + ( unlines + [ " other-modules:", + " System.FilePath", + " System.FilePath.Posix", + " System.FilePath.Windows", + " hs-source-dirs: ./vendored-filepath ." + ] + ) + ( unlines + [ " build-depends:", + " filepath", + " hs-source-dirs: ." + ] + ) + =<< readFile' "libraries/template-haskell/template-haskell.cabal.in" where series = ghcSeries ghcFlavor @@ -568,19 +558,19 @@ applyPatchTemplateHaskellCabal ghcFlavor = do -- https://github.com/digital-asset/ghc-lib/issues/210). applyPatchHeapClosures :: GhcFlavor -> IO () applyPatchHeapClosures _ = do - writeFile "libraries/ghc-heap/cbits/HeapPrim.cmm" . - replace + writeFile "libraries/ghc-heap/cbits/HeapPrim.cmm" + . replace "aToWordzh" - "Ghclib_aToWordzh" . - replace + "Ghclib_aToWordzh" + . replace "reallyUnsafePtrEqualityUpToTag" "Ghclib_reallyUnsafePtrEqualityUpToTag" =<< readFile' "libraries/ghc-heap/cbits/HeapPrim.cmm" - writeFile "libraries/ghc-heap/GHC/Exts/Heap/Closures.hs" . - replace + writeFile "libraries/ghc-heap/GHC/Exts/Heap/Closures.hs" + . replace "\"aToWordzh\"" - "\"Ghclib_aToWordzh\"" . - replace + "\"Ghclib_aToWordzh\"" + . replace "\"reallyUnsafePtrEqualityUpToTag\"" "\"Ghclib_reallyUnsafePtrEqualityUpToTag\"" =<< readFile' "libraries/ghc-heap/GHC/Exts/Heap/Closures.hs" @@ -605,15 +595,16 @@ applyPatchHsVersions ghcFlavor = -- Rename 'DerivedConstants.h' to 'GhclibDerivedConstants.h'. applyPatchDerivedConstants :: GhcFlavor -> IO () applyPatchDerivedConstants ghcFlavor = - renameFileRewriteSrcs - (if ghcSeries ghcFlavor >= GHC_9_4 then - stage0Rts "include" - else - hadrianGeneratedRoot ghcFlavor - ) - "DerivedConstants.h" - (["compiler", stage0Compiler] ++ [stage0Rts | ghcSeries ghcFlavor >= GHC_9_4 ]) - [".hs", ".y", ".hsc"] + renameFileRewriteSrcs + ( if ghcSeries ghcFlavor >= GHC_9_4 + then + stage0Rts "include" + else + hadrianGeneratedRoot ghcFlavor + ) + "DerivedConstants.h" + (["compiler", stage0Compiler] ++ [stage0Rts | ghcSeries ghcFlavor >= GHC_9_4]) + [".hs", ".y", ".hsc"] -- Selectively disable optimizations in some particular files so as -- to reduce (user) compile times. The files we apply this to were @@ -621,125 +612,129 @@ applyPatchDerivedConstants ghcFlavor = -- project. applyPatchDisableCompileTimeOptimizations :: GhcFlavor -> IO () applyPatchDisableCompileTimeOptimizations ghcFlavor = - let files - | ghcSeries ghcFlavor >= GHC_9_0 = [ "compiler/GHC/Driver/Session.hs", "compiler/GHC/Hs.hs" ] - | ghcSeries ghcFlavor >= GHC_8_10 = [ "compiler/main/DynFlags.hs", "compiler/GHC/Hs.hs" ] - | otherwise = [ "compiler/main/DynFlags.hs", "compiler/hsSyn/HsInstances.hs" ] - in - forM_ files $ + let files + | ghcSeries ghcFlavor >= GHC_9_0 = ["compiler/GHC/Driver/Session.hs", "compiler/GHC/Hs.hs"] + | ghcSeries ghcFlavor >= GHC_8_10 = ["compiler/main/DynFlags.hs", "compiler/GHC/Hs.hs"] + | otherwise = ["compiler/main/DynFlags.hs", "compiler/hsSyn/HsInstances.hs"] + in forM_ files $ \file -> - writeFile file . - ("{-# OPTIONS_GHC -O0 #-}\n" ++) - =<< readFile' file + writeFile file + . ("{-# OPTIONS_GHC -O0 #-}\n" ++) + =<< readFile' file applyPatchGHCiInfoTable :: GhcFlavor -> IO () applyPatchGHCiInfoTable ghcFlavor = do - when(ghcFlavor == DaGhc881) $ + when (ghcFlavor == DaGhc881) $ -- Drop references to RTS symbols in GHCi so we can build with GHC -- 9. These functions are never used since GHCi doesn’t work in -- ghc-lib anyway. - writeFile infoTableHsc . - replace - (unlines - [ "foreign import ccall unsafe \"allocateExec\"" - , " _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)" - , "" - , "foreign import ccall unsafe \"flushExec\"" - , " _flushExec :: CUInt -> Ptr a -> IO ()" - ]) - (unlines - [ "_allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)" - , "_allocateExec = error \"_allocateExec stub for ghc-lib\"" - , "" - , "_flushExec :: CUInt -> Ptr a -> IO ()" - , "_flushExec = error \"_flushExec stub for ghc-lib\"" - ]) + writeFile infoTableHsc + . replace + ( unlines + [ "foreign import ccall unsafe \"allocateExec\"", + " _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)", + "", + "foreign import ccall unsafe \"flushExec\"", + " _flushExec :: CUInt -> Ptr a -> IO ()" + ] + ) + ( unlines + [ "_allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)", + "_allocateExec = error \"_allocateExec stub for ghc-lib\"", + "", + "_flushExec :: CUInt -> Ptr a -> IO ()", + "_flushExec = error \"_flushExec stub for ghc-lib\"" + ] + ) =<< readFile' infoTableHsc - when(ghcSeries ghcFlavor >= GHC_9_2) $ do - writeFile infoTableHsc . - replace + when (ghcSeries ghcFlavor >= GHC_9_2) $ do + writeFile infoTableHsc + . replace (unlines newExecConItblBefore) - ("#if MIN_VERSION_rts(1,0,1)\n" <> - unlines newExecConItblBefore <> - "#else\n" <> - unlines newExecConItblAfter <> - "#endif\n") . - replace + ( "#if MIN_VERSION_rts(1,0,1)\n" + <> unlines newExecConItblBefore + <> "#else\n" + <> unlines newExecConItblAfter + <> "#endif\n" + ) + . replace "fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)\n" - ("#if MIN_VERSION_rts(1,0,1)\n" <> - "fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)\n" <> - "#endif\n") . - replace - (if ghcSeries ghcFlavor >= GHC_9_4 - then - "#error Sorry, rts versions <= 1.0 are not supported" - else - "#error hi" + ( "#if MIN_VERSION_rts(1,0,1)\n" + <> "fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)\n" + <> "#endif\n" + ) + . replace + ( if ghcSeries ghcFlavor >= GHC_9_4 + then + "#error Sorry, rts versions <= 1.0 are not supported" + else + "#error hi" + ) + ( unlines + [ "foreign import ccall unsafe \"allocateExec\"", + " _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)", + "", + "foreign import ccall unsafe \"flushExec\"", + " _flushExec :: CUInt -> Ptr a -> IO ()" + ] ) - (unlines [ - "foreign import ccall unsafe \"allocateExec\"" - , " _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)" - , "" - , "foreign import ccall unsafe \"flushExec\"" - , " _flushExec :: CUInt -> Ptr a -> IO ()" ] - ) =<< readFile' infoTableHsc where infoTableHsc = "libraries/ghci/GHCi/InfoTable.hsc" - newExecConItblBefore = [ - "newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())" - , "newExecConItbl tables_next_to_code obj con_desc = do" - , " sz0 <- sizeOfEntryCode tables_next_to_code" - , " let lcon_desc = BS.length con_desc + 1{- null terminator -}" - , " -- SCARY" - , " -- This size represents the number of bytes in an StgConInfoTable." - , " sz = fromIntegral $ conInfoTableSizeB + sz0" - , " -- Note: we need to allocate the conDesc string next to the info" - , " -- table, because on a 64-bit platform we reference this string" - , " -- with a 32-bit offset relative to the info table, so if we" - , " -- allocated the string separately it might be out of range." - , "" - , " ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \\wr_ptr ex_ptr -> do" - , " let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz" - , " , infoTable = obj }" - , " pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo" - , " BS.useAsCStringLen con_desc $ \\(src, len) ->" - , " copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len" - , " let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)" - , " poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)" - , "" - , " pure $ if tables_next_to_code" - , " then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB" - , " else castPtrToFunPtr ex_ptr" + newExecConItblBefore = + [ "newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())", + "newExecConItbl tables_next_to_code obj con_desc = do", + " sz0 <- sizeOfEntryCode tables_next_to_code", + " let lcon_desc = BS.length con_desc + 1{- null terminator -}", + " -- SCARY", + " -- This size represents the number of bytes in an StgConInfoTable.", + " sz = fromIntegral $ conInfoTableSizeB + sz0", + " -- Note: we need to allocate the conDesc string next to the info", + " -- table, because on a 64-bit platform we reference this string", + " -- with a 32-bit offset relative to the info table, so if we", + " -- allocated the string separately it might be out of range.", + "", + " ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \\wr_ptr ex_ptr -> do", + " let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz", + " , infoTable = obj }", + " pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo", + " BS.useAsCStringLen con_desc $ \\(src, len) ->", + " copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len", + " let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)", + " poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)", + "", + " pure $ if tables_next_to_code", + " then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB", + " else castPtrToFunPtr ex_ptr" ] - newExecConItblAfter = [ - "newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())" - , "newExecConItbl tables_next_to_code obj con_desc" - , " = alloca $ \\pcode -> do" - , " sz0 <- sizeOfEntryCode tables_next_to_code" - , " let lcon_desc = BS.length con_desc + 1{- null terminator -}" - , " -- SCARY" - , " -- This size represents the number of bytes in an StgConInfoTable." - , " sz = fromIntegral $ conInfoTableSizeB + sz0" - , " -- Note: we need to allocate the conDesc string next to the info" - , " -- table, because on a 64-bit platform we reference this string" - , " -- with a 32-bit offset relative to the info table, so if we" - , " -- allocated the string separately it might be out of range." - , " wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode" - , " ex_ptr <- peek pcode" - , " let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz" - , " , infoTable = obj }" - , " pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo" - , " BS.useAsCStringLen con_desc $ \\(src, len) ->" - , " copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len" - , " let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)" - , " poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)" - , " _flushExec sz ex_ptr -- Cache flush (if needed)" - , " pure $ if tables_next_to_code" - , " then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB" - , " else castPtrToFunPtr ex_ptr" + newExecConItblAfter = + [ "newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())", + "newExecConItbl tables_next_to_code obj con_desc", + " = alloca $ \\pcode -> do", + " sz0 <- sizeOfEntryCode tables_next_to_code", + " let lcon_desc = BS.length con_desc + 1{- null terminator -}", + " -- SCARY", + " -- This size represents the number of bytes in an StgConInfoTable.", + " sz = fromIntegral $ conInfoTableSizeB + sz0", + " -- Note: we need to allocate the conDesc string next to the info", + " -- table, because on a 64-bit platform we reference this string", + " -- with a 32-bit offset relative to the info table, so if we", + " -- allocated the string separately it might be out of range.", + " wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode", + " ex_ptr <- peek pcode", + " let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz", + " , infoTable = obj }", + " pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo", + " BS.useAsCStringLen con_desc $ \\(src, len) ->", + " copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len", + " let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)", + " poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)", + " _flushExec sz ex_ptr -- Cache flush (if needed)", + " pure $ if tables_next_to_code", + " then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB", + " else castPtrToFunPtr ex_ptr" ] applyPatchGHCiMessage :: GhcFlavor -> IO () @@ -759,50 +754,52 @@ applyPatchGHCiMessage ghcFlavor = Just version = firstJust (stripPrefix "#define __GLASGOW_HASKELL__ ") ls Just patchLevel = firstJust (stripPrefix "#define __GLASGOW_HASKELL_PATCHLEVEL1__ ") ls major1Major2 = read @Int version - minor = read @Int patchLevel - [x, y, z] = map show [ major1Major2 `div` 100, major1Major2 `mod` 100, minor ] - rs = [ - "#ifndef MIN_VERSION_ghc_heap" - , "#define MIN_VERSION_ghc_heap(major1,major2,minor) (\\" - , " (major1) < " ++ x ++ " || \\" - , " (major1) == " ++ x ++ " && (major2) < " ++ y ++ " || \\" - , " (major1) == " ++ x ++ " && (major2) == " ++ y ++ " && (minor) <= " ++ z ++ ")" - , "#endif /* MIN_VERSION_ghc_heap */" + minor = read @Int patchLevel + [x, y, z] = map show [major1Major2 `div` 100, major1Major2 `mod` 100, minor] + rs = + [ "#ifndef MIN_VERSION_ghc_heap", + "#define MIN_VERSION_ghc_heap(major1,major2,minor) (\\", + " (major1) < " ++ x ++ " || \\", + " (major1) == " ++ x ++ " && (major2) < " ++ y ++ " || \\", + " (major1) == " ++ x ++ " && (major2) == " ++ y ++ " && (minor) <= " ++ z ++ ")", + "#endif /* MIN_VERSION_ghc_heap */" ] -- Write this definition before it's tested on. - writeFile messageHs . - replace - "#if MIN_VERSION_ghc_heap(8,11,0)" - (unlines rs <> "#if MIN_VERSION_ghc_heap(8,11,0)") + writeFile messageHs + . replace + "#if MIN_VERSION_ghc_heap(8,11,0)" + (unlines rs <> "#if MIN_VERSION_ghc_heap(8,11,0)") =<< readFile' messageHs where - messageHs = "libraries/ghci/GHCi/Message.hs" + messageHs = "libraries/ghci/GHCi/Message.hs" applyPatchHaddockHs :: GhcFlavor -> IO () applyPatchHaddockHs ghcFlavor = do -- See https://github.com/ndmitchell/hlint/issues/1224 - when (ghcFlavor `elem` [Ghc901, Ghc902]) ( - writeFile haddockHs . - replace - "-- *" - "-- -" - =<< readFile' haddockHs + when + (ghcFlavor `elem` [Ghc901, Ghc902]) + ( writeFile haddockHs + . replace + "-- *" + "-- -" + =<< readFile' haddockHs ) -- See https://github.com/digital-asset/ghc-lib/issues/344 - when (ghcSeries ghcFlavor == GHC_9_2) ( - writeFile ffiClosuresHs . - replace - "-- *" - "-- -" - =<< readFile' ffiClosuresHs + when + (ghcSeries ghcFlavor == GHC_9_2) + ( writeFile ffiClosuresHs + . replace + "-- *" + "-- -" + =<< readFile' ffiClosuresHs ) -- See https://github.com/digital-asset/ghc-lib/issues/391 - when (ghcFlavor `elem` [Ghc923, Ghc924, Ghc925, Ghc926, Ghc927, Ghc928]) ( - writeFile codeGenHs . replace "{- | debugIsOn -}" "" - =<< readFile' codeGenHs + when + (ghcFlavor `elem` [Ghc923, Ghc924, Ghc925, Ghc926, Ghc927, Ghc928]) + ( writeFile codeGenHs . replace "{- | debugIsOn -}" "" + =<< readFile' codeGenHs ) - where haddockHs = "compiler/GHC/Parser/PostProcess/Haddock.hs" ffiClosuresHs = "libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs" @@ -815,67 +812,79 @@ applyPatchHaddockHs ghcFlavor = do applyPatchRtsBytecodes :: GhcFlavor -> IO () applyPatchRtsBytecodes ghcFlavor = do let series = ghcSeries ghcFlavor - when (series >= GHC_9_2 && series < GHC_9_6) ( - writeFile asmHs . - replace - "#include \"rts/Bytecodes.h\"" - (unlines [ - "#include \"rts/Bytecodes.h\"" - , "#if __GLASGOW_HASKELL__ <= 901" - , "# define bci_RETURN_T 69" - , "# define bci_PUSH_ALTS_T 70" - , "#endif" ]) - =<< readFile' asmHs ) - where - asmHs = "compiler/GHC/ByteCode/Asm.hs" + when + (series >= GHC_9_2 && series < GHC_9_6) + ( writeFile asmHs + . replace + "#include \"rts/Bytecodes.h\"" + ( unlines + [ "#include \"rts/Bytecodes.h\"", + "#if __GLASGOW_HASKELL__ <= 901", + "# define bci_RETURN_T 69", + "# define bci_PUSH_ALTS_T 70", + "#endif" + ] + ) + =<< readFile' asmHs + ) + where + asmHs = "compiler/GHC/ByteCode/Asm.hs" -- Workaround lack of newer ghc-prim 12/3/2019 -- (https://gitlab.haskell.org/ghc/ghc/commit/705a16df02411ec2445c9a254396a93cabe559ef) applyPatchGhcPrim :: GhcFlavor -> IO () applyPatchGhcPrim ghcFlavor = do - let series = ghcSeries ghcFlavor - when (series >= GHC_9_0 && series < GHC_9_6) $ do - let tysPrim = "compiler/GHC/Builtin/Types/Prim.hs" - writeFile tysPrim . - replaceIfGhcPrim070Else 0 - "bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep" - "bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep" . - replaceIfGhcPrim070Else 0 - "bcoPrimTyConName = mkPrimTc (fsLit \"BCO\") bcoPrimTyConKey bcoPrimTyCon" - "bcoPrimTyConName = mkPrimTc (fsLit \"BCO#\") bcoPrimTyConKey bcoPrimTyCon" - =<< readFile' tysPrim - let createBCO = "libraries/ghci/GHCi/CreateBCO.hs" - writeFile createBCO . - replace - "{-# LANGUAGE RecordWildCards #-}" - "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE CPP #-}" . - replaceIfGhcPrim070Else 5 - "do linked_bco <- linkBCO' arr bco" - "do BCO bco# <- linkBCO' arr bco" . - replaceIfGhcPrim070Else 11 - "then return (HValue (unsafeCoerce linked_bco))\n else case mkApUpd0# linked_bco of { (# final_bco #) ->" - "then return (HValue (unsafeCoerce# bco#))\n else case mkApUpd0# bco# of { (# final_bco #) ->" . - replaceIfGhcPrim070Else 6 - "bco <- linkBCO' arr bco\n writePtrsArrayBCO i bco marr" - "BCO bco# <- linkBCO' arr bco\n writePtrsArrayBCO i bco# marr" . - replaceIfGhcPrim070Else 0 - "writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()" - "writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()" . - replaceIfGhcPrim070Else 0 - "writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()" - "data BCO = BCO BCO#\nwritePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()" . - replaceIfGhcPrim070Else 2 - "newBCO# instrs lits ptrs arity bitmap s" - "case newBCO# instrs lits ptrs arity bitmap s of\n (# s1, bco #) -> (# s1, BCO bco #)" - =<< readFile' createBCO + let series = ghcSeries ghcFlavor + when (series >= GHC_9_0 && series < GHC_9_6) $ do + let tysPrim = "compiler/GHC/Builtin/Types/Prim.hs" + writeFile tysPrim + . replaceIfGhcPrim070Else + 0 + "bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep" + "bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep" + . replaceIfGhcPrim070Else + 0 + "bcoPrimTyConName = mkPrimTc (fsLit \"BCO\") bcoPrimTyConKey bcoPrimTyCon" + "bcoPrimTyConName = mkPrimTc (fsLit \"BCO#\") bcoPrimTyConKey bcoPrimTyCon" + =<< readFile' tysPrim + let createBCO = "libraries/ghci/GHCi/CreateBCO.hs" + writeFile createBCO + . replace + "{-# LANGUAGE RecordWildCards #-}" + "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE CPP #-}" + . replaceIfGhcPrim070Else + 5 + "do linked_bco <- linkBCO' arr bco" + "do BCO bco# <- linkBCO' arr bco" + . replaceIfGhcPrim070Else + 11 + "then return (HValue (unsafeCoerce linked_bco))\n else case mkApUpd0# linked_bco of { (# final_bco #) ->" + "then return (HValue (unsafeCoerce# bco#))\n else case mkApUpd0# bco# of { (# final_bco #) ->" + . replaceIfGhcPrim070Else + 6 + "bco <- linkBCO' arr bco\n writePtrsArrayBCO i bco marr" + "BCO bco# <- linkBCO' arr bco\n writePtrsArrayBCO i bco# marr" + . replaceIfGhcPrim070Else + 0 + "writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()" + "writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()" + . replaceIfGhcPrim070Else + 0 + "writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()" + "data BCO = BCO BCO#\nwritePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()" + . replaceIfGhcPrim070Else + 2 + "newBCO# instrs lits ptrs arity bitmap s" + "case newBCO# instrs lits ptrs arity bitmap s of\n (# s1, bco #) -> (# s1, BCO bco #)" + =<< readFile' createBCO where replaceIfGhcPrim070Else :: Int -> String -> String -> String -> String replaceIfGhcPrim070Else n s r = replace s (ifGhcPrim070Else n s r) ifGhcPrim070Else :: Int -> String -> String -> String ifGhcPrim070Else n s r = - let indent n s = replicate n ' ' ++ s in - unlines ["\n#if MIN_VERSION_ghc_prim(0, 7, 0)", indent n s, "#else", indent n r , "#endif" ] + let indent n s = replicate n ' ' ++ s + in unlines ["\n#if MIN_VERSION_ghc_prim(0, 7, 0)", indent n s, "#else", indent n r, "#endif"] -- Fix up these rts include paths. We don't ship rts headers since we -- run ghc-lib using the RTS of the compiler we build with - we go to @@ -883,61 +892,60 @@ applyPatchGhcPrim ghcFlavor = do applyPatchRtsIncludePaths :: GhcFlavor -> IO () applyPatchRtsIncludePaths ghcFlavor = do let files = - [ "compiler/GHC/Runtime/Heap/Layout.hs" | ghcSeries ghcFlavor >= GHC_9_0 ] ++ - [ "compiler/cmm/SMRep.hs" | ghcSeries ghcFlavor < GHC_9_0 ] ++ - [ "compiler/GHC/StgToCmm/Layout.hs" | ghcSeries ghcFlavor >= GHC_8_10 ] ++ - [ "compiler/codeGen/StgCmmLayout.hs" | ghcSeries ghcFlavor < GHC_8_10 ] + ["compiler/GHC/Runtime/Heap/Layout.hs" | ghcSeries ghcFlavor >= GHC_9_0] + ++ ["compiler/cmm/SMRep.hs" | ghcSeries ghcFlavor < GHC_9_0] + ++ ["compiler/GHC/StgToCmm/Layout.hs" | ghcSeries ghcFlavor >= GHC_8_10] + ++ ["compiler/codeGen/StgCmmLayout.hs" | ghcSeries ghcFlavor < GHC_8_10] forM_ files $ \file -> - writeFile file . - replace - "../includes/rts" - "rts" + writeFile file + . replace + "../includes/rts" + "rts" =<< readFile' file -- Mangle exported C symbols to avoid collisions between the symbols -- in ghc-lib-parser and ghc. mangleCSymbols :: GhcFlavor -> IO () mangleCSymbols ghcFlavor = do - let ghcLibParserPrefix = "ghc_lib_parser_" - let prefixSymbol s = replace s (ghcLibParserPrefix <> s) - let prefixForeignImport s = - replace - ("foreign import ccall unsafe " <> show s) - ("foreign import ccall unsafe " <> show (ghcLibParserPrefix <> s)) - let genSym = "genSym" - let initGenSym = "initGenSym" - let enableTimingStats = "enableTimingStats" - let setHeapSize = "setHeapSize" - let file = "compiler/cbits/genSym.c" in - writeFile file . - prefixSymbol genSym . - prefixSymbol initGenSym - =<< readFile' file - let files - | ghcSeries ghcFlavor >= GHC_9_0 = ("compiler/GHC/Types" ) <$> [ "Unique/Supply.hs", "Unique.hs" ] - | otherwise = [ "compiler/basicTypes/UniqSupply.hs" ] - forM_ files $ \file -> - writeFile file . - prefixForeignImport genSym . - prefixForeignImport initGenSym + let ghcLibParserPrefix = "ghc_lib_parser_" + let prefixSymbol s = replace s (ghcLibParserPrefix <> s) + let prefixForeignImport s = + replace + ("foreign import ccall unsafe " <> show s) + ("foreign import ccall unsafe " <> show (ghcLibParserPrefix <> s)) + let genSym = "genSym" + let initGenSym = "initGenSym" + let enableTimingStats = "enableTimingStats" + let setHeapSize = "setHeapSize" + let file = "compiler/cbits/genSym.c" + in writeFile file + . prefixSymbol genSym + . prefixSymbol initGenSym =<< readFile' file - let cUtils - | ghcSeries ghcFlavor >= GHC_9_0 = [ "compiler/cbits/cutils.c" ] - | otherwise = [ "compiler/parser/cutils.c", "compiler/parser/cutils.h" ] - forM_ cUtils $ \file -> - writeFile file . - prefixSymbol enableTimingStats . - prefixSymbol setHeapSize + let files + | ghcSeries ghcFlavor >= GHC_9_0 = map ("compiler/GHC/Types" ) ["Unique/Supply.hs", "Unique.hs"] + | otherwise = ["compiler/basicTypes/UniqSupply.hs"] + forM_ files $ \file -> + writeFile file + . prefixForeignImport genSym + . prefixForeignImport initGenSym + =<< readFile' file + let cUtils + | ghcSeries ghcFlavor >= GHC_9_0 = ["compiler/cbits/cutils.c"] + | otherwise = ["compiler/parser/cutils.c", "compiler/parser/cutils.h"] + forM_ cUtils $ \file -> + writeFile file + . prefixSymbol enableTimingStats + . prefixSymbol setHeapSize + =<< readFile' file + let file + | ghcSeries ghcFlavor >= GHC_9_0 = "compiler/GHC/Driver/Session.hs" + | otherwise = "compiler/main/DynFlags.hs" + in writeFile file + . prefixForeignImport enableTimingStats + . prefixForeignImport setHeapSize =<< readFile' file - let file - | ghcSeries ghcFlavor >= GHC_9_0 = "compiler/GHC/Driver/Session.hs" - | otherwise = "compiler/main/DynFlags.hs" - in - writeFile file . - prefixForeignImport enableTimingStats . - prefixForeignImport setHeapSize - =<< readFile' file -- Setting DSTAGE=2 will cause GHC to use getOrSetLibHSghc in -- FastString, DynFlags and Linker so we patch away that usage while @@ -954,28 +962,29 @@ applyPatchStage ghcFlavor = -- below 2 anymore). All usages of `getOrSetLibHSghc*` require -- `GHC_STAGE >= 2`. Thus, it's no longer neccessary to patch here. when (ghcSeries ghcFlavor < GHC_8_10) $ - forM_ [ "compiler/ghci/Linker.hs", "compiler/utils/FastString.hs", "compiler/main/DynFlags.hs" ] $ - \file -> - (writeFile file . replace "STAGE >= 2" "0" . replace "STAGE < 2" "1") - =<< readFile' file + forM_ ["compiler/ghci/Linker.hs", "compiler/utils/FastString.hs", "compiler/main/DynFlags.hs"] $ + \file -> + (writeFile file . replace "STAGE >= 2" "0" . replace "STAGE < 2" "1") + =<< readFile' file applyPatchAclocal :: GhcFlavor -> IO () applyPatchAclocal ghcFlavor = when (ghcFlavor <= Ghc901) $ - writeFile aclocalm4 . - replace "_AC_PROG_CC_C99" "AC_PROG_CC_C99" . - replace "\"$AlexCmd\" -v" "\"$AlexCmd\" -V" . - replace "if ! \"$CXX\"" "if ! eval \"$CXX\"" - =<< readFile' aclocalm4 - where aclocalm4 = "aclocal.m4" + writeFile aclocalm4 + . replace "_AC_PROG_CC_C99" "AC_PROG_CC_C99" + . replace "\"$AlexCmd\" -v" "\"$AlexCmd\" -V" + . replace "if ! \"$CXX\"" "if ! eval \"$CXX\"" + =<< readFile' aclocalm4 + where + aclocalm4 = "aclocal.m4" applyPatchFptoolsAlex :: GhcFlavor -> IO () applyPatchFptoolsAlex ghcFlavor = do fptools_alex_exists <- doesFileExist fptools_alex_m4 when (fptools_alex_exists && ghcFlavor <= Ghc982) $ - writeFile fptools_alex_m4 . - replace "\"$AlexCmd\" -v" "\"$AlexCmd\" -V" - =<< readFile' fptools_alex_m4 + writeFile fptools_alex_m4 + . replace "\"$AlexCmd\" -v" "\"$AlexCmd\" -V" + =<< readFile' fptools_alex_m4 where fptools_alex_m4 = "m4/fptools_alex.m4" @@ -983,9 +992,9 @@ applyPatchFpFindCxxStdLib :: GhcFlavor -> IO () applyPatchFpFindCxxStdLib ghcFlavor = do fp_find_cxx_std_lib_exists <- doesFileExist fp_find_cxx_std_lib_m4 when (fp_find_cxx_std_lib_exists && ghcFlavor <= Ghc982) $ - writeFile fp_find_cxx_std_lib_m4 . - replace "if ! \"$CXX\"" "if ! eval \"$CXX\"" - =<< readFile' fp_find_cxx_std_lib_m4 + writeFile fp_find_cxx_std_lib_m4 + . replace "if ! \"$CXX\"" "if ! eval \"$CXX\"" + =<< readFile' fp_find_cxx_std_lib_m4 where fp_find_cxx_std_lib_m4 = "m4/fp_find_cxx_std_lib.m4" @@ -999,9 +1008,9 @@ applyPatchFpFindCxxStdLib ghcFlavor = do -} applyPatchNoMonoLocalBinds :: GhcFlavor -> IO () applyPatchNoMonoLocalBinds _ = - forM_ [ "libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc", "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc" ] $ - \file -> - (writeFile file . ("{-# LANGUAGE NoMonoLocalBinds #-}\n" ++)) + forM_ ["libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc", "libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc"] $ + \file -> + (writeFile file . ("{-# LANGUAGE NoMonoLocalBinds #-}\n" ++)) =<< readFile' file {- 'CmmParse.y' on the ghc-8.10.* branches is missing an import. It's @@ -1021,41 +1030,41 @@ applyPatchCmmParseNoImplicitPrelude _ = do let cmmParse = "compiler/cmm/CmmParse.y" fileExists <- doesFileExist cmmParse when fileExists $ - writeFile cmmParse . - replace + writeFile cmmParse + . replace "import GhcPrelude" "import GhcPrelude\nimport qualified Prelude" - =<< readFile' cmmParse + =<< readFile' cmmParse applyPatchHadrianCabalProject :: GhcFlavor -> IO () applyPatchHadrianCabalProject _ = do - cabalProjectContents <- lines' <$> readFile' cabalProject - cabalProjectContents <- pure (unlines (cabalProjectContents ++ [ "flags:-selftest -with_bazel" ])) - writeFile cabalProject cabalProjectContents - whenM (doesPathExist cabalProjectFreeze) $ removePathForcibly cabalProjectFreeze - where - lines' s = [ l | l <- lines s , not $ "index-state" `isPrefixOf` l ] - cabalProject = "hadrian" "cabal.project" - cabalProjectFreeze = cabalProject ++ ".freeze" + cabalProjectContents <- lines' <$> readFile' cabalProject + cabalProjectContents <- pure (unlines (cabalProjectContents ++ ["flags:-selftest -with_bazel"])) + writeFile cabalProject cabalProjectContents + whenM (doesPathExist cabalProjectFreeze) $ removePathForcibly cabalProjectFreeze + where + lines' s = [l | l <- lines s, not $ "index-state" `isPrefixOf` l] + cabalProject = "hadrian" "cabal.project" + cabalProjectFreeze = cabalProject ++ ".freeze" -- Data type representing an approximately parsed Cabal file. data Cabal = Cabal - { cabalDir :: FilePath -- the directory this file exists in - , cabalFields :: [(String, [String])] -- the key/value pairs it contains - } + { cabalDir :: FilePath, -- the directory this file exists in + cabalFields :: [(String, [String])] -- the key/value pairs it contains + } -- Given a file, produce the key/value pairs it contains (approximate -- but good enough). readCabalFile :: FilePath -> IO Cabal readCabalFile file = do - src <- readFile' file - let fields = repeatedly f $ wordsBy (\x -> isSpace x || x == ',') $ unlines $ filter (not . isIf) $ map trimComment $ lines src - return $ Cabal (takeDirectory file) fields - where - isIf x = "if " `isPrefixOf` trim x - trimComment x = maybe x fst $ stripInfix "--" x - f (x : xs) = let (a, b) = break (":" `isSuffixOf`) xs in ((lower x, a), b) - f [] = error "readCabalFile: unexpected empty file" + src <- readFile' file + let fields = repeatedly f $ wordsBy (\x -> isSpace x || x == ',') $ unlines $ filter (not . isIf) $ map trimComment $ lines src + return $ Cabal (takeDirectory file) fields + where + isIf x = "if " `isPrefixOf` trim x + trimComment x = maybe x fst $ stripInfix "--" x + f (x : xs) = let (a, b) = break (":" `isSuffixOf`) xs in ((lower x, a), b) + f [] = error "readCabalFile: unexpected empty file" -- Ask a Cabal file for a field. askCabalField :: Cabal -> String -> [String] @@ -1078,10 +1087,13 @@ askFiles from x = nubSort $ concatMap (`askCabalFiles` x) from -- Some often used string manipulation utilities. indent :: [String] -> [String] indent = map (" " ++) + indent2 :: [String] -> [String] indent2 = indent . indent + indent3 :: [String] -> [String] -indent3 = indent . indent . indent +indent3 = indent . indent . indent + withCommas :: Data.List.NonEmpty.NonEmpty String -> Data.List.NonEmpty.NonEmpty String withCommas ms = Data.List.NonEmpty.fromList $ reverse (Data.List.NonEmpty.head ms' : map (++ ",") (Data.List.NonEmpty.tail ms')) where @@ -1097,67 +1109,66 @@ withCommas ms = Data.List.NonEmpty.fromList $ reverse (Data.List.NonEmpty.head m -- version. baseBounds :: GhcFlavor -> String baseBounds = \case - -- ghc >= 8.4.4 - DaGhc881 -> "base >= 4.11 && < 4.16" -- unlike upstream GHC 8.8, the DA fork does work with ghc-8.10.1 and ghc-9.0.2 - Ghc881 -> "base >= 4.11 && < 4.14" -- [ghc-8.4.4, ghc-8.10.1) - Ghc882 -> "base >= 4.11 && < 4.14" - Ghc883 -> "base >= 4.11 && < 4.14" - Ghc884 -> "base >= 4.11 && < 4.14" - - Ghc8101 -> "base >= 4.12 && < 4.15" -- [ghc-8.6.5, ghc-9.0.1) - Ghc8102 -> "base >= 4.12 && < 4.15" - Ghc8103 -> "base >= 4.12 && < 4.15" - Ghc8104 -> "base >= 4.12 && < 4.15" - Ghc8105 -> "base >= 4.12 && < 4.15" - Ghc8106 -> "base >= 4.12 && < 4.15" - Ghc8107 -> "base >= 4.12 && < 4.15" - - Ghc901 -> "base >= 4.13 && < 4.16" -- [ghc-8.8.1, ghc-9.2.1) - Ghc902 -> "base >= 4.13 && < 4.16" -- [ghc-8.8.1, ghc-9.2.1) - - -- ghc-9.2.1, base-4.16.0.0 - -- ghc-9.2.2, base-4.16.1.0 - -- ghc-9.2.2, base-4.16.2.0 - -- ghc-9.2.4, base-4.16.3.0 - -- ghc-9.2.5, ghc-9.2.6, ghc-9.2.7, ghc-9.2.8 ship with base-4.16.4.0 - Ghc921 -> "base >= 4.14 && < 4.16.1" -- [ghc-8.10.1, ghc-9.2.2) - Ghc922 -> "base >= 4.14 && < 4.16.2" -- [ghc-8.10.1, ghc-9.2.3) - Ghc923 -> "base >= 4.14 && < 4.16.3" -- [ghc-8.10.1, ghc-9.2.4) - Ghc924 -> "base >= 4.14 && < 4.16.4" -- [ghc-8.10.1, ghc-9.2.5) - Ghc925 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) - Ghc926 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) - Ghc927 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) - Ghc928 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) - -- ghc-9.4.1, ghc-9.4.2, ghc-9.4.3, ghc-9.4.4 all ship with - -- base-4.17.0.0, ghc-9.4.5 has base-4.17.1.0, ghc-9.4.6 has - -- base-4.17.2.0 - Ghc941 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc942 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc943 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc944 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc945 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc946 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc947 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - Ghc948 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) - - -- require bytestring >= 0.11.3 which rules out ghc-9.2.1 - -- base-4.18.0 - Ghc961 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - Ghc962 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - Ghc963 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - Ghc964 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - Ghc965 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - Ghc966 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) - - -- base-4.19.0.0, ghc-prim-0.11.0 - Ghc981 -> "base >= 4.17 && < 4.19.1" -- [ghc-9.4.1, ghc-9.8.2) - -- base-4.19.1.0 - Ghc982 -> "base >= 4.17 && < 4.20" -- [ghc-9.4.1, ghc-9.10.1) - -- base-4.20.0.0 - Ghc9101 -> "base >= 4.18 && < 4.21" -- [ghc-9.6.1, ghc-9.12.1) - GhcMaster -- e.g. "9.11.20230119" - -- (c.f. 'rts/include/ghcversion.h') - -> "base >= 4.18 && < 4.21" -- [ghc-9.6.1, ghc-9.12.1) + -- ghc >= 8.4.4 + DaGhc881 -> "base >= 4.11 && < 4.16" -- unlike upstream GHC 8.8, the DA fork does work with ghc-8.10.1 and ghc-9.0.2 + Ghc881 -> "base >= 4.11 && < 4.14" -- [ghc-8.4.4, ghc-8.10.1) + Ghc882 -> "base >= 4.11 && < 4.14" + Ghc883 -> "base >= 4.11 && < 4.14" + Ghc884 -> "base >= 4.11 && < 4.14" + Ghc8101 -> "base >= 4.12 && < 4.15" -- [ghc-8.6.5, ghc-9.0.1) + Ghc8102 -> "base >= 4.12 && < 4.15" + Ghc8103 -> "base >= 4.12 && < 4.15" + Ghc8104 -> "base >= 4.12 && < 4.15" + Ghc8105 -> "base >= 4.12 && < 4.15" + Ghc8106 -> "base >= 4.12 && < 4.15" + Ghc8107 -> "base >= 4.12 && < 4.15" + Ghc901 -> "base >= 4.13 && < 4.16" -- [ghc-8.8.1, ghc-9.2.1) + Ghc902 -> "base >= 4.13 && < 4.16" -- [ghc-8.8.1, ghc-9.2.1) + + -- ghc-9.2.1, base-4.16.0.0 + -- ghc-9.2.2, base-4.16.1.0 + -- ghc-9.2.2, base-4.16.2.0 + -- ghc-9.2.4, base-4.16.3.0 + -- ghc-9.2.5, ghc-9.2.6, ghc-9.2.7, ghc-9.2.8 ship with base-4.16.4.0 + Ghc921 -> "base >= 4.14 && < 4.16.1" -- [ghc-8.10.1, ghc-9.2.2) + Ghc922 -> "base >= 4.14 && < 4.16.2" -- [ghc-8.10.1, ghc-9.2.3) + Ghc923 -> "base >= 4.14 && < 4.16.3" -- [ghc-8.10.1, ghc-9.2.4) + Ghc924 -> "base >= 4.14 && < 4.16.4" -- [ghc-8.10.1, ghc-9.2.5) + Ghc925 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) + Ghc926 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) + Ghc927 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) + Ghc928 -> "base >= 4.14 && < 4.17" -- [ghc-8.10.1, ghc-9.4.1) + -- ghc-9.4.1, ghc-9.4.2, ghc-9.4.3, ghc-9.4.4 all ship with + -- base-4.17.0.0, ghc-9.4.5 has base-4.17.1.0, ghc-9.4.6 has + -- base-4.17.2.0 + Ghc941 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc942 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc943 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc944 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc945 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc946 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc947 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + Ghc948 -> "base >= 4.15 && < 4.18" -- [ghc-9.0.1, ghc-9.6.1) + + -- require bytestring >= 0.11.3 which rules out ghc-9.2.1 + -- base-4.18.0 + Ghc961 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + Ghc962 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + Ghc963 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + Ghc964 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + Ghc965 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + Ghc966 -> "base >= 4.16.1 && < 4.19" -- [ghc-9.2.2, ghc-9.8.1) + + -- base-4.19.0.0, ghc-prim-0.11.0 + Ghc981 -> "base >= 4.17 && < 4.19.1" -- [ghc-9.4.1, ghc-9.8.2) + -- base-4.19.1.0 + Ghc982 -> "base >= 4.17 && < 4.20" -- [ghc-9.4.1, ghc-9.10.1) + -- base-4.20.0.0 + Ghc9101 -> "base >= 4.18 && < 4.21" -- [ghc-9.6.1, ghc-9.12.1) + GhcMaster -> + -- e.g. "9.11.20230119" + -- (c.f. 'rts/include/ghcversion.h') + "base >= 4.18 && < 4.21" -- [ghc-9.6.1, ghc-9.12.1) -- Common build dependencies. commonBuildDepends :: GhcFlavor -> Data.List.NonEmpty.NonEmpty String @@ -1165,195 +1176,210 @@ commonBuildDepends ghcFlavor = Data.List.NonEmpty.fromList $ base ++ specific ++ conditional ++ shared where -- base - base = [ baseBounds ghcFlavor ] + base = [baseBounds ghcFlavor] specific - | ghcSeries ghcFlavor > GHC_9_10 = [ - "ghc-prim > 0.2 && < 0.12" - , "containers >= 0.6.2.1 && < 0.8" - , "bytestring >= 0.11.4 && < 0.13" - , "time >= 1.4 && < 1.13" - , "filepath >= 1.5 && < 1.6" - , "os-string >= 2.0.1 && < 2.1" - ] - | ghcSeries ghcFlavor >= GHC_9_10 = [ - "ghc-prim > 0.2 && < 0.12" - , "containers >= 0.6.2.1 && < 0.8" - , "bytestring >= 0.11.4 && < 0.13" - , "time >= 1.4 && < 1.13" - , "filepath >= 1 && < 1.6" - ] - | ghcSeries ghcFlavor >= GHC_9_8 = [ - "ghc-prim > 0.2 && < 0.12" - , "containers >= 0.6.2.1 && < 0.7" - , "bytestring >= 0.11.4 && < 0.13" - , "time >= 1.4 && < 1.13" - , "filepath >= 1 && < 1.5" - ] - | ghcSeries ghcFlavor >= GHC_9_6 = [ - "ghc-prim > 0.2 && < 0.11" - , "containers >= 0.6.2.1 && < 0.7" - , "bytestring >= 0.11.3 && < 0.12" - , "time >= 1.4 && < 1.13" - , "filepath >= 1 && < 1.5" - ] - | ghcSeries ghcFlavor >= GHC_9_4 = [ - "ghc-prim > 0.2 && < 0.10" - , "containers >= 0.5 && < 0.7" - , "bytestring >= 0.10 && < 0.12" - , "time >= 1.4 && < 1.13" - , "filepath >= 1 && < 1.5" - ] - | ghcSeries ghcFlavor >= GHC_9_2 = [ - "ghc-prim > 0.2 && < 0.9" - , "containers >= 0.5 && < 0.7" - , "bytestring >= 0.9 && < 0.12" - , "time >= 1.4 && < 1.12" - , "filepath >= 1 && < 1.5" - ] - | otherwise = [ - "ghc-prim > 0.2 && < 0.8" - , "containers >= 0.5 && < 0.7" - , "bytestring >= 0.9 && < 0.11" - , "time >= 1.4 && < 1.10" - , "filepath >= 1 && < 1.5" - ] - conditional - | ghcSeries ghcFlavor >= GHC_9_0 = [ - "exceptions == 0.10.*" - , "parsec" + | ghcSeries ghcFlavor > GHC_9_10 = + [ "ghc-prim > 0.2 && < 0.12", + "containers >= 0.6.2.1 && < 0.8", + "bytestring >= 0.11.4 && < 0.13", + "time >= 1.4 && < 1.13", + "filepath >= 1.5 && < 1.6", + "os-string >= 2.0.1 && < 2.1" + ] + | ghcSeries ghcFlavor >= GHC_9_10 = + [ "ghc-prim > 0.2 && < 0.12", + "containers >= 0.6.2.1 && < 0.8", + "bytestring >= 0.11.4 && < 0.13", + "time >= 1.4 && < 1.13", + "filepath >= 1 && < 1.6" ] - | otherwise = [ + | ghcSeries ghcFlavor >= GHC_9_8 = + [ "ghc-prim > 0.2 && < 0.12", + "containers >= 0.6.2.1 && < 0.7", + "bytestring >= 0.11.4 && < 0.13", + "time >= 1.4 && < 1.13", + "filepath >= 1 && < 1.5" + ] + | ghcSeries ghcFlavor >= GHC_9_6 = + [ "ghc-prim > 0.2 && < 0.11", + "containers >= 0.6.2.1 && < 0.7", + "bytestring >= 0.11.3 && < 0.12", + "time >= 1.4 && < 1.13", + "filepath >= 1 && < 1.5" + ] + | ghcSeries ghcFlavor >= GHC_9_4 = + [ "ghc-prim > 0.2 && < 0.10", + "containers >= 0.5 && < 0.7", + "bytestring >= 0.10 && < 0.12", + "time >= 1.4 && < 1.13", + "filepath >= 1 && < 1.5" + ] + | ghcSeries ghcFlavor >= GHC_9_2 = + [ "ghc-prim > 0.2 && < 0.9", + "containers >= 0.5 && < 0.7", + "bytestring >= 0.9 && < 0.12", + "time >= 1.4 && < 1.12", + "filepath >= 1 && < 1.5" + ] + | otherwise = + [ "ghc-prim > 0.2 && < 0.8", + "containers >= 0.5 && < 0.7", + "bytestring >= 0.9 && < 0.11", + "time >= 1.4 && < 1.10", + "filepath >= 1 && < 1.5" + ] + conditional + | ghcSeries ghcFlavor >= GHC_9_0 = + [ "exceptions == 0.10.*", + "parsec" ] + | otherwise = + [] -- shared for all flavors - shared = [ - "binary == 0.8.*" - , "directory >= 1 && < 1.4" - , "array >= 0.1 && < 0.6" - , "deepseq >= 1.4 && < 1.6" - , "pretty == 1.1.*" - , "transformers >= 0.5 && < 0.7" - , "process >= 1 && < 1.7" + shared = + [ "binary == 0.8.*", + "directory >= 1 && < 1.4", + "array >= 0.1 && < 0.6", + "deepseq >= 1.4 && < 1.6", + "pretty == 1.1.*", + "transformers >= 0.5 && < 0.7", + "process >= 1 && < 1.7" ] ghcLibParserBuildDepends :: GhcFlavor -> Data.List.NonEmpty.NonEmpty String -ghcLibParserBuildDepends = commonBuildDepends +ghcLibParserBuildDepends = commonBuildDepends ghcLibBuildDepends :: GhcFlavor -> Data.List.NonEmpty.NonEmpty String ghcLibBuildDepends ghcFlavor = - commonBuildDepends ghcFlavor <> Data.List.NonEmpty.fromList ( - [ "stm" | ghcSeries ghcFlavor >= GHC_9_4 ] ++ - [ "semaphore-compat" | ghcSeries ghcFlavor >= GHC_9_8 ] ++ - [ "rts" - , "hpc >= 0.6 && < 0.8" - , "ghc-lib-parser" -- we rely on this being last (in CI.hs: - -- 'patchConstraints')! - ]) + commonBuildDepends ghcFlavor + <> Data.List.NonEmpty.fromList + ( join + [ ["stm" | ghcSeries ghcFlavor >= GHC_9_4], + ["semaphore-compat" | ghcSeries ghcFlavor >= GHC_9_8], + [ "rts", + "hpc >= 0.6 && < 0.8", + "ghc-lib-parser" -- we rely on this being last (in CI.hs: + -- 'patchConstraints')! + ] + ] + ) libBinParserLibModules :: GhcFlavor -> IO ([Cabal], [Cabal], [String], [String]) libBinParserLibModules ghcFlavor = do - lib <- mapM readCabalFile (cabalFileLibraries ghcFlavor) - bin <- readCabalFile cabalFileBinary - parserModules <- filterGhcInternalModules <$> calcParserModules ghcFlavor - libModules <- filterGhcInternalModules <$> calcLibModules ghcFlavor - return (lib, [bin], parserModules, libModules) - where - keptGhcInternalModules :: [String] - keptGhcInternalModules = [ "GHC.Internal.ForeignSrcLang", "GHC.Internal.LanguageExtensions", "GHC.Internal.Lexeme", "GHC.Internal.TH.Syntax", "GHC.Internal.TH.Ppr", "GHC.Internal.TH.PprLib", "GHC.Internal.TH.Lib.Map" ] - - filterGhcInternalModules :: [String] -> [String] - filterGhcInternalModules mods = - [ f | f <- mods, not ("GHC.Internal" `isPrefixOf` f) || (f `elem` keptGhcInternalModules) ] + lib <- mapM readCabalFile (cabalFileLibraries ghcFlavor) + bin <- readCabalFile cabalFileBinary + parserModules <- filterGhcInternalModules <$> calcParserModules ghcFlavor + libModules <- filterGhcInternalModules <$> calcLibModules ghcFlavor + return (lib, [bin], parserModules, libModules) + where + keptGhcInternalModules :: [String] + keptGhcInternalModules = ["GHC.Internal.ForeignSrcLang", "GHC.Internal.LanguageExtensions", "GHC.Internal.Lexeme", "GHC.Internal.TH.Syntax", "GHC.Internal.TH.Ppr", "GHC.Internal.TH.PprLib", "GHC.Internal.TH.Lib.Map"] + + filterGhcInternalModules :: [String] -> [String] + filterGhcInternalModules mods = + [f | f <- mods, not ("GHC.Internal" `isPrefixOf` f) || (f `elem` keptGhcInternalModules)] -- Produces a ghc-lib Cabal file. generateGhcLibCabal :: GhcFlavor -> [String] -> IO () generateGhcLibCabal ghcFlavor customCppOpts = do - (lib, _bin, parserModules, libModules) <- libBinParserLibModules ghcFlavor - let nonParserModules = - Set.toList (Set.difference - (Set.fromList libModules) - (Set.fromList parserModules)) - {- Alternative: - ``` - let nonParserModules = - Set.toList (Set.difference - (Set.fromList $ askField lib "exposed-modules:" ) - (Set.fromList parserModules)) - ``` - -} - let hsSrcDirs = replace ["libraries/ghc-boot-th/../ghc-internal/src"] [] (ghcLibHsSrcDirs False ghcFlavor lib) - let includeDirs = replace ["libraries/ghc-internal/include"] [] (ghcLibIncludeDirs ghcFlavor) - writeFile "ghc-lib.cabal" $ unlines $ map trimEnd $ - [ "cabal-version: 3.0" - , "build-type: Simple" - , "name: ghc-lib" - , "version: 0.1.0" - , "license: BSD-3-Clause" - , "license-file: LICENSE" - , "category: Development" - , "author: The GHC Team and Digital Asset" - , "maintainer: Digital Asset" - , "synopsis: The GHC API, decoupled from GHC versions" - , "description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions." - , "homepage: https://github.com/digital-asset/ghc-lib" - , "bug-reports: https://github.com/digital-asset/ghc-lib/issues" - , "data-dir: " ++ dataDir - , "data-files:"] ++ indent (dataFiles ghcFlavor) ++ - [ "extra-source-files:"] ++ indent (performExtraFilesSubstitutions ghcFlavor ghcLibExtraFiles) ++ - [ "source-repository head" - , " type: git" - , " location: git@github.com:digital-asset/ghc-lib.git" - ] ++ - [ "flag threaded-rts" - , " default: True" - , " manual: True" - , " description: Pass -DTHREADED_RTS to the C toolchain" - ] ++ - [ "library" ] ++ - [ " default-language: Haskell2010" | ghcFlavor < Ghc9101 ] ++ - [ " default-language: GHC2021" | ghcFlavor >= Ghc9101 ] ++ - [ " exposed: False" - , " include-dirs:" - ] ++ indent2 includeDirs ++ - [ " if impl(ghc >= 8.8.1)" - , " ghc-options: -fno-safe-haskell" ] ++ - [ " if flag(threaded-rts)" - , " ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS" - , " cc-options: -DTHREADED_RTS" - , " cpp-options: -DTHREADED_RTS " <> generateCppOpts ghcFlavor customCppOpts - , " else" - , " ghc-options: -fobject-code -package=ghc-boot-th" - , " cpp-options: " <> generateCppOpts ghcFlavor customCppOpts - ] ++ - [ " if !os(windows)" - , " build-depends: unix" - , " else" - , " build-depends: Win32" - , " build-depends:" ] ++ - indent2 (Data.List.NonEmpty.toList (withCommas (ghcLibBuildDepends ghcFlavor)))++ - [ " build-tool-depends: alex:alex >= 3.1, " ++ "happy:happy > " ++ if ghcSeries ghcFlavor < GHC_8_10 then "1.19" else "1.20" ] ++ - [ " other-extensions:" ] ++ indent2 (askField lib "other-extensions:") ++ - [ " default-extensions:" ] ++ indent2 (askField lib "default-extensions:") ++ - [ " hs-source-dirs:" ] ++ - indent2 hsSrcDirs ++ - [ " autogen-modules:" - , " Paths_ghc_lib" - ] ++ - [ " reexported-modules:" ] ++ - indent2 (Data.List.NonEmpty.toList (withCommas (Data.List.NonEmpty.fromList $ nubSort parserModules))) ++ - [ " exposed-modules:" - , " Paths_ghc_lib" - ] ++ - indent2 (nubSort nonParserModules) - putStrLn "# Generating 'ghc-lib.cabal'... Done!" + (lib, _bin, parserModules, libModules) <- libBinParserLibModules ghcFlavor + let nonParserModules = + Set.toList + ( Set.difference + (Set.fromList libModules) + (Set.fromList parserModules) + ) + {- Alternative: + ``` + let nonParserModules = + Set.toList (Set.difference + (Set.fromList $ askField lib "exposed-modules:" ) + (Set.fromList parserModules)) + ``` + -} + let hsSrcDirs = replace ["libraries/ghc-boot-th/../ghc-internal/src"] [] (ghcLibHsSrcDirs False ghcFlavor lib) + let includeDirs = replace ["libraries/ghc-internal/include"] [] (ghcLibIncludeDirs ghcFlavor) + writeFile "ghc-lib.cabal" . unlines . map trimEnd . join $ + [ [ "cabal-version: 3.0", + "build-type: Simple", + "name: ghc-lib", + "version: 0.1.0", + "license: BSD-3-Clause", + "license-file: LICENSE", + "category: Development", + "author: The GHC Team and Digital Asset", + "maintainer: Digital Asset", + "synopsis: The GHC API, decoupled from GHC versions", + "description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.", + "homepage: https://github.com/digital-asset/ghc-lib", + "bug-reports: https://github.com/digital-asset/ghc-lib/issues", + "data-dir: " ++ dataDir, + "data-files:" + ], + indent (dataFiles ghcFlavor), + ["extra-source-files:"], + indent (performExtraFilesSubstitutions ghcFlavor ghcLibExtraFiles), + [ "source-repository head", + " type: git", + " location: git@github.com:digital-asset/ghc-lib.git" + ], + [ "flag threaded-rts", + " default: True", + " manual: True", + " description: Pass -DTHREADED_RTS to the C toolchain" + ], + ["library"], + [" default-language: Haskell2010" | ghcFlavor < Ghc9101], + [" default-language: GHC2021" | ghcFlavor >= Ghc9101], + [ " exposed: False", + " include-dirs:" + ], + indent2 includeDirs, + [ " if impl(ghc >= 8.8.1)", + " ghc-options: -fno-safe-haskell" + ], + [ " if flag(threaded-rts)", + " ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS", + " cc-options: -DTHREADED_RTS", + " cpp-options: -DTHREADED_RTS " ++ generateCppOpts ghcFlavor customCppOpts, + " else", + " ghc-options: -fobject-code -package=ghc-boot-th", + " cpp-options: " ++ generateCppOpts ghcFlavor customCppOpts + ], + [ " if !os(windows)", + " build-depends: unix", + " else", + " build-depends: Win32", + " build-depends:" + ], + indent2 (Data.List.NonEmpty.toList (withCommas (ghcLibBuildDepends ghcFlavor))), + [" build-tool-depends: alex:alex >= 3.1, " ++ "happy:happy > " ++ if ghcSeries ghcFlavor < GHC_8_10 then "1.19" else "1.20"], + [" other-extensions:"], + indent2 (askField lib "other-extensions:"), + [" default-extensions:"], + indent2 (askField lib "default-extensions:"), + [" hs-source-dirs:"], + indent2 hsSrcDirs, + [ " autogen-modules:", + " Paths_ghc_lib" + ], + [" reexported-modules:"], + indent2 (Data.List.NonEmpty.toList (withCommas (Data.List.NonEmpty.fromList $ nubSort parserModules))), + [ " exposed-modules:", + " Paths_ghc_lib" + ], + indent2 (nubSort nonParserModules) + ] + putStrLn "# Generating 'ghc-lib.cabal'... Done!" generateCppOpts :: GhcFlavor -> [String] -> String generateCppOpts ghcFlavor customCppOpts = - unwords $ [ - ghcStageDef ghcFlavor - , ghcInGhciDef ghcFlavor - , bootstrapTh ghcFlavor - ] ++ - customCppOpts + unwords $ + [ ghcStageDef ghcFlavor, + ghcInGhciDef ghcFlavor, + bootstrapTh ghcFlavor + ] + ++ customCppOpts where ghcInGhciDef, ghcStageDef :: GhcFlavor -> String ghcInGhciDef = \case f | ghcSeries f >= GHC_9_2 -> ""; _ -> "-DGHC_IN_GHCI" @@ -1363,169 +1389,184 @@ generateCppOpts ghcFlavor customCppOpts = -- Perform a set of specific substitutions on the given list of files. performExtraFilesSubstitutions :: GhcFlavor -> (GhcFlavor -> [FilePath]) -> [FilePath] performExtraFilesSubstitutions ghcFlavor files = - foldl' sub (files ghcFlavor) $ - [ ("rts/include/ghcversion.h", Nothing) | ghcSeries ghcFlavor >= GHC_9_4 ] ++ - [ (hadrianGeneratedRoot ghcFlavor "ghcversion.h", Nothing) | ghcSeries ghcFlavor < GHC_9_4 ] ++ - [ ((stage0Rts "include") "DerivedConstants.h", Just $ (stage0Rts "include") "GhclibDerivedConstants.h") | ghcSeries ghcFlavor >= GHC_9_4] ++ - [ (hadrianGeneratedRoot ghcFlavor "DerivedConstants.h", Just $ hadrianGeneratedRoot ghcFlavor "GhclibDerivedConstants.h") | ghcSeries ghcFlavor < GHC_9_4 ] ++ - [("compiler" "HsVersions.h", Just $ "compiler" "GhclibHsVersions.h") | ghcSeries ghcFlavor < GHC_9_4 ] + foldl' sub (files ghcFlavor) . join $ + [ [("rts/include/ghcversion.h", Nothing) | ghcSeries ghcFlavor >= GHC_9_4], + [(hadrianGeneratedRoot ghcFlavor "ghcversion.h", Nothing) | ghcSeries ghcFlavor < GHC_9_4], + [((stage0Rts "include") "DerivedConstants.h", Just $ (stage0Rts "include") "GhclibDerivedConstants.h") | ghcSeries ghcFlavor >= GHC_9_4], + [(hadrianGeneratedRoot ghcFlavor "DerivedConstants.h", Just $ hadrianGeneratedRoot ghcFlavor "GhclibDerivedConstants.h") | ghcSeries ghcFlavor < GHC_9_4], + [("compiler" "HsVersions.h", Just $ "compiler" "GhclibHsVersions.h") | ghcSeries ghcFlavor < GHC_9_4] + ] where - sub :: Eq a => [a] -> (a, Maybe a) -> [a] + sub :: (Eq a) => [a] -> (a, Maybe a) -> [a] sub xs (s, r) = replace [s] (maybeToList r) xs -- Produces a ghc-lib-parser Cabal file. generateGhcLibParserCabal :: GhcFlavor -> [String] -> IO () generateGhcLibParserCabal ghcFlavor customCppOpts = do - (lib, _bin, parserModules, _) <- libBinParserLibModules ghcFlavor - let hsSrcDirs = replace ["libraries/ghc-boot-th/../ghc-internal/src"] ["libraries/ghc-internal/src"] (ghcLibParserHsSrcDirs False ghcFlavor lib) - let includeDirs = replace ["libraries/ghc-internal/include"] [] (ghcLibParserIncludeDirs ghcFlavor) - writeFile "ghc-lib-parser.cabal" $ unlines $ map trimEnd $ - [ "cabal-version: 3.0" - , "build-type: Simple" - , "name: ghc-lib-parser" - , "version: 0.1.0" - , "license: BSD-3-Clause" - , "license-file: LICENSE" - , "category: Development" - , "author: The GHC Team and Digital Asset" - , "maintainer: Digital Asset" - , "synopsis: The GHC API, decoupled from GHC versions" - , "description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions." - , "homepage: https://github.com/digital-asset/ghc-lib" - , "bug-reports: https://github.com/digital-asset/ghc-lib/issues" - , "data-dir: " ++ dataDir - , "data-files:" - ] ++ indent (dataFiles ghcFlavor) ++ - [ "extra-source-files:"] ++ indent (performExtraFilesSubstitutions ghcFlavor ghcLibParserExtraFiles) ++ - [ "source-repository head" - , " type: git" - , " location: git@github.com:digital-asset/ghc-lib.git" - ] ++ - [ "flag threaded-rts" - , " default: True" - , " manual: True" - , " description: Pass -DTHREADED_RTS to the C toolchain" - ] ++ - [ "library" ] ++ - [ " default-language: Haskell2010" | ghcFlavor < Ghc9101 ] ++ - [ " default-language: GHC2021" | ghcFlavor >= Ghc9101 ] ++ - [ " exposed: False" - , " include-dirs:" - ] ++ indent2 includeDirs ++ - [ " if impl(ghc >= 8.8.1)" - , " ghc-options: -fno-safe-haskell" ] ++ - [ " if flag(threaded-rts)" - , " ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS" - , " cc-options: -DTHREADED_RTS" - , " cpp-options: -DTHREADED_RTS " <> generateCppOpts ghcFlavor customCppOpts - , " else" - , " ghc-options: -fobject-code -package=ghc-boot-th" - , " cpp-options: " <> generateCppOpts ghcFlavor customCppOpts - ] ++ - [ " if !os(windows)" - , " build-depends: unix" - , " else" - , " build-depends: Win32" - , " build-depends:" ] ++ - indent2 (Data.List.NonEmpty.toList (withCommas (ghcLibParserBuildDepends ghcFlavor))) ++ - [ " if impl(ghc >= 9.10)" - , " build-depends: ghc-internal"] ++ - [ " build-tool-depends: alex:alex >= 3.1, " ++ "happy:happy > " ++ if ghcSeries ghcFlavor < GHC_8_10 then "1.19" else "1.20" ] ++ - [ " other-extensions:" ] ++ indent2 (askField lib "other-extensions:") ++ - [ " default-extensions:" ] ++ indent2 (askField lib "default-extensions:") ++ - [ " if impl(ghc >= 9.2.2) "] ++ -- cabal >= 3.6.0 - [ " cmm-sources:" ] ++ - indent3 [ "libraries/ghc-heap/cbits/HeapPrim.cmm" ] ++ - [ " else" ] ++ - [ " c-sources:" ] ++ - indent3 [ "libraries/ghc-heap/cbits/HeapPrim.cmm" ] ++ - [ " c-sources:" ] ++ - indent2 [ "compiler/cbits/genSym.c" ] ++ - indent2 [ "compiler/cbits/cutils.c" | ghcSeries ghcFlavor >= GHC_9_0 ] ++ - indent2 [ "compiler/parser/cutils.c" | ghcSeries ghcFlavor < GHC_9_0 ] ++ - indent2 [ "compiler/cbits/keepCAFsForGHCi.c" | ghcFlavor `elem` [Ghc926, Ghc927, Ghc928, Ghc945, Ghc946, Ghc947, Ghc948] || ghcSeries ghcFlavor >= GHC_9_6 ] ++ - [ " hs-source-dirs:" ] ++ - indent2 hsSrcDirs ++ - [ " autogen-modules:" ] ++ - indent2 [ x | ghcSeries ghcFlavor >= GHC_9_0, x <- [ "GHC.Parser.Lexer", "GHC.Parser" ] ] ++ - indent2 [ x | ghcSeries ghcFlavor < GHC_9_0, x <- [ "Lexer", "Parser" ] ] ++ - [" exposed-modules:" ] ++ indent2 parserModules - putStrLn "# Generating 'ghc-lib-parser.cabal'... Done!" + (lib, _bin, parserModules, _) <- libBinParserLibModules ghcFlavor + let hsSrcDirs = replace ["libraries/ghc-boot-th/../ghc-internal/src"] ["libraries/ghc-internal/src"] (ghcLibParserHsSrcDirs False ghcFlavor lib) + let includeDirs = replace ["libraries/ghc-internal/include"] [] (ghcLibParserIncludeDirs ghcFlavor) + writeFile "ghc-lib-parser.cabal" . unlines . map trimEnd . join $ + [ [ "cabal-version: 3.0", + "build-type: Simple", + "name: ghc-lib-parser", + "version: 0.1.0", + "license: BSD-3-Clause", + "license-file: LICENSE", + "category: Development", + "author: The GHC Team and Digital Asset", + "maintainer: Digital Asset", + "synopsis: The GHC API, decoupled from GHC versions", + "description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.", + "homepage: https://github.com/digital-asset/ghc-lib", + "bug-reports: https://github.com/digital-asset/ghc-lib/issues", + "data-dir: " ++ dataDir, + "data-files:" + ], + indent (dataFiles ghcFlavor), + ["extra-source-files:"], + indent (performExtraFilesSubstitutions ghcFlavor ghcLibParserExtraFiles), + [ "source-repository head", + " type: git", + " location: git@github.com:digital-asset/ghc-lib.git" + ], + [ "flag threaded-rts", + " default: True", + " manual: True", + " description: Pass -DTHREADED_RTS to the C toolchain" + ], + ["library"], + [" default-language: Haskell2010" | ghcFlavor < Ghc9101], + [" default-language: GHC2021" | ghcFlavor >= Ghc9101], + [ " exposed: False", + " include-dirs:" + ], + indent2 includeDirs, + [ " if impl(ghc >= 8.8.1)", + " ghc-options: -fno-safe-haskell" + ], + [ " if flag(threaded-rts)", + " ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS", + " cc-options: -DTHREADED_RTS", + " cpp-options: -DTHREADED_RTS " ++ generateCppOpts ghcFlavor customCppOpts, + " else", + " ghc-options: -fobject-code -package=ghc-boot-th", + " cpp-options: " ++ generateCppOpts ghcFlavor customCppOpts + ], + [ " if !os(windows)", + " build-depends: unix", + " else", + " build-depends: Win32", + " build-depends:" + ], + indent2 (Data.List.NonEmpty.toList (withCommas (ghcLibParserBuildDepends ghcFlavor))), + [ " if impl(ghc >= 9.10)", + " build-depends: ghc-internal" + ], + [" build-tool-depends: alex:alex >= 3.1, " ++ "happy:happy > " ++ if ghcSeries ghcFlavor < GHC_8_10 then "1.19" else "1.20"], + [" other-extensions:"], + indent2 (askField lib "other-extensions:"), + [" default-extensions:"], + indent2 (askField lib "default-extensions:"), + [" if impl(ghc >= 9.2.2) "], -- cabal >= 3.6.0 + [" cmm-sources:"], + indent3 ["libraries/ghc-heap/cbits/HeapPrim.cmm"], + [" else"], + [" c-sources:"], + indent3 ["libraries/ghc-heap/cbits/HeapPrim.cmm"], + [" c-sources:"], + indent2 ["compiler/cbits/genSym.c"], + indent2 ["compiler/cbits/cutils.c" | ghcSeries ghcFlavor >= GHC_9_0], + indent2 ["compiler/parser/cutils.c" | ghcSeries ghcFlavor < GHC_9_0], + indent2 ["compiler/cbits/keepCAFsForGHCi.c" | ghcFlavor `elem` [Ghc926, Ghc927, Ghc928, Ghc945, Ghc946, Ghc947, Ghc948] || ghcSeries ghcFlavor >= GHC_9_6], + [" hs-source-dirs:"], + indent2 hsSrcDirs, + [" autogen-modules:"], + indent2 [x | ghcSeries ghcFlavor >= GHC_9_0, x <- ["GHC.Parser.Lexer", "GHC.Parser"]], + indent2 [x | ghcSeries ghcFlavor < GHC_9_0, x <- ["Lexer", "Parser"]], + [" exposed-modules:"], + indent2 parserModules + ] + putStrLn "# Generating 'ghc-lib-parser.cabal'... Done!" -- Run Hadrian to build the things that the Cabal files need. generatePrerequisites :: GhcFlavor -> IO () generatePrerequisites ghcFlavor = do - when (ghcSeries ghcFlavor < GHC_8_10) ( - -- Workaround a Windows bug present in at least 8.4.3. See - -- http://haskell.1045720.n5.nabble.com/msys-woes-td5898334.html - writeFile "./mk/get-win32-tarballs.sh" . - replace - "$curl_cmd || echo \"Checking repo.msys2.org instead of Haskell.org...\" && $curl_cmd_bnk || {" - "$curl_cmd || (echo \"Checking repo.msys2.org instead of Haskell.org...\" && $curl_cmd_bnk) || {" - =<< readFile' "./mk/get-win32-tarballs.sh" + when + (ghcSeries ghcFlavor < GHC_8_10) + ( -- Workaround a Windows bug present in at least 8.4.3. See + -- http://haskell.1045720.n5.nabble.com/msys-woes-td5898334.html + writeFile "./mk/get-win32-tarballs.sh" + . replace + "$curl_cmd || echo \"Checking repo.msys2.org instead of Haskell.org...\" && $curl_cmd_bnk || {" + "$curl_cmd || (echo \"Checking repo.msys2.org instead of Haskell.org...\" && $curl_cmd_bnk) || {" + =<< readFile' "./mk/get-win32-tarballs.sh" ) system_ "bash -c ./boot" system_ "bash -c \"./configure --enable-tarballs-autodownload\"" withCurrentDirectory "hadrian" $ do system_ "cabal build exe:hadrian --ghc-options=-j" - system_ $ unwords $ [ - "cabal run exe:hadrian --" - , "--directory=.." - , "--build-root=ghc-lib" - ] ++ - [ "--bignum=native" | ghcSeries ghcFlavor >= GHC_9_0 ] ++ - [ "--integer-simple" | ghcSeries ghcFlavor < GHC_9_0 ] ++ - ghcLibParserExtraFiles ghcFlavor ++ map (dataDir ) (dataFiles ghcFlavor) + system_ . unwords . join $ + [ [ "cabal run exe:hadrian --", + "--directory=..", + "--build-root=ghc-lib" + ], + ["--bignum=native" | ghcSeries ghcFlavor >= GHC_9_0], + ["--integer-simple" | ghcSeries ghcFlavor < GHC_9_0], + ghcLibParserExtraFiles ghcFlavor, + map (dataDir ) $ dataFiles ghcFlavor + ] -- Given an Hsc, Alex, or Happy file, generate a placeholder module -- with the same module imports. genPlaceholderModule :: FilePath -> IO () genPlaceholderModule m = do - (name, imports) <- withFile m ReadMode $ \h -> do - name <- parseModuleName h - imports <- parseModuleImports h [] - pure (name, imports) - let fname = placeholderModulesDir T.unpack (T.replace "." "/" name <> ".hs") - createDirectoryIfMissing True (takeDirectory fname) - withFile fname WriteMode $ \h -> do - T.hPutStrLn h $ "module " <> name <> " where" - let extra = extraImports $ takeExtension fname - forM_ (imports ++ extra) $ \i -> T.hPutStrLn h $ "import " <> i - pure () + (name, imports) <- withFile m ReadMode $ \h -> do + name <- parseModuleName h + imports <- parseModuleImports h [] + pure (name, imports) + let fname = placeholderModulesDir T.unpack (T.replace "." "/" name <> ".hs") + createDirectoryIfMissing True (takeDirectory fname) + withFile fname WriteMode $ \h -> do + T.hPutStrLn h $ "module " <> name <> " where" + let extra = extraImports $ takeExtension fname + forM_ (imports ++ extra) $ \i -> T.hPutStrLn h $ "import " <> i + pure () where parseModuleName :: Handle -> IO T.Text parseModuleName h = do l <- T.hGetLine h - if "module " `T.isPrefixOf` l then - case T.words l of + if "module " `T.isPrefixOf` l + then case T.words l of _module : name : _ -> pure $ T.takeWhile (/= '(') name _ -> fail $ "Cannot parse module name of " ++ m - else - parseModuleName h + else + parseModuleName h parseModuleImports :: Handle -> [T.Text] -> IO [T.Text] parseModuleImports h acc = handleEof acc $ do - l <- T.hGetLine h - acc <- if "import " `T.isPrefixOf` l then - case T.words l of - _import : "::" : _ -> pure acc -- Skip `import :: { ... }` in Parser.y - _import : "qualified" : name : _ -> do - pure $ T.takeWhile (/= '(') name : acc - _import : name : _ -> do - pure $ T.takeWhile (/= '(') name : acc - _ -> fail $ "Cannot parse import in " ++ m ++ " in line " ++ T.unpack l - else - pure acc - parseModuleImports h acc + l <- T.hGetLine h + acc <- + if "import " `T.isPrefixOf` l + then case T.words l of + _import : "::" : _ -> pure acc -- Skip `import :: { ... }` in Parser.y + _import : "qualified" : name : _ -> do + pure $ T.takeWhile (/= '(') name : acc + _import : name : _ -> do + pure $ T.takeWhile (/= '(') name : acc + _ -> fail $ "Cannot parse import in " ++ m ++ " in line " ++ T.unpack l + else + pure acc + parseModuleImports h acc handleEof :: a -> IO a -> IO a handleEof acc = handle $ \e -> if isEOFError e then pure acc else ioError e extraImports :: String -> [T.Text] - extraImports ".x" = [ "Data.Array", "Data.Array.Base", "GHC.Exts" ] -- Alex adds these imports - extraImports ".y" = [ "Data.Array", "GHC.Exts" ] -- Happy adds these imports + extraImports ".x" = ["Data.Array", "Data.Array.Base", "GHC.Exts"] -- Alex adds these imports + extraImports ".y" = ["Data.Array", "GHC.Exts"] -- Happy adds these imports extraImports _ = [] genPlaceholderModules :: FilePath -> IO () @@ -1533,7 +1574,8 @@ genPlaceholderModules = loop where loop fp = do isDir <- doesDirectoryExist fp - if isDir then do - contents <- listDirectory fp - mapM_ (loop . (fp )) contents - else when (takeExtension fp `elem` [".x", ".y", ".hsc"]) $ genPlaceholderModule fp + if isDir + then do + contents <- listDirectory fp + mapM_ (loop . (fp )) contents + else when (takeExtension fp `elem` [".x", ".y", ".hsc"]) $ genPlaceholderModule fp