{-# LANGUAGE StandaloneDeriving #-}

 {-# LANGUAGE StandaloneKindSignatures #-}

 {-# LANGUAGE TypeOperators #-}

 module Base (

     -- * General utilities

     module Development.Shake.Util,

     Vec(..), (&%>),

     -- * Basic data types

     module Hadrian.Package,

 #endif

 import qualified Development.Shake as Shake

 import Development.Shake.Classes

 import Development.Shake.Util

 import Hadrian.Oracles.DirectoryContents

 import Hadrian.Utilities

 import Stage

 import Way

 -- | Hadrian lives in the 'hadrianPath' directory of the GHC tree.

 hadrianPath :: FilePath

 import qualified Data.ByteString.Lazy.Char8 as BSL

 import Development.Shake.Classes

 import Development.Shake.Command

 import GHC.Generics

 import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..))

 import qualified Hadrian.Builder as H

     -- Get program from a certain stage's target configuration

     fromStageTC stage keyname key = do

         validate keyname path

     validate keyname path = do

             case (windowsHost, hasExtension fullPath) of

                 (False, _    ) -> return path

                 (True , True ) -> fixAbsolutePathOnWindows fullPath

     -- Without this function, on Windows we can observe a bad builder path

     -- for 'autoreconf'. If the relevant system.config field is set to

 -- | Get the 'Target' configuration of the current stage

 getStagedTarget :: Expr Context b Target

 -- | Path to the directory containing the final artifact in a given 'Context'.

 libPath :: Context -> Action FilePath

             -- TODO: get rid of EFF_ altogether (#14647) and make sure

             -- unregisterised backend emits clean C without needing

             -- these hacks.

           ]

       -- N.B. We currently don't build the boot libraries' C sources with -Werror

       -- as this tends to be a portability nightmare.

   flav <- flavour

   let flavourArgs = extraArgs flav

   projectVersion <- setting ProjectVersion

   let pkgHashCompilerId = "ghc-" ++ projectVersion

       pkgHashPlatform = targetOs

     ) where

 import Development.Shake.Classes

 import GHC.Generics

 import Hadrian.Utilities

 targetRTSLinkerOnlySupportsSharedLibs :: Stage -> Action Bool

 targetRTSLinkerOnlySupportsSharedLibs s =

 arSupportsDashL :: Stage -> Action Bool

 arSupportsAtFile :: Stage -> Action Bool

 targetSupportsSharedLibs :: Stage -> Action Bool

 targetSupportsSharedLibs stage = do

 -- | Does the target support the -N RTS flag?

 targetSupportsSMP :: Stage -> Action Bool

 targetUseLibffiForAdjustors :: Stage -> Action Bool

 useLibdw :: Stage -> Action Bool

     -- * Helpers

     ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory,

     isHostStage,

     -- ** Target platform things

 isOsxTarget stage = anyTargetOs stage [OSDarwin]

 isArmTarget :: Stage -> Action Bool

 -- | Check whether the host OS setting matches one of the given strings.

 anyHostOs :: [OS] -> Action Bool

 -- | Check whether the target architecture setting matches one of the given

 -- strings.

 anyTargetArch :: Stage -> [Arch] -> Action Bool

 -- | Check whether the target OS setting matches one of the given strings.

 anyTargetOs :: Stage -> [OS] -> Action Bool

 -- | Check whether the target OS uses the ELF object format.

 isElfTarget :: Stage -> Action Bool

 -- | Check whether the target OS supports the @-rpath@ linker option when

 -- using dynamic linking.

 -- TODO: Windows supports lazy binding (but GHC doesn't currently support

 --       dynamic way on Windows anyways).

 targetSupportsRPaths :: Stage -> Action Bool

                                 (\t -> let os = archOS_OS (tgtArchOs t)

                                        in osElfTarget os || osMachOTarget os)

 -- ARM)?

 targetArmVersion :: Stage -> Action (Maybe ArmISA)

 targetArmVersion stage = runMaybeT $ do

     return isa

 -- | Canonicalised GHC version number, used for integer version comparisons. We

         let suffix = waySuffix (removeWayUnit Dynamic way)

         return (suffix ++ "-ghc" ++ version ++ extension)

 --

 -- produce a host executable with stage1 (which cross-compiles to stage2).

    ht <- getHostTarget

    tt <- getTargetTarget

    if targetPlatformTriple ht == targetPlatformTriple tt

      then return tt

      else return ht

 isHostStage :: Stage -> Bool

 isHostStage stage | stage <= Stage1 = True

 isHostStage _ = False

 -- | A 'Stage' is a cross-stage if the produced compiler is a cross-compiler.

 crossStage :: Stage -> Action Bool

 crossStage st = do

   return (targetPlatformTriple st_target /= targetPlatformTriple st_host)

 import Packages

 import Settings.Program (programContext)

 import Hadrian.Oracles.Path

 testConfigFile :: Action FilePath

 testConfigFile = buildRoot <&> (-/- "test/ghcconfig")

      bindir <- getBinaryDirectory testGhc

      compiler_path <- getCompilerPath testGhc

      cross <- getBooleanSetting TestCrossCompiling

      let cross_prefix = if cross then dropWhileEnd ((/=) '-') (takeFileName compiler_path) else ""

      -- get relative path for the given program in the given stage

      let make_absolute rel_path = do

            abs_path <- liftIO (makeAbsolute rel_path)

            fixAbsolutePathOnWindows abs_path

     -- get relative path for the given program in the given stage

 import Base

 import Context.Type

 import Oracles.Setting

 -- | These are all GHC packages we know about. Build rules will be generated for

 -- all of them. However, not all of these packages will be built. For example,

 programPath context@Context {..} = do

     name <- programName context

     path <- stageBinPath stage

 -- TODO: Move @timeout@ to the @util@ directory and build in a more standard

 -- location like other programs used only by the testsuite.

 timeoutPath :: FilePath

 -- TODO: Can we extract this information from Cabal files?

 -- | Some program packages should not be linked with Haskell main function.

                       else prefix

                 relPkgDb = makeRelativeNoSysLink libTopDir pkgDb

             go (generateSettings out True relPkgDb) out

   where

     file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out

     , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian

     , interpolateVar "TargetWordSize" $ getTarget wordSize

     , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised

     , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors

     , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base

     , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP Stage2

 generateConfigHs = do

     stage <- getStage

     let chooseSetting x y = case stage of { Stage0 {} -> x; _ -> y }

     -- Not right for stage3

     buildPlatform <- chooseSetting (queryBuild targetPlatformTriple) (queryHost targetPlatformTriple)

     hostPlatform <- queryTarget targetPlatformTriple

 import Context

 import Expression hiding (stage, way)

 import Oracles.ModuleFiles

 import Packages

 import Settings

 import Settings.Default

 import Utilities

 import Rules.Library

 import Rules.Register

 -- | TODO: Drop code duplication

 buildProgramRules :: [(Resource, Int)] -> Rules ()

   -- 'Rules', because it is an 'Action' depending on an oracle.

   sPackages <- filter isProgram <$> stagePackages stage

   tPackages <- testsuitePackages

   -- TODO: Shall we use Stage2 for testsuite packages instead?

   let allPackages = sPackages

                  ++ tPackages

   forM allPackages $ \pkg -> do

     ctx <- programContext stage pkg -- TODO: see todo on programContext.

     name <- programName ctx

 lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context

 lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs

 {-# OPTIONS_GHC -Wno-unused-top-binds #-}

 module Rules.Test (testRules) where

 import GHC.Toolchain.Program as Toolchain

 import Hadrian.Oracles.Path

 import Hadrian.Oracles.TextFile (getHostTarget, getTargetTarget)

 checkPprSourcePath = "utils/check-ppr/Main.hs"

 checkPprExtra :: [String]

 checkPprExtra = []

 checkExactSourcePath = "utils/check-exact/Main.hs"

 checkExactExtra :: [String]

 checkExactExtra = ["-iutils/check-exact"]

 countDepsSourcePath = "utils/count-deps/Main.hs"

 countDepsExtra :: [String]

 countDepsExtra = ["-iutils/count-deps"]

 dumpDeclsSourcePath = "utils/dump-decls/Main.hs"

 dumpDeclsExtra :: [String]

 dumpDeclsExtra = []

 noteLinterSourcePath = "linters/lint-notes/Main.hs"

 noteLinterExtra :: [String]

 noteLinterExtra = ["-ilinters/lint-notes"]

 codeLinterSourcePath = "linters/lint-codes/Main.hs"

 codeLinterExtra :: [String]

 codeLinterExtra = ["-ilinters/lint-codes"]

 whitespaceLinterSourcePath = "linters/lint-whitespace/Main.hs"

 whitespaceLinterExtra :: [String]

 whitespaceLinterExtra = ["-ilinters/lint-whitespace", "-ilinters/linters-common"]

 changelogDSourcePath = "utils/changelog-d/ChangelogD.hs"

 changelogDExtra :: [String]

 changelogDExtra = ["-iutils/changelog-d"]

 data CheckProgram =

         CheckProgram { cp_target :: String -- ^ Name for the hadrian target

                      , cp_src_path :: FilePath -- ^ Source to the Main.hs for the executable

                      , cp_extra_args :: [String] -- ^ Any extra arguments to use when compiling Main.hs

                      , cp_hadrian_pkg :: Package -- ^ How to build the executable when using in-tree compiler.

 checkPrograms :: [CheckProgram]

 checkPrograms =

     -- N.B. The lint:changelog build is replicated by lint_changelog in

     -- .gitlab/ci.sh. Keep its package dependencies in sync with this target.

     ]

 inTreeOutTree :: (Stage -> Action b) -> Action b -> Action b

     testsuiteDeps

     -- Rules for building check-ppr, check-exact and

     -- check-ppr-annotations with the compiler we are going to test

     -- (in-tree or out-of-tree).

             need [ sourcePath ]

             testGhc <- testCompiler <$> userSetting defaultTestArgs

                      | targetPlatformTriple ht /= targetPlatformTriple tt = targetPlatform ++ "-" ++ prog

                      | otherwise = prog

                 let dynPrograms = hasDynamic test_args

                     concatMap (\p -> ["-package", pkgName p]) depsPkgs ++

                     ["-o", top -/- path, top -/- sourcePath] ++

                     mextra ++

     top             <- topDirectory

     pythonPath      <- builderPath Python

     -- MP: TODO wrong, should use the ccPath and ccFlags from the bindist we are testing.

     ghcFlags        <- runTestGhcFlags stg

     let ghciFlags = ghcFlags ++ unwords

           [ "--interactive", "-v0", "-ignore-dot-ghci"

       , "TEST_HC_OPTS_INTERACTIVE" .= ghciFlags

       , "TEST_CC" .= ccPath

       , "TEST_CC_OPTS" .= ccFlags

       -- This lets us bypass the need to generate a config

       -- through Make, which happens in testsuite/mk/boilerplate.mk

       -- which is in turn included by all test 'Makefile's.

     stage <- getStage

     rtsPath <- expr $ rtsBuildPath stage

     mconcat [ cWarnings

             , arg "-Irts"

             , arg "-Irts/include"

             , arg $ "-I" ++ rtsPath </> "include"

 {-# LANGUAGE TypeApplications #-}

 module Settings.Builders.RunTest (runTestBuilderArgs

                                  , runTestGhcFlags

                                  , assertSameCompilerArgs

 -- | Extra flags to send to the Haskell compiler to run tests.

 runTestGhcFlags :: Stage -> Action String

 runTestGhcFlags stage = do

     let ifMinGhcVer ver opt = do v <- ghcCanonVersion

                                  if ver <= v then pure opt

       ways <- interpretInContext (vanillaContext ghcStage rts) getRtsWays

       return (dynamic `elem` ways, threaded `elem` ways)

     hasDynamic          <- (wayUnit Dynamic) . Context.Type.way <$> (programContext stg ghc)

     withInterpreter     <- ghcWithInterpreter ghcStage

     targetWithSMP       <- targetSupportsSMP ghcStage

     interpForceDyn      <- targetRTSLinkerOnlySupportsSharedLibs ghcStage

     profiled            <- ghcProfiled        <$> flavour <*> pure ghcStage

     os          <- queryHostTarget queryOS

     let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32", "riscv64", "loongarch64"]

     let withNativeCodeGen

           | unregisterised = False

           | arch `elem` codegen_arches = True

           | otherwise = False

     let have_llvm = allowHaveLLVM arch && all isJust [llc_cmd, llvm_as_cmd]

     top         <- topDirectory

     keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)

     accept <- expr (testAccept <$> userSetting defaultTestArgs)

     (acceptPlatform, acceptOS) <- expr . liftIO $

         (,) <$> (maybe False (=="YES") <$> lookupEnv "PLATFORM")

             , arg "-e", arg $ "config.accept=" ++ show accept

             , arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform

             , arg "-e", arg $ "config.accept_os=" ++ show acceptOS

             , arg "-e", arg $ "config.compiler_debugged=" ++ show debugAssertions

             , arg "-e", arg $ "config.debug_rts=" ++ show debugged

     path           <- getBuildPath

     top            <- expr topDirectory

     useSystemFfi   <- succStaged (buildFlag UseSystemFfi)

     libnumaIncludeDir <- staged (buildSetting LibnumaIncludeDir)

     libnumaLibraryDir <- staged (buildSetting LibnumaLibDir)

     libzstdIncludeDir <- staged (buildSetting LibZstdIncludeDir)

           , buildFlag UseLibnuma stage        `cabalFlag` "libnuma"

           , buildFlag UseLibzstd stage        `cabalFlag` "libzstd"

           , buildFlag StaticLibzstd stage     `cabalFlag` "static-libzstd"

           , ghcUnreg                          `cabalFlag` "unregisterised"

           , ghcEnableTNC                      `cabalFlag` "tables-next-to-code"

           ]