- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/mangoiv/ci-stages] fixup! ci: build and test stage
by Magnus (＠MangoIV) 27 Aug '26

27 Aug '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 8ff9044f by mangoiv at 2026-08-27T13:57:57+02:00 fixup! ci: build and test stage - - - - - 17 changed files: - hadrian/hie-bios.bat - hadrian/src/Base.hs - hadrian/src/Builder.hs - hadrian/src/Context.hs - hadrian/src/Flavour.hs - hadrian/src/Hadrian/Haskell/Hash.hs - hadrian/src/Hadrian/Package.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Oracles/TestSettings.hs - hadrian/src/Packages.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Program.hs - hadrian/src/Rules/Test.hs - hadrian/src/Settings/Builders/DeriveConstants.hs - hadrian/src/Settings/Builders/RunTest.hs - hadrian/src/Settings/Packages.hs Changes: ===================================== hadrian/hie-bios.bat ===================================== ===================================== hadrian/src/Base.hs ===================================== @@ -5,6 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiWayIf #-} module Base ( -- * General utilities @@ -22,6 +23,7 @@ module Base ( module Development.Shake.Util, Vec(..), (&%>), + exe, -- * Basic data types module Hadrian.Package, @@ -57,7 +59,7 @@ import Development.Shake hiding (unit, (&%>), (*>), Normal) #endif import qualified Development.Shake as Shake import Development.Shake.Classes -import Development.Shake.FilePath +import Development.Shake.FilePath hiding (exe) import Development.Shake.Util import Hadrian.Oracles.DirectoryContents import Hadrian.Utilities @@ -67,6 +69,13 @@ import GHC.Stack ( HasCallStack ) import Stage import Way +import GHC.Platform.ArchOS (ArchOS(..), Arch (..), OS (..)) + +exe :: ArchOS -> FilePath +exe arch + | ArchWasm32 <- archOS_arch arch = "wasm" + | OSMinGW32 <- archOS_OS arch = "exe" + | otherwise = "" -- | Hadrian lives in the 'hadrianPath' directory of the GHC tree. hadrianPath :: FilePath ===================================== hadrian/src/Builder.hs ===================================== @@ -15,7 +15,6 @@ import Control.Exception.Extra (Partial) import qualified Data.ByteString.Lazy.Char8 as BSL import Development.Shake.Classes import Development.Shake.Command -import Development.Shake.FilePath import GHC.Generics import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..)) import qualified Hadrian.Builder as H @@ -458,7 +457,7 @@ systemBuilderPath builder = case builder of -- Get program from a certain stage's target configuration fromStageTC stage keyname key = do - path <- prgPath . key <$> targetStage stage + path <- prgPath . key <$> perStageTarget stage validate keyname path validate keyname path = do @@ -479,7 +478,7 @@ systemBuilderPath builder = case builder of case (windowsHost, hasExtension fullPath) of (False, _ ) -> return path (True , True ) -> fixAbsolutePathOnWindows fullPath - (True , False) -> fixAbsolutePathOnWindows fullPath <&> (<.> exe) + (True , False) -> fixAbsolutePathOnWindows fullPath <&> (<.> exe (tgtArchOs target)) -- Without this function, on Windows we can observe a bad builder path -- for 'autoreconf'. If the relevant system.config field is set to ===================================== hadrian/src/Context.hs ===================================== @@ -51,7 +51,7 @@ getWay = way <$> getContext -- | Get the 'Target' configuration of the current stage getStagedTarget :: Expr Context b Target -getStagedTarget = expr . targetStage =<< getStage +getStagedTarget = expr . perStageTarget =<< getStage -- | Path to the directory containing the final artifact in a given 'Context'. libPath :: Context -> Action FilePath ===================================== hadrian/src/Flavour.hs ===================================== @@ -170,7 +170,7 @@ werror = addArgs $ do -- TODO: get rid of EFF_ altogether (#14647) and make sure -- unregisterised backend emits clean C without needing -- these hacks. - , queryTargetTarget stage tgtUnregisterised ? arg "-optc-Wno-error" + , queryPerStageTargetSpec stage tgtUnregisterised ? arg "-optc-Wno-error" ] -- N.B. We currently don't build the boot libraries' C sources with -Werror -- as this tends to be a portability nightmare. ===================================== hadrian/src/Hadrian/Haskell/Hash.hs ===================================== @@ -125,7 +125,7 @@ pkgHashOracle = void $ addOracleCache $ \(PkgHashKey (stag, pkg)) -> do flav <- flavour let flavourArgs = extraArgs flav - targetOs <- queryTargetTarget stag queryOS + targetOs <- queryPerStageTargetSpec stag queryOS projectVersion <- setting ProjectVersion let pkgHashCompilerId = "ghc-" ++ projectVersion pkgHashPlatform = targetOs ===================================== hadrian/src/Hadrian/Package.hs ===================================== @@ -23,7 +23,7 @@ module Hadrian.Package ( ) where import Development.Shake.Classes -import Development.Shake.FilePath +import Development.Shake.FilePath ((<.>)) import GHC.Generics import Hadrian.Utilities ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -77,13 +77,13 @@ getFlag = expr . flag targetRTSLinkerOnlySupportsSharedLibs :: Stage -> Action Bool targetRTSLinkerOnlySupportsSharedLibs s = - queryTargetTarget s Toolchain.tgtRTSLinkerOnlySupportsSharedLibs + queryPerStageTargetSpec s Toolchain.tgtRTSLinkerOnlySupportsSharedLibs arSupportsDashL :: Stage -> Action Bool -arSupportsDashL stage = Toolchain.arSupportsDashL . tgtAr <$> targetStage stage +arSupportsDashL stage = Toolchain.arSupportsDashL . tgtAr <$> perStageTarget stage arSupportsAtFile :: Stage -> Action Bool -arSupportsAtFile stage = Toolchain.arSupportsAtFile . tgtAr <$> targetStage stage +arSupportsAtFile stage = Toolchain.arSupportsAtFile . tgtAr <$> perStageTarget stage targetSupportsSharedLibs :: Stage -> Action Bool targetSupportsSharedLibs stage = do @@ -101,10 +101,10 @@ targetSupportsThreadedRts stage = do -- | Does the target support the -N RTS flag? targetSupportsSMP :: Stage -> Action Bool -targetSupportsSMP stage = queryTargetTarget stage Toolchain.tgtSupportsSMP +targetSupportsSMP stage = queryPerStageTargetSpec stage Toolchain.tgtSupportsSMP targetUseLibffiForAdjustors :: Stage -> Action Bool -targetUseLibffiForAdjustors stage = queryTargetTarget stage tgtUseLibffiForAdjustors +targetUseLibffiForAdjustors stage = queryPerStageTargetSpec stage tgtUseLibffiForAdjustors useLibdw :: Stage -> Action Bool -useLibdw stage = queryTargetTarget stage (isJust . tgtRTSWithLibdw) +useLibdw stage = queryPerStageTargetSpec stage (isJust . tgtRTSWithLibdw) ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -6,7 +6,7 @@ module Oracles.Setting ( -- * Helpers ghcCanonVersion, cmdLineLengthLimit, targetSupportsRPaths, topDirectory, - libsuf, ghcVersionStage, bashPath, targetStage, crossStage, queryTarget, queryTargetTarget, + libsuf, ghcVersionStage, bashPath, perStageTarget, crossStage, queryTarget, queryPerStageTargetSpec, isHostStage, -- ** Target platform things @@ -153,7 +153,7 @@ isOsxTarget :: Stage -> Action Bool isOsxTarget stage = anyTargetOs stage [OSDarwin] isArmTarget :: Stage -> Action Bool -isArmTarget stage = queryTargetTarget stage (isARM . archOS_arch . tgtArchOs) +isArmTarget stage = queryPerStageTargetSpec stage (isARM . archOS_arch . tgtArchOs) -- | Check whether the host OS setting matches one of the given strings. anyHostOs :: [OS] -> Action Bool @@ -162,15 +162,15 @@ anyHostOs oss = (`elem` oss) <$> queryHostTarget (archOS_OS . tgtArchOs) -- | Check whether the target architecture setting matches one of the given -- strings. anyTargetArch :: Stage -> [Arch] -> Action Bool -anyTargetArch stage archs = (`elem` archs) <$> queryTargetTarget stage (archOS_arch . tgtArchOs) +anyTargetArch stage archs = (`elem` archs) <$> queryPerStageTargetSpec stage (archOS_arch . tgtArchOs) -- | Check whether the target OS setting matches one of the given strings. anyTargetOs :: Stage -> [OS] -> Action Bool -anyTargetOs stage oss = (`elem` oss) <$> queryTargetTarget stage (archOS_OS . tgtArchOs) +anyTargetOs stage oss = (`elem` oss) <$> queryPerStageTargetSpec stage (archOS_OS . tgtArchOs) -- | Check whether the target OS uses the ELF object format. isElfTarget :: Stage -> Action Bool -isElfTarget stage = queryTargetTarget stage (osElfTarget . archOS_OS . tgtArchOs) +isElfTarget stage = queryPerStageTargetSpec stage (osElfTarget . archOS_OS . tgtArchOs) -- | Check whether the target OS supports the @-rpath@ linker option when -- using dynamic linking. @@ -180,7 +180,7 @@ isElfTarget stage = queryTargetTarget stage (osElfTarget . archOS_OS . tgtArchOs -- TODO: Windows supports lazy binding (but GHC doesn't currently support -- dynamic way on Windows anyways). targetSupportsRPaths :: Stage -> Action Bool -targetSupportsRPaths stage = queryTargetTarget stage +targetSupportsRPaths stage = queryPerStageTargetSpec stage (\t -> let os = archOS_OS (tgtArchOs t) in osElfTarget os || osMachOTarget os) @@ -188,7 +188,7 @@ targetSupportsRPaths stage = queryTargetTarget stage -- ARM)? targetArmVersion :: Stage -> Action (Maybe ArmISA) targetArmVersion stage = runMaybeT $ do - ArchARM isa _ _ <- lift $ queryTargetTarget stage (archOS_arch . tgtArchOs) + ArchARM isa _ _ <- lift $ queryPerStageTargetSpec stage (archOS_arch . tgtArchOs) return isa -- | Canonicalised GHC version number, used for integer version comparisons. We @@ -231,33 +231,34 @@ libsuf st way let suffix = waySuffix (removeWayUnit Dynamic way) return (suffix ++ "-ghc" ++ version ++ extension) --- | Build libraries for this `Stage` targetting this `Target` +-- | Determine the 'Target' that this 'Stage' is supposed to build libraries for. -- --- For example, we want to build RTS with stage1 for the host target as we +-- For example, we want to build RTS with stage1 for the host as we -- produce a host executable with stage1 (which cross-compiles to stage2). -targetStage :: Stage -> Action Target -targetStage Stage0 {} = getHostTarget -targetStage stage | isHostStage stage = do +perStageTarget :: Stage -> Action Target +perStageTarget Stage0 {} = getHostTarget +perStageTarget stage | isHostStage stage = do ht <- getHostTarget tt <- getTargetTarget if targetPlatformTriple ht == targetPlatformTriple tt then return tt else return ht -targetStage _ = getTargetTarget +perStageTarget _ = getTargetTarget isHostStage :: Stage -> Bool isHostStage stage | stage <= Stage1 = True isHostStage _ = False -queryTarget :: Stage -> (Target -> a) -> (Expr c b a) -queryTarget s f = expr (f <$> targetStage s) +queryTarget :: Stage -> (Target -> a) -> Expr c b a +queryTarget s f = expr (f <$> perStageTarget s) -queryTargetTarget :: Stage -> (Target -> a) -> Action a -queryTargetTarget s f = f <$> targetStage s +-- | get the conentents of the .target file for the specified stage +queryPerStageTargetSpec :: Stage -> (Target -> a) -> Action a +queryPerStageTargetSpec s f = f <$> perStageTarget s -- | A 'Stage' is a cross-stage if the produced compiler is a cross-compiler. crossStage :: Stage -> Action Bool crossStage st = do - st_target <- targetStage (succStage st) - st_host <- targetStage st + st_target <- perStageTarget (succStage st) + st_host <- perStageTarget st return (targetPlatformTriple st_target /= targetPlatformTriple st_host) ===================================== hadrian/src/Oracles/TestSettings.hs ===================================== @@ -14,6 +14,7 @@ import Oracles.Setting (topDirectory, setting, ProjectSetting(..), crossStage) import Packages import Settings.Program (programContext) import Hadrian.Oracles.Path +import GHC.Toolchain (Target(tgtArchOs)) testConfigFile :: Action FilePath testConfigFile = buildRoot <&> (-/- "test/ghcconfig") @@ -154,10 +155,11 @@ getTestExePath testGhc pkg = do bindir <- getBinaryDirectory testGhc compiler_path <- getCompilerPath testGhc cross <- getBooleanSetting TestCrossCompiling + tgt <- getTargetTarget -- FIXME: is this right -- ask rodrigo about the targettarget and query/get versions of this function 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 - make_absolute (bindir </> (cross_prefix ++ programBasename pkg) <.> exe) + make_absolute (bindir </> (cross_prefix ++ programBasename pkg) <.> exe (tgtArchOs tgt)) -- get relative path for the given program in the given stage ===================================== hadrian/src/Packages.hs ===================================== @@ -24,6 +24,8 @@ import Hadrian.Utilities import Base import Context.Type import Oracles.Setting +import GHC.Toolchain (tgtArchOs) +import qualified Development.Shake.FilePath as Shake -- | 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, @@ -196,12 +198,13 @@ programPath :: Context -> Action FilePath programPath context@Context {..} = do name <- programName context path <- stageBinPath stage - return $ path -/- name <.> exe + arch <- queryPerStageTargetSpec stage tgtArchOs + return $ path -/- name <.> exe arch -- TODO: Move @timeout@ to the @util@ directory and build in a more standard -- location like other programs used only by the testsuite. timeoutPath :: FilePath -timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe +timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> Shake.exe -- TODO: Can we extract this information from Cabal files? -- | Some program packages should not be linked with Haskell main function. ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -276,7 +276,7 @@ generateRules = do else prefix relPkgDb = makeRelativeNoSysLink libTopDir pkgDb go (generateSettings out True relPkgDb) out - (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr (targetStage (succStage stage))) out + (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr (perStageTarget (succStage stage))) out where file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out @@ -447,7 +447,7 @@ bindistRules = do , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian , interpolateVar "TargetWordSize" $ getTarget wordSize , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised - , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ staged (fmap (isJust . tgtRTSWithLibdw) . targetStage) + , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ staged (fmap (isJust . tgtRTSWithLibdw) . perStageTarget) , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP Stage2 @@ -536,7 +536,7 @@ generateConfigHs :: Expr String generateConfigHs = do stage <- getStage let chooseSetting x y = case stage of { Stage0 {} -> x; _ -> y } - let queryTarget f = f <$> expr (targetStage stage) + let queryTarget f = f <$> expr (perStageTarget stage) -- Not right for stage3 buildPlatform <- chooseSetting (queryBuild targetPlatformTriple) (queryHost targetPlatformTriple) hostPlatform <- queryTarget targetPlatformTriple ===================================== hadrian/src/Rules/Program.hs ===================================== @@ -9,7 +9,7 @@ import Base import Context import Expression hiding (stage, way) import Oracles.ModuleFiles -import Oracles.Setting (topDirectory) +import Oracles.Setting (topDirectory, perStageTarget) import Packages import Settings import Settings.Default @@ -18,6 +18,7 @@ import Target import Utilities import Rules.Library import Rules.Register +import GHC.Toolchain (Target(tgtArchOs)) -- | TODO: Drop code duplication buildProgramRules :: [(Resource, Int)] -> Rules () @@ -49,13 +50,14 @@ getProgramContexts stage = do -- 'Rules', because it is an 'Action' depending on an oracle. sPackages <- filter isProgram <$> stagePackages stage tPackages <- testsuitePackages + tgt <- perStageTarget stage -- 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 - return (name <.> exe, ctx) + return (name <.> exe (tgtArchOs tgt), ctx) lookupProgramContext :: FilePath -> [(FilePath, Context)] -> Maybe Context lookupProgramContext wholePath progs = lookup (takeFileName wholePath) progs ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Rules.Test (testRules) where @@ -22,58 +23,70 @@ import GHC.Toolchain as Toolchain import GHC.Toolchain.Program as Toolchain import Hadrian.Oracles.Path import Hadrian.Oracles.TextFile (getHostTarget, getTargetTarget) +import GHC.Platform.ArchOS (ArchOS (..), Arch (..), OS (..)) -checkPprProgPath, checkPprSourcePath :: FilePath -checkPprProgPath = "test/bin/check-ppr" <.> exe +checkPprProgPath :: ArchOS -> FilePath +checkPprProgPath archos = "test/bin/check-ppr" <.> exe archos +checkPprSourcePath :: FilePath checkPprSourcePath = "utils/check-ppr/Main.hs" checkPprExtra :: [String] checkPprExtra = [] -checkExactProgPath, checkExactSourcePath :: FilePath -checkExactProgPath = "test/bin/check-exact" <.> exe +checkExactProgPath :: ArchOS -> FilePath +checkExactProgPath archos = "test/bin/check-exact" <.> exe archos +checkExactSourcePath :: FilePath checkExactSourcePath = "utils/check-exact/Main.hs" checkExactExtra :: [String] checkExactExtra = ["-iutils/check-exact"] -countDepsProgPath, countDepsSourcePath :: FilePath -countDepsProgPath = "test/bin/count-deps" <.> exe +countDepsProgPath :: ArchOS -> FilePath +countDepsProgPath archos = "test/bin/count-deps" <.> exe archos +countDepsSourcePath :: FilePath countDepsSourcePath = "utils/count-deps/Main.hs" countDepsExtra :: [String] countDepsExtra = ["-iutils/count-deps"] -dumpDeclsProgPath, dumpDeclsSourcePath :: FilePath -dumpDeclsProgPath = "test/bin/dump-decls" <.> exe +dumpDeclsProgPath :: ArchOS -> FilePath +dumpDeclsProgPath archos = "test/bin/dump-decls" <.> exe archos +dumpDeclsSourcePath :: FilePath dumpDeclsSourcePath = "utils/dump-decls/Main.hs" dumpDeclsExtra :: [String] dumpDeclsExtra = [] -noteLinterProgPath, noteLinterSourcePath :: FilePath -noteLinterProgPath = "test/bin/lint-notes" <.> exe +noteLinterProgPath :: ArchOS -> FilePath +noteLinterProgPath archos = "test/bin/lint-notes" <.> exe archos +noteLinterSourcePath :: FilePath noteLinterSourcePath = "linters/lint-notes/Main.hs" noteLinterExtra :: [String] noteLinterExtra = ["-ilinters/lint-notes"] -codeLinterProgPath, codeLinterSourcePath :: FilePath -codeLinterProgPath = "test/bin/lint-codes" <.> exe +codeLinterProgPath :: ArchOS -> FilePath +codeLinterProgPath archos = "test/bin/lint-codes" <.> exe archos +codeLinterSourcePath :: FilePath codeLinterSourcePath = "linters/lint-codes/Main.hs" codeLinterExtra :: [String] codeLinterExtra = ["-ilinters/lint-codes"] -whitespaceLinterProgPath, whitespaceLinterSourcePath :: FilePath -whitespaceLinterProgPath = "test/bin/lint-whitespace" <.> exe +whitespaceLinterProgPath :: ArchOS -> FilePath +whitespaceLinterProgPath archos = "test/bin/lint-whitespace" <.> exe archos +whitespaceLinterSourcePath :: FilePath whitespaceLinterSourcePath = "linters/lint-whitespace/Main.hs" whitespaceLinterExtra :: [String] whitespaceLinterExtra = ["-ilinters/lint-whitespace", "-ilinters/linters-common"] -changelogDProgPath, changelogDSourcePath :: FilePath -changelogDProgPath = "test/bin/changelog-d" <.> exe +changelogDProgPath :: ArchOS -> FilePath +changelogDProgPath archos = "test/bin/changelog-d" <.> exe archos +changelogDSourcePath :: FilePath changelogDSourcePath = "utils/changelog-d/ChangelogD.hs" changelogDExtra :: [String] changelogDExtra = ["-iutils/changelog-d"] data CheckProgram = CheckProgram { cp_target :: String -- ^ Name for the hadrian target - , cp_exe_path :: FilePath -- ^ Path to resulting executable + , cp_exe_path :: ArchOS -> FilePattern + -- ^ Path to resulting executable. + -- This depends on the taret the program is built for, + -- not the host that hadrian is built on , 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. @@ -83,16 +96,16 @@ data CheckProgram = checkPrograms :: [CheckProgram] checkPrograms = - [ CheckProgram "test:check-ppr" checkPprProgPath checkPprSourcePath checkPprExtra checkPpr id id - , CheckProgram "test:check-exact" checkExactProgPath checkExactSourcePath checkExactExtra checkExact id id - , CheckProgram "test:count-deps" countDepsProgPath countDepsSourcePath countDepsExtra countDeps id id - , CheckProgram "test:dump-decls" dumpDeclsProgPath dumpDeclsSourcePath dumpDeclsExtra dumpDecls id id - , CheckProgram "lint:notes" noteLinterProgPath noteLinterSourcePath noteLinterExtra lintNotes (const stage0Boot) id - , CheckProgram "lint:codes" codeLinterProgPath codeLinterSourcePath codeLinterExtra lintCodes id id - , CheckProgram "lint:whitespace" whitespaceLinterProgPath whitespaceLinterSourcePath whitespaceLinterExtra lintWhitespace (const stage0Boot) (filter (/= lintersCommon)) + [ CheckProgram { cp_target = "test:check-ppr", cp_exe_path = checkPprProgPath, cp_src_path = checkPprSourcePath, cp_extra_args = checkPprExtra, cp_hadrian_pkg = checkPpr, cp_modify_stage = id, cp_modify_deps = id } + , CheckProgram { cp_target = "test:check-exact", cp_exe_path = checkExactProgPath, cp_src_path = checkExactSourcePath, cp_extra_args = checkExactExtra, cp_hadrian_pkg = checkExact, cp_modify_stage = id, cp_modify_deps = id } + , CheckProgram { cp_target = "test:count-deps", cp_exe_path = countDepsProgPath, cp_src_path = countDepsSourcePath, cp_extra_args = countDepsExtra, cp_hadrian_pkg = countDeps, cp_modify_stage = id, cp_modify_deps = id } + , CheckProgram { cp_target = "test:dump-decls", cp_exe_path = dumpDeclsProgPath, cp_src_path = dumpDeclsSourcePath, cp_extra_args = dumpDeclsExtra, cp_hadrian_pkg = dumpDecls, cp_modify_stage = id, cp_modify_deps = id } + , CheckProgram { cp_target = "lint:notes", cp_exe_path = noteLinterProgPath, cp_src_path = noteLinterSourcePath, cp_extra_args = noteLinterExtra, cp_hadrian_pkg = lintNotes, cp_modify_stage = (const stage0Boot), cp_modify_deps = id } + , CheckProgram { cp_target = "lint:codes", cp_exe_path = codeLinterProgPath, cp_src_path = codeLinterSourcePath, cp_extra_args = codeLinterExtra, cp_hadrian_pkg = lintCodes, cp_modify_stage = id, cp_modify_deps = id } + , CheckProgram { cp_target = "lint:whitespace", cp_exe_path = whitespaceLinterProgPath, cp_src_path = whitespaceLinterSourcePath, cp_extra_args = whitespaceLinterExtra, cp_hadrian_pkg = lintWhitespace, cp_modify_stage = (const stage0Boot), cp_modify_deps = (filter (/= lintersCommon)) } -- N.B. The lint:changelog build is replicated by lint_changelog in -- .gitlab/ci.sh. Keep its package dependencies in sync with this target. - , CheckProgram "lint:changelog" changelogDProgPath changelogDSourcePath changelogDExtra changelogD (const stage0Boot) id + , CheckProgram { cp_target = "lint:changelog", cp_exe_path = changelogDProgPath, cp_src_path = changelogDSourcePath, cp_extra_args = changelogDExtra, cp_hadrian_pkg = changelogD, cp_modify_stage = (const stage0Boot), cp_modify_deps = id } ] inTreeOutTree :: (Stage -> Action b) -> Action b -> Action b @@ -136,12 +149,23 @@ testRules = do testsuiteDeps + -- the test targets will all be compiled by the test comppiler which is going + -- to produce artifacts for its target + -- 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). - forM_ checkPrograms $ \(CheckProgram name progPath sourcePath mextra progPkg mod_stage mod_pkgs) -> do - name ~> need [root -/- progPath] - root -/- progPath %> \path -> do + forM_ checkPrograms $ \(CheckProgram name progPathForArch sourcePath mextra progPkg mod_stage mod_pkgs) -> do + name ~> do + tt <- getTargetTarget + need [root -/- progPathForArch (tgtArchOs tt)] + + -- HACK: we don't havea program path here and just a pattern + -- because we can't query the target before declaring the rule. + -- we specify target arch linux (no extension), then append a pattern + -- for any extension + let filePat = progPathForArch ArchOS { archOS_arch = ArchUnknown, archOS_OS = OSLinux } <> "*" + root -/- filePat %> \path -> do need [ sourcePath ] testGhc <- testCompiler <$> userSetting defaultTestArgs @@ -167,7 +191,7 @@ testRules = do | targetPlatformTriple ht /= targetPlatformTriple tt = targetPlatform ++ "-" ++ prog | otherwise = prog let dynPrograms = hasDynamic test_args - cmd [bindir </> mkGhcProg "ghc" <.> exe] $ -- FIXME: needs proper prefix! + cmd [bindir </> mkGhcProg "ghc" <.> exe (tgtArchOs ht)] $ concatMap (\p -> ["-package", pkgName p]) depsPkgs ++ ["-o", top -/- path, top -/- sourcePath] ++ mextra ++ @@ -243,8 +267,12 @@ testEnv stg = do top <- topDirectory pythonPath <- builderPath Python -- MP: TODO wrong, should use the ccPath and ccFlags from the bindist we are testing. - ccPath <- queryTargetTarget stg (Toolchain.prgPath . Toolchain.ccProgram . Toolchain.tgtCCompiler) - ccFlags <- queryTargetTarget stg (unwords . Toolchain.prgFlags . Toolchain.ccProgram . Toolchain.tgtCCompiler) + tgt <- queryPerStageTargetSpec stg id + let ccPath = tgt.tgtCCompiler.ccProgram.prgPath + let ccFlags = unwords tgt.tgtCCompiler.ccProgram.prgFlags + let archos = tgt.tgtArchOs + let mkProgPath k = top -/- root -/- k archos + ghcFlags <- runTestGhcFlags stg let ghciFlags = ghcFlags ++ unwords [ "--interactive", "-v0", "-ignore-dot-ghci" @@ -262,14 +290,14 @@ testEnv stg = do , "TEST_HC_OPTS_INTERACTIVE" .= ghciFlags , "TEST_CC" .= ccPath , "TEST_CC_OPTS" .= ccFlags - , "CHECK_PPR" .= (top -/- root -/- checkPprProgPath) - , "CHECK_EXACT" .= (top -/- root -/- checkExactProgPath) - , "DUMP_DECLS" .= (top -/- root -/- dumpDeclsProgPath) - , "COUNT_DEPS" .= (top -/- root -/- countDepsProgPath) - , "LINT_NOTES" .= (top -/- root -/- noteLinterProgPath) - , "LINT_CODES" .= (top -/- root -/- codeLinterProgPath) - , "LINT_WHITESPACE" .= (top -/- root -/- whitespaceLinterProgPath) - , "CHANGELOG_D" .= (top -/- root -/- changelogDProgPath) + , "CHECK_PPR" .= mkProgPath checkPprProgPath + , "CHECK_EXACT" .= mkProgPath checkExactProgPath + , "DUMP_DECLS" .= mkProgPath dumpDeclsProgPath + , "COUNT_DEPS" .= mkProgPath countDepsProgPath + , "LINT_NOTES" .= mkProgPath noteLinterProgPath + , "LINT_CODES" .= mkProgPath codeLinterProgPath + , "LINTstageWHITESPACE" .= mkProgPath whitespaceLinterProgPath + , "CHANGELOG_D" .= mkProgPath changelogDProgPath -- 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. ===================================== hadrian/src/Settings/Builders/DeriveConstants.hs ===================================== @@ -42,8 +42,8 @@ includeCcArgs = do stage <- getStage rtsPath <- expr $ rtsBuildPath stage mconcat [ cWarnings - , prgFlags . ccProgram . tgtCCompiler <$> expr (targetStage stage) - , queryTargetTarget stage tgtUnregisterised ? arg "-DUSE_MINIINTERPRETER" + , prgFlags . ccProgram . tgtCCompiler <$> expr (perStageTarget stage) + , queryPerStageTargetSpec stage tgtUnregisterised ? arg "-DUSE_MINIINTERPRETER" , arg "-Irts" , arg "-Irts/include" , arg $ "-I" ++ rtsPath </> "include" ===================================== hadrian/src/Settings/Builders/RunTest.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NamedFieldPuns #-} module Settings.Builders.RunTest (runTestBuilderArgs , runTestGhcFlags , assertSameCompilerArgs @@ -27,7 +28,7 @@ import GHC.Toolchain.Target -- | Extra flags to send to the Haskell compiler to run tests. runTestGhcFlags :: Stage -> Action String runTestGhcFlags stage = do - unregisterised <- queryTargetTarget stage tgtUnregisterised + unregisterised <- queryPerStageTargetSpec stage tgtUnregisterised let ifMinGhcVer ver opt = do v <- ghcCanonVersion if ver <= v then pure opt @@ -112,10 +113,10 @@ inTreeCompilerArgs stg = do ways <- interpretInContext (vanillaContext ghcStage rts) getRtsWays return (dynamic `elem` ways, threaded `elem` ways) hasDynamic <- (wayUnit Dynamic) . Context.Type.way <$> (programContext stg ghc) - leadingUnderscore <- queryTargetTarget ghcStage tgtSymbolsHaveLeadingUnderscore + leadingUnderscore <- queryPerStageTargetSpec ghcStage tgtSymbolsHaveLeadingUnderscore withInterpreter <- ghcWithInterpreter ghcStage - unregisterised <- queryTargetTarget ghcStage tgtUnregisterised - tables_next_to_code <- queryTargetTarget ghcStage tgtTablesNextToCode + unregisterised <- queryPerStageTargetSpec ghcStage tgtUnregisterised + tables_next_to_code <- queryPerStageTargetSpec ghcStage tgtTablesNextToCode targetWithSMP <- targetSupportsSMP ghcStage interpForceDyn <- targetRTSLinkerOnlySupportsSharedLibs ghcStage @@ -124,17 +125,17 @@ inTreeCompilerArgs stg = do profiled <- ghcProfiled <$> flavour <*> pure ghcStage os <- queryHostTarget queryOS - arch <- queryTargetTarget ghcStage queryArch + arch <- queryPerStageTargetSpec ghcStage queryArch let codegen_arches = ["x86_64", "i386", "powerpc", "powerpc64", "powerpc64le", "aarch64", "wasm32", "riscv64", "loongarch64"] let withNativeCodeGen | unregisterised = False | arch `elem` codegen_arches = True | otherwise = False - platform <- queryTargetTarget ghcStage targetPlatformTriple - wordsize <- show @Int . (*8) <$> queryTargetTarget ghcStage (wordSize2Bytes . tgtWordSize) + platform <- queryPerStageTargetSpec ghcStage targetPlatformTriple + wordsize <- show @Int . (*8) <$> queryPerStageTargetSpec ghcStage (wordSize2Bytes . tgtWordSize) - llc_cmd <- queryTargetTarget ghcStage tgtLlc - llvm_as_cmd <- queryTargetTarget ghcStage tgtLlvmAs + llc_cmd <- queryPerStageTargetSpec ghcStage tgtLlc + llvm_as_cmd <- queryPerStageTargetSpec ghcStage tgtLlvmAs let have_llvm = allowHaveLLVM arch && all isJust [llc_cmd, llvm_as_cmd] top <- topDirectory @@ -231,6 +232,8 @@ runTestBuilderArgs = builder Testsuite ? do keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs) + tgtArchOs <- expr $ queryPerStageTargetSpec stage tgtArchOs + accept <- expr (testAccept <$> userSetting defaultTestArgs) (acceptPlatform, acceptOS) <- expr . liftIO $ (,) <$> (maybe False (=="YES") <$> lookupEnv "PLATFORM") @@ -266,7 +269,7 @@ runTestBuilderArgs = builder Testsuite ? do , 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.exeext=" ++ quote (if null exe then "" else "."<>exe) + , arg "-e", arg $ "config.exeext=" ++ quote ("" <.> exe tgtArchOs) , arg "-e", arg $ "config.compiler_debugged=" ++ show debugAssertions , arg "-e", arg $ "config.debug_rts=" ++ show debugged ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -295,8 +295,8 @@ rtsPackageArgs = package rts ? do path <- getBuildPath top <- expr topDirectory useSystemFfi <- succStaged (buildFlag UseSystemFfi) - libdwIncludeDir <- staged (\s -> queryTargetTarget s (Lib.includePath <=< tgtRTSWithLibdw)) - libdwLibraryDir <- staged (\s -> queryTargetTarget s (Lib.libraryPath <=< tgtRTSWithLibdw)) + libdwIncludeDir <- staged (\s -> queryPerStageTargetSpec s (Lib.includePath <=< tgtRTSWithLibdw)) + libdwLibraryDir <- staged (\s -> queryPerStageTargetSpec s (Lib.libraryPath <=< tgtRTSWithLibdw)) libnumaIncludeDir <- staged (buildSetting LibnumaIncludeDir) libnumaLibraryDir <- staged (buildSetting LibnumaLibDir) libzstdIncludeDir <- staged (buildSetting LibZstdIncludeDir) @@ -412,7 +412,7 @@ rtsPackageArgs = package rts ? do , buildFlag UseLibnuma stage `cabalFlag` "libnuma" , buildFlag UseLibzstd stage `cabalFlag` "libzstd" , buildFlag StaticLibzstd stage `cabalFlag` "static-libzstd" - , queryTargetTarget stage tgtSymbolsHaveLeadingUnderscore `cabalFlag` "leading-underscore" + , queryPerStageTargetSpec stage tgtSymbolsHaveLeadingUnderscore `cabalFlag` "leading-underscore" , ghcUnreg `cabalFlag` "unregisterised" , ghcEnableTNC `cabalFlag` "tables-next-to-code" ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ff9044fd3fbdc621eceb7dfa7153b2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8ff9044fd3fbdc621eceb7dfa7153b2… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/stm-exception-improvements] 11 commits: cmm dumps: Add machop width info with -dppr-debug for infix ops.
by Wolfgang Jeltsch (＠jeltsch) 27 Aug '26

27 Aug '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/stm-exception-improvements at Glasgow Haskell Compiler / GHC Commits: e9bbe8f9 by Andreas Klebinger at 2026-08-26T15:09:23-04:00 cmm dumps: Add machop width info with -dppr-debug for infix ops. - - - - - 86e3a9d8 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 CmmLint: Check for unsupported MachOp widths machOpArgReps now maps MachOp + Width to a list of supported argument widths or Nothing if the given operation is not supported at the given width. This allows us to check for nonsensical combinations like FloatToInt at Word16. Similarly we now check that every address is actually wordwidth. - - - - - 13781cca by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: The big subword truncation fix. A set of slightly related fixes to arm subword handling: Bitmask immediates: Don't produce overflowing assembly literals. There is still another bug here that causes us to miss some valid literals but we will fix that later. Improve subword truncation handling: We now use a small set of helpers to truncate `Register` values rather than truncating immediate `Reg` values which greatly simplifies the code structure. This fixes a great many bugs to do with sign/zero extending subwords or the lack thereof. We now establish the invariant that subword values are zero-extended at every site at which they come into "scope" of the ncg, and rely on the invariant throughout rather than pessimistically inserting redundant extensions in a hodgepodge manner at the use sites of these values. This fixes at least the bugs described in issues #27533, #27430 #27537, #27538, #27539, and #27550. But likely more bugs yet not found. Subword ffi results: Apply truncations when calling functions returning subword values. genCondJump: Don't sign extend signed values in the input register as it might map to a local variable, corrupting the value stored within. Fix subword store/load instructions.: We used to read those at 32bit width even for smaller values possibly resulting in invalid memory access. Now we construct the suffix for subword variants based on the instruction format for these. - - - - - d8fa5d7c by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: Fix MO_V_Broadcast for non-literals. We now use OpReg instead of OpScalarAsVec as required since we broadcast a gp register. Also adds a test. Fixes #27565. - - - - - 94822c95 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 Add some test cases covering bugs in the arm ncg. * Test for #27430 (subword ffi results) * #27537 - subword conversions * #27538 - subwords used in conditional * #27533 - single byte read - - - - - dd1ba88a by Andreas Klebinger at 2026-08-26T15:09:24-04:00 cmmLint: Lint against MO_FS_Truncate subword use. - - - - - fd22f71e by Zubin Duggal at 2026-08-26T15:10:20-04:00 ghc-internal: annotateSTM should use catchSTM# rather than catch# A catch# frame inside a transaction breaks retry and async exception delivery. Fixes #27657 - - - - - bb324171 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS - No behavior change in this commit (well, a small optimization here makes us do less work if the target TSO owned by the curr. capability) - Move all THREADED_RTS CPP needed into `updThreadFlag` - Merge MSG_SET_TSO_FLAGS and MSG_UNSET_TSO_FLAGS into MSG_UPD_TSO_FLAGS plus a `set` bool field in the MessageUpdTSOFlag struct Towards #27729 - - - - - ed99b7b7 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: Fix race condition in MSG_UPD_TSO_FLAGS execution The code for processing the MSG_UPD_TSO_FLAGS message was not taking into consideration that the TSO's owner might have moved in between that capability receiving the message (since it was its previous owner) and starting to process its inbox (a point at which it was no longer the owner) Added Note [TSO owner may change in between Msg being sent and received] to explain this race and the pattern used to fix this, where we just forward the message to the new owner. Fixes #27729 - - - - - cd653714 by Alan Zimmerman at 2026-08-26T15:11:49-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - d1d01fa5 by Wolfgang Jeltsch at 2026-08-27T13:17:59+03:00 Add `rethrowSTM` and improve STM-related documentation Adding `rethrowSTM` resolves #26758. The implementation of `rethrowSTM` is completely analogous to the one of `rethrowIO`. The following is established for the documentation of `throwSTM` and `catchSTM`: * Both operations are directly described as analogs of their `IO` counterparts. * There is no reference to `throw` in the documentation of `throwSTM`, because, although such a reference is great in the documentation of `throwIO`, it is somewhat out of place in the documentation of `throwSTM`. * Instead of repeating part of `throwIO`’s documentation, the documentation of `throwSTM` just recommends using `throwSTM` instead of `throw` and references the corresponding arguments in the documentation of `throwIO`. - - - - - 48 changed files: - + changelog.d/T27657 - + changelog.d/arm_ncg_fixes_T27430 - + changelog.d/rethrow-stm - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - libraries/base/src/GHC/Conc.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - rts/CloneStack.c - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr - − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/codeGen/should_run/T27430.hs - + testsuite/tests/codeGen/should_run/T27430.stdout - + testsuite/tests/codeGen/should_run/T27430_c.c - + testsuite/tests/codeGen/should_run/T27533.hs - + testsuite/tests/codeGen/should_run/T27533.stdout - + testsuite/tests/codeGen/should_run/T27533_cmm.cmm - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/concurrent/should_run/T27657a.hs - + testsuite/tests/concurrent/should_run/T27657a.stdout - + testsuite/tests/concurrent/should_run/T27657b.hs - + testsuite/tests/concurrent/should_run/T27657b.stdout - testsuite/tests/concurrent/should_run/all.T - + testsuite/tests/simd/should_run/T27565.hs - + testsuite/tests/simd/should_run/T27565.stdout - testsuite/tests/simd/should_run/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1653dc05cde9e6d317162f6ba1716… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1653dc05cde9e6d317162f6ba1716… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/27627] 5 commits: Never make an absent filler for a constraint type
by Zubin (＠wz1000) 27 Aug '26

27 Aug '26

Zubin pushed to branch wip/27627 at Glasgow Haskell Compiler / GHC Commits: 41a13cb6 by Simon Peyton Jones at 2026-08-27T10:18:12+05:30 Never make an absent filler for a constraint type mkAbsentFiller used isTerminatingType to decide, but that is not enough. Consider class Eq a => UC a where {} let u :: UC Int -- UC Int is a "non-terminating type" u = error "Absent" let e :: Eq Int -- Eq Int is a "terminating type" e = $p1UC u We clearly must not make a filler for `e`, because we speculatively evaluate it. But speculatively evaluating `e` forces `u`, so we must not make one for `u` either. Asking isDictTy instead is not enough either, because it does not catch a constraint hidden behind an unreduced type family application: type family F a :: Constraint type instance F W = TC W a :: F W => Int -> Int -- (F W) argument is absent Oops! Entered absent arg Arg: irred Type: F W So play safe and use isPredTy: never make an absent filler for any constraint-kinded type. Fixes #27627 - - - - - ac54d8d9 by Zubin Duggal at 2026-08-27T10:18:12+05:30 Add tests for absent fillers at dictionary types T27627 a unary class whose superclass is a non-unary class T27627a ...whose superclass is a Constraint-kinded type family T27627b ...whose superclass is a quantified constraint T27627c a unary class applied to itself, (UC (UC (TC a))) T27627e a (forall b. P b) dictionary that loops - - - - - 4b6dd94e by Zubin Duggal at 2026-08-27T10:18:12+05:30 An abstract TyCon may hide a unary class A class declared in an hs-boot file is an AbstractTyCon inside the module loop, and compiling the real declaration may reveal it to be a UnaryClassTyCon. - isTerminatingType returned True for such AbstractTyCons - IfaceToCore set the unary flag to False in the DFunId So we could end up speculating bottom dictionaries because inside a module loop we see an UnaryClassTyCon as an AbstractTyCon Use mayBeUnaryClassTyCon instead of isUnaryClassTyCon, which returns True for an abstract TyCon. Fixes #27704 - - - - - 6e414550 by Zubin Duggal at 2026-08-27T10:18:12+05:30 Specialise: don't replace dead args with absent fillers specHeader decides an argument is dead by calling isDeadBinder on a binder of the /optimised RHS/, then applies the filler to the /stable unfolding/ template instead. The two may differ, so the argument can be dead in the RHS and not in the template. The specialised function's unfolding then has an absent filler, and any call site that inlines it evaluates the error thunk. Dropping dead args in the specialiser is rarely worth it, to quote Simon, "The later worker/wrapper pass will pick up the dead arg later if it is really dead. Keeps the specialiser simpler." So instead of trying to check if the arg really is dead in the stable unfolding, just drop the logic for dropping dead args in the specialiser altogeher. Fixes #27703 - - - - - c1de6b57 by Zubin Duggal at 2026-08-27T10:18:12+05:30 CorePrep: don't speculate a call across an hs-boot edge We take care not to evaluate things that might be bottom, like a looping dictionary group, but our analysis is defeated by boot files. We only track recursion within a module, so two dictionaries that depend on each other across a module loop each look non-recursive, and we might speculate them. Any recursion we cannot see must cross an hs-boot edge, so refuse to speculate calls that cross one. Fixes #27717 - - - - - 68 changed files: - + changelog.d/27627 - + changelog.d/27703 - + changelog.d/27704 - + changelog.d/27717 - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Literal.hs - + testsuite/tests/core-to-stg/T27627/Callee.hs - + testsuite/tests/core-to-stg/T27627/Caller.hs - + testsuite/tests/core-to-stg/T27627/Main.hs - + testsuite/tests/core-to-stg/T27627/T27627.stdout - + testsuite/tests/core-to-stg/T27627/all.T - + testsuite/tests/core-to-stg/T27627a/Callee.hs - + testsuite/tests/core-to-stg/T27627a/Caller.hs - + testsuite/tests/core-to-stg/T27627a/Main.hs - + testsuite/tests/core-to-stg/T27627a/T27627a.stdout - + testsuite/tests/core-to-stg/T27627a/all.T - + testsuite/tests/core-to-stg/T27627b/Callee.hs - + testsuite/tests/core-to-stg/T27627b/Caller.hs - + testsuite/tests/core-to-stg/T27627b/Main.hs - + testsuite/tests/core-to-stg/T27627b/T27627b.stdout - + testsuite/tests/core-to-stg/T27627b/all.T - + testsuite/tests/core-to-stg/T27627c/Callee.hs - + testsuite/tests/core-to-stg/T27627c/Caller.hs - + testsuite/tests/core-to-stg/T27627c/Main.hs - + testsuite/tests/core-to-stg/T27627c/T27627c.stdout - + testsuite/tests/core-to-stg/T27627c/all.T - + testsuite/tests/core-to-stg/T27627e.hs - + testsuite/tests/core-to-stg/T27627e.stdout - + testsuite/tests/core-to-stg/T27627f/Callee.hs - + testsuite/tests/core-to-stg/T27627f/Caller.hs - + testsuite/tests/core-to-stg/T27627f/Inst.hs - + testsuite/tests/core-to-stg/T27627f/Main.hs - + testsuite/tests/core-to-stg/T27627f/T27627f.stdout - + testsuite/tests/core-to-stg/T27627f/all.T - + testsuite/tests/core-to-stg/T27704/Callee.hs - + testsuite/tests/core-to-stg/T27704/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704/Main.hs - + testsuite/tests/core-to-stg/T27704/Mid.hs - + testsuite/tests/core-to-stg/T27704/T27704.stdout - + testsuite/tests/core-to-stg/T27704/all.T - + testsuite/tests/core-to-stg/T27704a/Callee.hs - + testsuite/tests/core-to-stg/T27704a/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704a/Main.hs - + testsuite/tests/core-to-stg/T27704a/Mid.hs - + testsuite/tests/core-to-stg/T27704a/T27704a.stdout - + testsuite/tests/core-to-stg/T27704a/all.T - + testsuite/tests/core-to-stg/T27717/Callee.hs - + testsuite/tests/core-to-stg/T27717/Callee.hs-boot - + testsuite/tests/core-to-stg/T27717/Main.hs - + testsuite/tests/core-to-stg/T27717/Mid.hs - + testsuite/tests/core-to-stg/T27717/T27717.stdout - + testsuite/tests/core-to-stg/T27717/Ty.hs - + testsuite/tests/core-to-stg/T27717/all.T - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplCore/should_compile/spec004.hs - testsuite/tests/simplCore/should_compile/spec004.stderr - + testsuite/tests/simplCore/should_run/T27703/Lib.hs - + testsuite/tests/simplCore/should_run/T27703/Main.hs - + testsuite/tests/simplCore/should_run/T27703/T27703.stdout - + testsuite/tests/simplCore/should_run/T27703/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b74f9775b188178ff79d7f222d0d6e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b74f9775b188178ff79d7f222d0d6e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-21
by Alan Zimmerman (＠alanz) 26 Aug '26

26 Aug '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-21 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-21 You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27744] Fix buglet in INLINE-arity calculation for pattern synonyms
by Simon Peyton Jones (＠simonpj) 26 Aug '26

26 Aug '26

Simon Peyton Jones pushed to branch wip/T27744 at Glasgow Haskell Compiler / GHC Commits: a583c921 by Simon Peyton Jones at 2026-08-26T20:35:40+01:00 Fix buglet in INLINE-arity calculation for pattern synonyms This fixes #27744. The buglet was accidentally introduced by commit 3a0f9a51c1dacc474c7fd128082edd8bf4081256 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Sat Aug 1 00:13:02 2026 +0100 Fix three bugs related to required type args and INLINE pragmas I failed to find all the calls to `addInlinePragArity`! - - - - - 3 changed files: - compiler/GHC/Tc/TyCl/PatSyn.hs - + testsuite/tests/patsyn/should_compile/T27744.hs - testsuite/tests/patsyn/should_compile/all.T Changes: ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -875,8 +875,9 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn mg = MG{ mg_alts = L (l2l $ getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty gen } - matcher_arity = length req_theta + 3 - -- See Note [Pragmas for pattern synonyms] + + matcher_arity :: VisArity -- VisArity excludes dictionary arguments! + matcher_arity = 3 -- See Note [Pragmas for pattern synonyms] -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name @@ -967,9 +968,8 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) let builder_id = mkExportedVanillaId builder_name builder_ty -- See Note [Exported LocalIds] in GHC.Types.Id - (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn - builder_arity = length req_theta + length prov_theta - + length arg_tys + builder_arity :: VisArity -- VisArity excludes dictionary arguments! + builder_arity = length (patSynArgs patsyn) + (if need_dummy_arg then 1 else 0) -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms] @@ -1348,13 +1348,20 @@ entire pattern synonym is supported. For example: When no pragma is provided for a pattern, the inlining decision might change between different versions of GHC. -Implementation notes. The prag_fn passed in to tcPatSynDecl will have a binding -for the /pattern synonym/ Name, thus - InlinedPattern :-> INLINE -From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher) -and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/ -Name in the prag_fn, and then using addInlinePragArity to add the right -inl_sat field to that INLINE pragma for the matcher or builder respectively. +Implementation notes. + +* The prag_fn passed in to tcPatSynDecl will have a binding + for the /pattern synonym/ Name, thus + InlinedPattern :-> INLINE + From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher) + and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/ + Name in the prag_fn, and then using `addInlinePragArity` to add the right + inl_sat field to that INLINE pragma for the matcher or builder respectively. + +* Note that the arity passed to `addInlinePragArity` is the `VisArity`, the /visible/ + arity. That specifically /excludes/ dictionary arguments, which are dealt with by + `addInlinePragArity`. The builder and matcher have no Required type args, so we + don't need to worry about them in the `VisArity`. -} ===================================== testsuite/tests/patsyn/should_compile/T27744.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A facility for faking GADTs that work sufficiently similarly +-- to unary natural numbers. +module T27744 + ( Nattish (Zeroy, Succy) + ) + where +import Unsafe.Coerce (unsafeCoerce) +import Data.Kind (Type) + +type Nattish :: forall k. k -> (k -> k) -> k -> Type +newtype Nattish zero succ n = Nattish Word +type role Nattish nominal nominal nominal + +data Res zero succ n where + ResZero :: Res zero succ zero + ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n) + +check :: Nattish zero succ n -> Res zero succ n +check (Nattish 0) = unsafeCoerce ResZero +check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1)) + +pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n +pattern Zeroy <- (check -> ResZero) + where + Zeroy = Nattish 0 +{-# INLINE Zeroy #-} + +pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n +pattern Succy n <- (check -> ResSucc n) + where + Succy (Nattish n) = Nattish (n + 1) +{-# INLINE Succy #-} + +{-# COMPLETE Zeroy, Succy #-} ===================================== testsuite/tests/patsyn/should_compile/all.T ===================================== @@ -94,3 +94,4 @@ test('T26331a', normal, compile, ['']) test('T27440a', normal, compile, ['']) test('T27440b', normal, compile, ['']) test('T27440c', normal, compile, ['']) +test('T27744', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a583c921f39dfde1738fe3dd32bb5e8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a583c921f39dfde1738fe3dd32bb5e8… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] EPA: Uses Parsers.parseModule for exactprint tests
by Marge Bot (＠marge-bot) 26 Aug '26

26 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cd653714 by Alan Zimmerman at 2026-08-26T15:11:49-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 5 changed files: - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd653714596108ebf47450202b6748c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd653714596108ebf47450202b6748c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] 2 commits: rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS
by Marge Bot (＠marge-bot) 26 Aug '26

26 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: bb324171 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS - No behavior change in this commit (well, a small optimization here makes us do less work if the target TSO owned by the curr. capability) - Move all THREADED_RTS CPP needed into `updThreadFlag` - Merge MSG_SET_TSO_FLAGS and MSG_UNSET_TSO_FLAGS into MSG_UPD_TSO_FLAGS plus a `set` bool field in the MessageUpdTSOFlag struct Towards #27729 - - - - - ed99b7b7 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: Fix race condition in MSG_UPD_TSO_FLAGS execution The code for processing the MSG_UPD_TSO_FLAGS message was not taking into consideration that the TSO's owner might have moved in between that capability receiving the message (since it was its previous owner) and starting to process its inbox (a point at which it was no longer the owner) Added Note [TSO owner may change in between Msg being sent and received] to explain this race and the pattern used to fix this, where we just forward the message to the new owner. Fixes #27729 - - - - - 8 changed files: - rts/CloneStack.c - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h Changes: ===================================== rts/CloneStack.c ===================================== @@ -88,6 +88,7 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){ // We must check that the current owner of the thread we want to clone the stack for // is still this capability. + // See Note [TSO owner may change in between Msg being sent and received] Capability *owner = RELAXED_LOAD(&msg->tso->cap); if (owner != cap) { // The target TSO may have migrated after the message was queued on the old ===================================== rts/Interpreter.c ===================================== @@ -416,22 +416,14 @@ void rts_disableStopNextBreakpointAll(void) void rts_enableStopNextBreakpoint(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); setThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); -#else - tso->flags |= TSO_STOP_NEXT_BREAKPOINT; -#endif } void rts_disableStopNextBreakpoint(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); unsetThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); -#else - tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT; -#endif } /* --------------------------------------------------------------------------- @@ -440,22 +432,14 @@ void rts_disableStopNextBreakpoint(StgTSO* tso) void rts_enableStopAfterReturn(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); setThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); -#else - tso->flags |= TSO_STOP_AFTER_RETURN; -#endif } void rts_disableStopAfterReturn(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); unsetThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); -#else - tso->flags &= ~TSO_STOP_AFTER_RETURN; -#endif } /* ===================================== rts/Messages.c ===================================== @@ -36,8 +36,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked i != &stg_WHITEHOLE_info && i != &stg_MSG_CLONE_STACK_info && - i != &stg_MSG_SET_TSO_FLAG_info && - i != &stg_MSG_UNSET_TSO_FLAG_info) { + i != &stg_MSG_UPD_TSO_FLAG_info) { barf("sendMessage: %p", i); } } @@ -67,6 +66,62 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) Handle a message ------------------------------------------------------------------------- */ +/* +Note [TSO owner may change in between Msg being sent and received] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a message is sent from Capability (C1) to a target TSO (T2) (e.g. +MessageUpdTSOFlag, MessageCloneStack, ...), it is queued on the TSO's owner +Capability (C3) inbox (inboxes are owned by Capabilities, not TSOs). + +At a later point, the Capability (C3) will process its inbox. Upon receiving +the message meant for a specific TSO (T2), it must first always check that the +TSO's owner is *still* itself (C3). + +The target TSO (T2) may have migrated after the message was queued on its old +capability (C3). In that case we must forward the request to the new owner +(say, C4); otherwise the Capability C3 could be modifying a TSO it no longer +owns, racing with its actual owner mutating it, since it is no longer the owner. + +The message meant for a TSO should only be executed when the receiving +Capability is still the owner of that TSO. Otherwise, it must be forwarded to +the new owner. + +The general pattern is one where there's a top-level function which assumes it +can be called by capabilities other than the TSO's owner. The function checks +whether the current capability is the TSO owner. If yes, execute the action. If +not, then it sends a message to the current TSO's owner. On receiving the +message, the new capability will just call that top-level function, which will +ensure the message is forwarded again if the TSO owner changed. +It will look something like: + + runMyMsg(Capability *from, StgTSO *target, ...) { + +#if defined(THREADED_RTS) + Capability *owner = RELAXED_LOAD(&target->cap) + if (owner != from) { + MessageMyMsg* msg = ... + sendMessage(cap, owner, msg) + return + } +#endif + + actuallyDoTheWork(...) + } + + executeMessage(...) { + + if (i == &stg_MY_MSG_info) { + + MessageMyMsg* msg = (MessageMyMsg*) m + runMyMsg(cap, m->tso, ...) + + } + } + +See example `updThreadFlag` and `executeMessage`'s `stg_MSG_UPD_TSO_FLAG_info`, +or `tryWakeUpThread` and `stg_MSG_TRY_WAKEUP_info` for two live examples. +*/ + #if defined(THREADED_RTS) void @@ -141,15 +196,11 @@ loop: MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; handleCloneStackMessage(cap, cloneStackMessage); } - else if(i == &stg_MSG_SET_TSO_FLAG_info){ + else if(i == &stg_MSG_UPD_TSO_FLAG_info){ MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; - u->tso->flags |= u->flag; - return; - } - else if(i == &stg_MSG_UNSET_TSO_FLAG_info){ - MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; - u->tso->flags &= ~u->flag; - return; + + StgTSO *tso = RELAXED_LOAD(&u->tso); + updThreadFlag(cap, tso, u->flag, u->set); } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -855,11 +855,8 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL") INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK") { ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; } -INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,2,1,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG") -{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; } - -INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,2,1,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG") -{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; } +INFO_TABLE_CONSTR(stg_MSG_UPD_TSO_FLAG,2,2,0,PRIM,"MSG_UPD_TSO_FLAG","MSG_UPD_TSO_FLAG") +{ foreign "C" barf("stg_MSG_UPD_TSO_FLAG object (%p) entered!", R1) never returns; } /* ---------------------------------------------------------------------------- END_TSO_QUEUE ===================================== rts/Threads.c ===================================== @@ -379,32 +379,46 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to) sets or unsets a flag in a given TSO ------------------------------------------------------------------------- */ -#if defined(THREADED_RTS) -static void -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info); - void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) { - updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info); + updThreadFlag(from, tso, flag, true); } void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) { - updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info); + updThreadFlag(from, tso, flag, false); } -static void -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info) +void +updThreadFlag(Capability *from USED_IF_THREADS, StgTSO *tso, StgWord32 flag, StgBool set /* true=set, false=unset */) { - MessageUpdTSOFlag *msg; - msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); - msg->tso = tso; - msg->flag = flag; - SET_HDR_RELEASE(msg, info, CCS_SYSTEM); - sendMessage(from, tso->cap, (Message*)msg); -} +#if defined(THREADED_RTS) + // If we're the current owner of the thread we want to modify, do it. + // Otherwise, we must forward the message to the actual owner. + // When executing the upd message, we check again that we're still the TSO + // owner (which may have changed since the message was queued on this cap.) + // See Note [TSO owner may change in between Msg being sent and received] + Capability *tso_owner = RELAXED_LOAD(&tso->cap); + if (from != tso_owner) { + MessageUpdTSOFlag *msg; + msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); + msg->tso = tso; + msg->flag = flag; + msg->set = set; + SET_HDR_RELEASE(msg, &stg_MSG_UPD_TSO_FLAG_info, CCS_SYSTEM); + sendMessage(from, tso_owner, (Message*)msg); + return; + } #endif + if (set) { + tso->flags |= flag; + } + else { + tso->flags &= ~flag; + } +} + /* ---------------------------------------------------------------------------- awakenBlockedQueue ===================================== rts/Threads.h ===================================== @@ -19,10 +19,9 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso); void tryWakeupThread (Capability *cap, StgTSO *tso); void migrateThread (Capability *from, StgTSO *tso, Capability *to); -#if defined(THREADED_RTS) void setThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); void unsetThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); -#endif +void updThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag, StgBool set); // Wakes up a thread on a Capability (probably a different Capability // from the one held by the current Task). ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -625,6 +625,7 @@ typedef struct MessageUpdTSOFlag_ { Message *link; StgTSO *tso; StgWord flag; + StgWord set; // bool: true=SET; false=UNSET } MessageUpdTSOFlag; /* ---------------------------------------------------------------------------- ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -151,8 +151,7 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP); RTS_ENTRY(stg_MSG_THROWTO); RTS_ENTRY(stg_MSG_BLACKHOLE); RTS_ENTRY(stg_MSG_CLONE_STACK); -RTS_ENTRY(stg_MSG_SET_TSO_FLAG); -RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG); +RTS_ENTRY(stg_MSG_UPD_TSO_FLAG); RTS_ENTRY(stg_MSG_NULL); RTS_ENTRY(stg_MVAR_TSO_QUEUE); RTS_ENTRY(stg_catch); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd22f71ee92595f4634206455d8eab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd22f71ee92595f4634206455d8eab… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] ghc-internal: annotateSTM should use catchSTM# rather than catch#
by Marge Bot (＠marge-bot) 26 Aug '26

26 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fd22f71e by Zubin Duggal at 2026-08-26T15:10:20-04:00 ghc-internal: annotateSTM should use catchSTM# rather than catch# A catch# frame inside a transaction breaks retry and async exception delivery. Fixes #27657 - - - - - 7 changed files: - + changelog.d/T27657 - libraries/ghc-internal/src/GHC/Internal/STM.hs - + testsuite/tests/concurrent/should_run/T27657a.hs - + testsuite/tests/concurrent/should_run/T27657a.stdout - + testsuite/tests/concurrent/should_run/T27657b.hs - + testsuite/tests/concurrent/should_run/T27657b.stdout - testsuite/tests/concurrent/should_run/all.T Changes: ===================================== changelog.d/T27657 ===================================== @@ -0,0 +1,9 @@ +section: base +issues: #27657 +mrs: !16508 +synopsis: + Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler +description: + ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO + ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the + correct way to catch exceptions inside STM. ===================================== libraries/ghc-internal/src/GHC/Internal/STM.hs ===================================== @@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation) import GHC.Internal.Exception.Type (WhileHandling(..)) import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.Prim ( - RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#, + RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#, newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#, ) import GHC.Internal.Prim.PtrEq (sameTVar#) @@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler' -- | Execute an 'STM' action, adding the given 'ExceptionContext' -- to any thrown synchronous exceptions. annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a -annotateSTM ann (STM io) = STM (catch# io handler) +annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657 where handler se = raiseIO# (addExceptionContext ann se) ===================================== testsuite/tests/concurrent/should_run/T27657a.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO +-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper. + +import Control.Exception +import GHC.Conc + +main :: IO () +main = do + r <- atomically $ + catchSTM (throwSTM (ErrorCall "boom")) + (\(_ :: SomeException) -> retry) + `orElse` pure "T27657a: completed" + putStrLn r ===================================== testsuite/tests/concurrent/should_run/T27657a.stdout ===================================== @@ -0,0 +1 @@ +T27657a: completed ===================================== testsuite/tests/concurrent/should_run/T27657b.hs ===================================== @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- An async exception delivered while a catchSTM handler runs must abort the +-- transaction, not be swallowed by a restart of the invalidated one. + +import Control.Concurrent.MVar +import Control.Exception +import GHC.Conc + +waitParked :: ThreadId -> IO () +waitParked t = do + s <- threadStatus t + case s of + ThreadBlocked BlockedOnMVar -> pure () + _ -> threadDelay 1000 >> waitParked t + +main :: IO () +main = do + tv <- newTVarIO (0 :: Int) + park <- newEmptyMVar + result <- newEmptyMVar + t <- forkIO $ do + r <- try $ atomically $ do + v <- readTVar tv + catchSTM (throwSTM (ErrorCall "boom")) + (\(_ :: SomeException) -> + if v == 0 + then do unsafeIOToSTM (takeMVar park) + pure "handler resumed" + else pure "transaction restarted, exception dropped") + putMVar result (r :: Either SomeException String) + -- parked in the handler, so t cannot revalidate its trec before delivery + waitParked t + atomically (writeTVar tv 1) + killThread t + r <- takeMVar result + putStrLn $ case r of + Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered" + | otherwise -> "T27657b: unexpected exception: " ++ displayException e + Right s -> "T27657b: FAILED, " ++ s ===================================== testsuite/tests/concurrent/should_run/T27657b.stdout ===================================== @@ -0,0 +1 @@ +T27657b: killThread delivered ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -340,3 +340,6 @@ test('T27105_fail', extra_run_opts('+RTS -C0.2 -RTS'), expect_fail, run_timeout_multiplier(0.05)], multimod_compile_and_run, ['T27105.hs', '']) + +test('T27657a', normal, compile_and_run, ['']) +test('T27657b', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd22f71ee92595f4634206455d8eab1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd22f71ee92595f4634206455d8eab1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] 6 commits: cmm dumps: Add machop width info with -dppr-debug for infix ops.
by Marge Bot (＠marge-bot) 26 Aug '26

26 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e9bbe8f9 by Andreas Klebinger at 2026-08-26T15:09:23-04:00 cmm dumps: Add machop width info with -dppr-debug for infix ops. - - - - - 86e3a9d8 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 CmmLint: Check for unsupported MachOp widths machOpArgReps now maps MachOp + Width to a list of supported argument widths or Nothing if the given operation is not supported at the given width. This allows us to check for nonsensical combinations like FloatToInt at Word16. Similarly we now check that every address is actually wordwidth. - - - - - 13781cca by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: The big subword truncation fix. A set of slightly related fixes to arm subword handling: Bitmask immediates: Don't produce overflowing assembly literals. There is still another bug here that causes us to miss some valid literals but we will fix that later. Improve subword truncation handling: We now use a small set of helpers to truncate `Register` values rather than truncating immediate `Reg` values which greatly simplifies the code structure. This fixes a great many bugs to do with sign/zero extending subwords or the lack thereof. We now establish the invariant that subword values are zero-extended at every site at which they come into "scope" of the ncg, and rely on the invariant throughout rather than pessimistically inserting redundant extensions in a hodgepodge manner at the use sites of these values. This fixes at least the bugs described in issues #27533, #27430 #27537, #27538, #27539, and #27550. But likely more bugs yet not found. Subword ffi results: Apply truncations when calling functions returning subword values. genCondJump: Don't sign extend signed values in the input register as it might map to a local variable, corrupting the value stored within. Fix subword store/load instructions.: We used to read those at 32bit width even for smaller values possibly resulting in invalid memory access. Now we construct the suffix for subword variants based on the instruction format for these. - - - - - d8fa5d7c by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: Fix MO_V_Broadcast for non-literals. We now use OpReg instead of OpScalarAsVec as required since we broadcast a gp register. Also adds a test. Fixes #27565. - - - - - 94822c95 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 Add some test cases covering bugs in the arm ncg. * Test for #27430 (subword ffi results) * #27537 - subword conversions * #27538 - subwords used in conditional * #27533 - single byte read - - - - - dd1ba88a by Andreas Klebinger at 2026-08-26T15:09:24-04:00 cmmLint: Lint against MO_FS_Truncate subword use. - - - - - 26 changed files: - + changelog.d/arm_ncg_fixes_T27430 - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr - − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/codeGen/should_run/T27430.hs - + testsuite/tests/codeGen/should_run/T27430.stdout - + testsuite/tests/codeGen/should_run/T27430_c.c - + testsuite/tests/codeGen/should_run/T27533.hs - + testsuite/tests/codeGen/should_run/T27533.stdout - + testsuite/tests/codeGen/should_run/T27533_cmm.cmm - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/simd/should_run/T27565.hs - + testsuite/tests/simd/should_run/T27565.stdout - testsuite/tests/simd/should_run/all.T Changes: ===================================== changelog.d/arm_ncg_fixes_T27430 ===================================== @@ -0,0 +1,18 @@ +section: compiler +issues: #27430 #27539 #27538 #27537 #27550 #27565 #27533 +mrs: !16255 +synopsis: + A series of fixes to the ARM64 ncg, related to handling of primitive + 8/16bit types and simd. +description: + A series of related fixes to the ncg fixing: + + Fixed sign extension for subword values returned from unsafe ffi calls. + Clarify and lint for invalid conversions of int8/int16 -> float/double conversions. + Fix incorrect clobbering of local variables when comparing signed subword values. + Fix incorrect use of 32bit reads/stores for 8/16bit wide reads/stores. + Fix zero extension on function entry if arguments are passed at word-width + but used at subword-widths. + Fix broadcast# for non-literal arguments (arm64 only). + Fix rare assembler errors caused by overflowing literals, by properly checking + whether a constant is a viable immediate argument. ===================================== compiler/GHC/Cmm/Expr.hs ===================================== @@ -443,6 +443,11 @@ pprExpr platform e CmmLit lit -> pprLit platform lit _other -> pprExpr1 platform e +-- | `op` usually, but `(op[width])` with -dppr-debug +withDebugWidth :: Width -> SDoc -> SDoc +withDebugWidth w doc = + ifPprDebug (parens (doc <> brackets (ppr w))) doc + -- Here's the precedence table from GHC.Cmm.Parser: -- %nonassoc '>=' '>' '<=' '<' '!=' '==' -- %left '|' @@ -465,15 +470,17 @@ pprExpr1 platform e = pprExpr7 platform e infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing +infixMachOp1 mop = case mop of + (MO_Eq w) -> Just $ withDebugWidth w (text "==") + (MO_Ne w) -> Just $ withDebugWidth w (text "!=") + (MO_Shl w) -> Just $ withDebugWidth w (text "<<") + (MO_U_Shr w) -> Just $ withDebugWidth w (text ">>") + (MO_U_Ge w) -> Just $ withDebugWidth w (text ">=") + (MO_U_Le w) -> Just $ withDebugWidth w (text "<=") + (MO_U_Gt w) -> Just $ withDebugWidth w (char '>') + (MO_U_Lt w) -> Just $ withDebugWidth w (char '<') + _ -> Nothing + where -- %left '-' '+' pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 @@ -483,8 +490,8 @@ pprExpr7 platform (CmmMachOp op [x,y]) = pprExpr7 platform x <+> doc <+> pprExpr8 platform y pprExpr7 platform e = pprExpr8 platform e -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 (MO_Add w) = Just $ withDebugWidth w (char '+') +infixMachOp7 (MO_Sub w) = Just $ withDebugWidth w (char '-') infixMachOp7 _ = Nothing -- %left '/' '*' '%' @@ -493,9 +500,9 @@ pprExpr8 platform (CmmMachOp op [x,y]) = pprExpr8 platform x <+> doc <+> pprExpr9 platform y pprExpr8 platform e = pprExpr9 platform e -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 (MO_U_Quot w) = Just $ withDebugWidth w (char '/') +infixMachOp8 (MO_Mul w) = Just $ withDebugWidth w (char '*') +infixMachOp8 (MO_U_Rem w) = Just $ withDebugWidth w (char '%') infixMachOp8 _ = Nothing pprExpr9 :: Platform -> CmmExpr -> SDoc @@ -545,11 +552,11 @@ genMachOp platform mop args infixMachOp :: MachOp -> Maybe SDoc infixMachOp mop = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + MO_And w -> Just $ withDebugWidth w $ char '&' + MO_Or w -> Just $ withDebugWidth w $ char '|' + MO_Xor w -> Just $ withDebugWidth w $ char '^' + MO_Not w -> Just $ withDebugWidth w $ char '~' + MO_S_Neg w -> Just $ withDebugWidth w $ char '-' -- there is no unsigned neg :) _ -> Nothing -- -------------------------------------------------------------------------- ===================================== compiler/GHC/Cmm/Lint.hs ===================================== @@ -88,8 +88,9 @@ lintCmmBlock labels block -- byte/word mismatches. lintCmmExpr :: CmmExpr -> CmmLint CmmType -lintCmmExpr (CmmLoad expr rep _alignment) = do - _ <- lintCmmExpr expr +lintCmmExpr e@(CmmLoad expr rep _alignment) = do + ty <- lintCmmExpr expr + lintAddrTy e ty -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $ @@ -99,11 +100,11 @@ lintCmmExpr expr@(CmmMachOp op args) = do platform <- getPlatform tys <- mapM lintCmmExpr args lintShiftOp op (zip args tys) - let machop_arg_widths = machOpArgReps platform op + let machop_arg_widths_m = machOpArgReps platform op arg_tys = map (cmmExprType platform) args - if map typeWidth arg_tys == machop_arg_widths + if maybe False (\machop_arg_widths -> map typeWidth arg_tys == machop_arg_widths) machop_arg_widths_m then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr arg_tys machop_arg_widths + else cmmLintMachOpErr expr arg_tys machop_arg_widths_m lintCmmExpr (CmmRegOff reg offset) = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) @@ -112,6 +113,15 @@ lintCmmExpr expr = do platform <- getPlatform return (cmmExprType platform expr) +-- We require every address value to be word-sized since we don't support 32 +-- bit pointers on 64bit platforms. +lintAddrTy :: CmmExpr -> CmmType -> CmmLint () +lintAddrTy e addr_ty = do + p <- getPlatform + -- We don't support any platforms where wordwidth /= ptrWidth currently. + unless (addr_ty `cmmCompatType` bWord p) $ cmmLintErr (text "Non word-width address found in:" <+> pdoc p e) + + -- | Check for obviously out-of-bounds shift operations lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint () lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)] @@ -173,10 +183,10 @@ lintCmmMiddle node = case node of unless (erep `cmmCompatType` reg_ty) $ cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - CmmStore l r _alignment -> do - _ <- lintCmmExpr l - _ <- lintCmmExpr r - return () + CmmStore addr rhs _alignment -> do + addr_ty <- lintCmmExpr addr + _ <- lintCmmExpr rhs + lintAddrTy addr addr_ty CmmUnsafeForeignCall target _formals actuals -> do let lintArg expr = do @@ -279,8 +289,16 @@ addLintInfo info thing = CmmLint $ \platform -> Left err -> Left (hang info 2 err) Right a -> Right a -cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a -cmmLintMachOpErr expr argsRep opExpectsRep +cmmLintMachOpErr :: CmmExpr -> [CmmType] -> Maybe [Width] -> CmmLint a +cmmLintMachOpErr expr argsRep Nothing + = do + platform <- getPlatform + cmmLintErr (text "in MachOp application: " $$ + nest 2 (pdoc platform expr) $$ + text "op is using unsupported width" $$ + (text "arguments provide: " <+> ppr argsRep)) + +cmmLintMachOpErr expr argsRep (Just opExpectsRep) = do platform <- getPlatform cmmLintErr (text "in MachOp application: " $$ ===================================== compiler/GHC/Cmm/MachOp.hs ===================================== @@ -142,8 +142,8 @@ data MachOp -- Conversions. Some of these will be NOPs. -- Floating-point conversions use the signed variant. - | MO_SF_Round Width Width -- Signed int -> Float - | MO_FS_Truncate Width Width -- Float -> Signed int + | MO_SF_Round Width Width -- Signed int -> Float, but only W32/W64 inputs + | MO_FS_Truncate Width Width -- Float -> Signed int, only W32/W64 on the int side. | MO_SS_Conv Width Width -- Signed int -> Signed int | MO_UU_Conv Width Width -- unsigned int -> unsigned int | MO_XX_Conv Width Width -- int -> int; puts no requirements on the @@ -565,111 +565,120 @@ comparisonResultRep = bWord -- is it? -- application of a MachOp is "type-correct" by checking that the MachReps of -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. +-- We also check if the given width is supported at all. But there might be +-- false positives. -machOpArgReps :: Platform -> MachOp -> [Width] +machOpArgReps :: Platform -> MachOp -> Maybe [Width] machOpArgReps platform op = case op of - MO_Add w -> [w,w] - MO_Sub w -> [w,w] - MO_Eq w -> [w,w] - MO_Ne w -> [w,w] - MO_Mul w -> [w,w] - MO_S_MulMayOflo w -> [w,w] - MO_S_Quot w -> [w,w] - MO_S_Rem w -> [w,w] - MO_S_Neg w -> [w] - MO_U_Quot w -> [w,w] - MO_U_Rem w -> [w,w] - - MO_S_Ge w -> [w,w] - MO_S_Le w -> [w,w] - MO_S_Gt w -> [w,w] - MO_S_Lt w -> [w,w] - - MO_U_Ge w -> [w,w] - MO_U_Le w -> [w,w] - MO_U_Gt w -> [w,w] - MO_U_Lt w -> [w,w] - - MO_F_Add w -> [w,w] - MO_F_Sub w -> [w,w] - MO_F_Mul w -> [w,w] - MO_F_Quot w -> [w,w] - MO_F_Neg w -> [w] - MO_F_Min w -> [w,w] - MO_F_Max w -> [w,w] - - MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] - - MO_F_Eq w -> [w,w] - MO_F_Ne w -> [w,w] - MO_F_Ge w -> [w,w] - MO_F_Le w -> [w,w] - MO_F_Gt w -> [w,w] - MO_F_Lt w -> [w,w] - - MO_And w -> [w,w] - MO_Or w -> [w,w] - MO_Xor w -> [w,w] - MO_Not w -> [w] - MO_Shl w -> [w, wordWidth platform] - MO_U_Shr w -> [w, wordWidth platform] - MO_S_Shr w -> [w, wordWidth platform] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_XX_Conv from _ -> [from] - MO_SF_Round from _ -> [from] - MO_FS_Truncate from _ -> [from] - MO_FF_Conv from _ -> [from] - MO_WF_Bitcast w -> [w] - MO_FW_Bitcast w -> [w] - - MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] - - MO_V_Broadcast _ w -> [w] - MO_V_Insert l w -> [vecwidth l w, w, W32] - MO_V_Extract l w -> [vecwidth l w, W32] - MO_VF_Broadcast _ w -> [w] - MO_VF_Insert l w -> [vecwidth l w, w, W32] - MO_VF_Extract l w -> [vecwidth l w, W32] + MO_Add w -> Just [w,w] + MO_Sub w -> Just [w,w] + MO_Eq w -> Just [w,w] + MO_Ne w -> Just [w,w] + MO_Mul w -> Just [w,w] + MO_S_MulMayOflo w -> Just [w,w] + MO_S_Quot w -> Just [w,w] + MO_S_Rem w -> Just [w,w] + MO_S_Neg w -> Just [w] + MO_U_Quot w -> Just [w,w] + MO_U_Rem w -> Just [w,w] + + MO_S_Ge w -> Just [w,w] + MO_S_Le w -> Just [w,w] + MO_S_Gt w -> Just [w,w] + MO_S_Lt w -> Just [w,w] + + MO_U_Ge w -> Just [w,w] + MO_U_Le w -> Just [w,w] + MO_U_Gt w -> Just [w,w] + MO_U_Lt w -> Just [w,w] + + MO_F_Add w -> Just [w,w] + MO_F_Sub w -> Just [w,w] + MO_F_Mul w -> Just [w,w] + MO_F_Quot w -> Just [w,w] + MO_F_Neg w -> Just [w] + MO_F_Min w -> Just [w,w] + MO_F_Max w -> Just [w,w] + + MO_FMA _ l w -> Just [vecwidth l w, vecwidth l w, vecwidth l w] + + MO_F_Eq w -> Just [w,w] + MO_F_Ne w -> Just [w,w] + MO_F_Ge w -> Just [w,w] + MO_F_Le w -> Just [w,w] + MO_F_Gt w -> Just [w,w] + MO_F_Lt w -> Just [w,w] + + MO_And w -> Just [w,w] + MO_Or w -> Just [w,w] + MO_Xor w -> Just [w,w] + MO_Not w -> Just [w] + MO_Shl w -> Just [w, wordWidth platform] + MO_U_Shr w -> Just [w, wordWidth platform] + MO_S_Shr w -> Just [w, wordWidth platform] + + MO_SS_Conv from _ -> Just [from] + MO_UU_Conv from _ -> Just [from] + MO_XX_Conv from _ -> Just [from] + -- Only supports W32/W64 + MO_SF_Round from _w -> onlyW32W64 from + MO_FS_Truncate from to + | to `notElem` [W32, W64] -> Nothing + | otherwise -> onlyW32W64 from + MO_FF_Conv from _ -> onlyW32W64 from + MO_WF_Bitcast w -> onlyW32W64 w + MO_FW_Bitcast w -> onlyW32W64 w + + MO_V_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + MO_VF_Shuffle l w _ -> Just [vecwidth l w, vecwidth l w] + + MO_V_Broadcast _ w -> Just [w] + MO_V_Insert l w -> Just [vecwidth l w, w, W32] + MO_V_Extract l w -> Just [vecwidth l w, W32] + MO_VF_Broadcast _ w -> Just [w] + MO_VF_Insert l w -> Just [vecwidth l w, w, W32] + MO_VF_Extract l w -> Just [vecwidth l w, W32] -- SIMD vector indices are always 32 bit - MO_V_Add l w -> [vecwidth l w, vecwidth l w] - MO_V_Sub l w -> [vecwidth l w, vecwidth l w] - MO_V_Mul l w -> [vecwidth l w, vecwidth l w] + MO_V_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Mul l w -> Just [vecwidth l w, vecwidth l w] - MO_VS_Neg l w -> [vecwidth l w] - MO_VS_Abs l w -> [vecwidth l w] - MO_VS_Min l w -> [vecwidth l w, vecwidth l w] - MO_VS_Max l w -> [vecwidth l w, vecwidth l w] + MO_VS_Neg l w -> Just [vecwidth l w] + MO_VS_Abs l w -> Just [vecwidth l w] + MO_VS_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VS_Max l w -> Just [vecwidth l w, vecwidth l w] - MO_VU_Min l w -> [vecwidth l w, vecwidth l w] - MO_VU_Max l w -> [vecwidth l w, vecwidth l w] + MO_VU_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VU_Max l w -> Just [vecwidth l w, vecwidth l w] -- NOTE: The below is owing to the fact that floats use the SSE registers - MO_VF_Add l w -> [vecwidth l w, vecwidth l w] - MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] - MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] - MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] - MO_VF_Neg l w -> [vecwidth l w] - MO_VF_Abs l w -> [vecwidth l w] - MO_VF_Sqrt l w -> [vecwidth l w] - MO_VF_Min l w -> [vecwidth l w, vecwidth l w] - MO_VF_Max l w -> [vecwidth l w, vecwidth l w] - - MO_V_And l w -> [vecwidth l w, vecwidth l w] - MO_V_Or l w -> [vecwidth l w, vecwidth l w] - MO_V_Xor l w -> [vecwidth l w, vecwidth l w] - MO_VF_And l w -> [vecwidth l w, vecwidth l w] - MO_VF_Or l w -> [vecwidth l w, vecwidth l w] - MO_VF_Xor l w -> [vecwidth l w, vecwidth l w] - - MO_RelaxedRead _ -> [wordWidth platform] - MO_AlignmentCheck _ w -> [w] + MO_VF_Add l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> Just [vecwidth l w] + MO_VF_Abs l w -> Just [vecwidth l w] + MO_VF_Sqrt l w -> Just [vecwidth l w] + MO_VF_Min l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Max l w -> Just [vecwidth l w, vecwidth l w] + + MO_V_And l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_V_Xor l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_And l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Or l w -> Just [vecwidth l w, vecwidth l w] + MO_VF_Xor l w -> Just [vecwidth l w, vecwidth l w] + + MO_RelaxedRead _ -> Just [wordWidth platform] + MO_AlignmentCheck _ w -> Just [w] where vecwidth l w = widthFromBytes (l * widthInBytes w) + onlyW32W64 w + | w == W64 = Just [w] + | w == W32 = Just [w] + | otherwise = Nothing ----------------------------------------------------------------------------- -- CallishMachOp ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -745,6 +745,8 @@ stmt :: { CmmParse () } { doCall $2 [] $4 } | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' { doCall $6 $2 $8 } + -- NB: bool_expr most be a *boolean* expression: A comparison machOp or 1/0 word literals. + -- We don't allow arbitrary expressions as conditions (See GHC.Cmm.Lint.checkCond:checkCond, #27543). | 'if' bool_expr cond_likely 'goto' NAME { do l <- lookupLabel $5; cmmRawIf $2 l $3 } | 'if' bool_expr cond_likely '{' body '}' else ===================================== compiler/GHC/CmmToAsm/AArch64/CodeGen.hs ===================================== @@ -356,13 +356,10 @@ type InstrBlock -- data Register = Fixed Format Reg InstrBlock + -- ^ It can be unsafe to clobber the result reg, as it might map to a + -- local variable. | Any Format (Reg -> InstrBlock) - --- | Sometimes we need to change the Format of a register. Primarily during --- conversion. -swizzleRegisterRep :: Format -> Register -> Register -swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code -swizzleRegisterRep format (Any _ codefn) = Any format codefn + -- ^ A destination the caller decides, prevents redundant moves -- | Grab the Reg for a CmmReg getRegisterReg :: Platform -> CmmReg -> Reg @@ -370,8 +367,9 @@ getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) - = case globalRegMaybe platform mid of +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid ty)) + = assert (formatInBytes (cmmTypeFormat ty) >= 4) $ + case globalRegMaybe platform mid of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) -- By this stage, the only MagicIds remaining should be the @@ -382,11 +380,19 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) -- ----------------------------------------------------------------------------- -- General things for putting together code sequences --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- | Computes the `Register` value into a concrete register, but we can't pick which one. +-- This means the register might be mapped to a global or local variable and +-- we can only mutate the result reg in place if we know the Cmm expression can't +-- refer to local or global variables. +-- Subword results will be truncated as described by the subword invariant. +-- See Note [Subword operations on AArch64]. getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) getSomeReg expr = do r <- getRegister expr + someReg r + +someReg :: Register -> NatM (Reg, Format, InstrBlock) +someReg r = case r of Any rep code -> do tmp <- getNewRegNat rep @@ -633,6 +639,8 @@ getFloatReg expr = do litToImm' :: CmmLit -> NatM (Operand, InstrBlock) litToImm' lit = return (OpImm (litToImm lit), nilOL) +-- | Return a computation/block of instructions that corresponds to the expressions +-- value. Values are already truncated if needed. See Note [Subword operations on AArch64]. getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig @@ -647,28 +655,38 @@ opRegWidth W16 = W32 -- w opRegWidth W8 = W32 -- w opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) --- Note [Signed arithmetic on AArch64] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Handling signed arithmetic on sub-word-size values on AArch64 is a bit --- tricky as Cmm's type system does not capture signedness. While 32-bit values --- are fairly easy to handle due to AArch64's 32-bit instruction variants --- (denoted by use of %wN registers), 16- and 8-bit values require quite some --- care. +-- Note [Subword operations on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Handling subword operations on AArch64 is a bit tricky. 32-bit values are fairly +-- easy to handle due to AArch64's 32-bit instruction variants. 16- and 8-bit +-- values require quite some care. The platform doesn't provide operations at +-- widths below 32bit. Which means we have to simulate them using wider operations. +-- Signed arithmetic on sub-word-size values on AArch64 is a bit tricky as Cmm's +-- type system does not capture signedness. If we have a 8 bit value the high +-- bits could be sign or zero extended with no easy way to tell. -- --- We handle 16-and 8-bit values by using the 32-bit operations and +-- To work around this handle 16-and 8-bit values by using the 32-bit operations and -- sign-/zero-extending operands and truncate results as necessary. For -- simplicity we maintain the invariant that a register containing a -- sub-word-size value always contains the zero-extended form of that value -- in between operations. -- --- IMPORTANT: this invariant only holds within a single expression tree as --- generated by the NCG (via truncateReg after each sub-word operation). It --- does NOT hold at function entry points or across basic block boundaries, --- because the GHC calling convention does not guarantee that callers --- zero-extend sub-word arguments. Therefore, any operation that is sensitive --- to the upper bits of its input (e.g. unsigned right shift, unsigned --- division) must explicitly zero- or sign-extend its operands rather than --- assuming they are already extended. +-- Concretely we establish this invariant on every input into the function for which +-- we generate code for in the NCG. This means: +-- * Global STG register access +-- * memory reads +-- * function arguments +-- * ffi results +-- * function call results +-- * results from any subexpression. (Including results produced by getRegister/getSomeReg) +-- +-- This means we can assume the invariant when generated code for expression trees +-- or machops reading local variables, avoiding (some) redundant extensions. But +-- we have to take great care to uphold the invariant when computing new values. +-- +-- We used to do the inverse. Re-establish the invariant for any operation that +-- is sensitive to values in the high bits. But that turned out to produce worse +-- code and wasn't any less likely to result in new bugs in practice. -- -- For instance, consider the program, -- @@ -688,7 +706,10 @@ opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) -- Next we compute `c`: The `%not` requires no extension of its operands, but -- we must still truncate the result back down to 8-bits. Finally the `%shrl` -- requires no extension and no truncate since we can assume that --- `c` is zero-extended (it was produced by a truncateReg in the same block). +-- `c` is zero-extended. +-- +-- Down the line I think the right way to approach this is to operate more over +-- the `Register` type and store sign extension information inside it. -- -- TODO: -- Don't use Width in Operands @@ -925,20 +946,36 @@ getRegister' config plat expr getRegister (CmmLoad e (cmmBits w) NaturallyAligned) CmmMachOp op [e] -> do - (reg, _format, code) <- getSomeReg e + register <- getRegister e + (reg, _format, code) <- someReg register case op of - MO_Not w -> return $ Any (intFormat w) $ \dst -> + -- XX Conversion + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_XX_Conv from to + | to >= from -> pure $ swizzleRegisterRep register (intFormat to) + | otherwise -> pure $ truncateSubwordRegister to register + + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_Not w -> return $ truncateSubwordRegister w $ Any (intFormat w) $ \dst -> let w' = opRegWidth w in code `snocOL` - MVN (OpReg w' dst) (OpReg w' reg) `appOL` - truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] + MVN (OpReg w' dst) (OpReg w' reg) + + -- truncateSubwordRegister: See Note [Subword operations on AArch64]. + MO_S_Neg w -> truncateSubwordRegister w <$> do + let op_w = opRegWidth w + (src, _fmt, reg_code) <- someReg $ signExtendRegister w op_w register + pure $ Any (intFormat w) $ \dst -> reg_code `snocOL` (NEG (intFormat w) (OpReg op_w dst) (OpReg op_w src)) - MO_S_Neg w -> negate code w reg MO_F_Neg w -> return $ Any fmt (\dst -> code `snocOL` NEG fmt (OpReg w dst) (OpReg w reg)) where fmt = floatFormat w - MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) - MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) + MO_SF_Round from to -> + massert (from >= W32) >> + return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float) + MO_FS_Truncate from to -> + massert (to >= W32) >> + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed) -- TODO this is very hacky -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ @@ -951,11 +988,8 @@ getRegister' config plat expr MO_FW_Bitcast w -> return $ Any fmt (\dst -> code `snocOL` FMOV fmt (OpReg w dst) (OpReg w reg)) where fmt = intFormat w - -- Conversions - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e - -- Vector - MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg)) + MO_V_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpReg w reg)) where fmt = VecFormat l (intScalarFormat w) vw = formatToWidth fmt MO_VF_Broadcast l w -> return $ Any fmt (\dst -> code `snocOL` DUP fmt (OpReg vw dst) (OpScalarAsVec w reg)) @@ -1054,26 +1088,13 @@ getRegister' config plat expr toImm W256 = (OpImm (ImmInt 255)) toImm W512 = (OpImm (ImmInt 511)) - -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits - -- See Note [Signed arithmetic on AArch64]. - negate code w reg = do - let w' = opRegWidth w - fmt = intFormat w - (reg', code_sx) <- signExtendReg w w' reg - return $ Any fmt $ \dst -> - code `appOL` - code_sx `snocOL` - NEG fmt (OpReg w' dst) (OpReg w' reg') `appOL` - truncateReg w' w dst - ss_conv from to reg code = let w' = opRegWidth (max from to) - in return $ Any (intFormat to) $ \dst -> - code `snocOL` - SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL` - -- At this point an 8- or 16-bit value would be sign-extended + in return $ truncateSubwordRegister to $ Any (intFormat to) $ \dst -> + code `snocOL` + SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) + -- At this point an 8- or 16-bit value is sign-extended -- to 32-bits. Truncate back down the final width. - truncateReg w' to dst -- Dyadic machops: -- @@ -1090,26 +1111,14 @@ getRegister' config plat expr CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' -- Immediates are handled via `getArithImm` in the generic code path. - CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16-> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y - tmp_x <- getNewRegNat (intFormat w) - tmp_y <- getNewRegNat (intFormat w) - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w tmp_x) (OpReg w reg_x)) `snocOL` - (UXTB (OpReg w tmp_y) (OpReg w reg_y)) `snocOL` - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y))) - CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y - tmp_x <- getNewRegNat (intFormat w) - tmp_y <- getNewRegNat (intFormat w) - return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w tmp_x) (OpReg w reg_x)) `snocOL` - (UXTH (OpReg w tmp_y) (OpReg w reg_y)) `snocOL` - (UDIV (OpReg w dst) (OpReg w tmp_x) (OpReg w tmp_y))) + return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) -- 2. Shifts. x << n, x >> n. -- Sub-word left shifts by a constant: use UBFM (UBFIZ alias) to shift - -- and mask in a single instruction. See Note [Signed arithmetic on AArch64]. + -- and mask in a single instruction. See Note [Subword operations on AArch64]. CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFM (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger ((32 - n) `mod` 32))) (OpImm (ImmInteger (7 - n))))) @@ -1126,7 +1135,7 @@ getRegister' config plat expr CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))) - `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y @@ -1135,12 +1144,12 @@ getRegister' config plat expr tmp <- getNewRegNat (intFormat w) return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w tmp) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL` - (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))) - `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do (reg_x, _format_x, code_x) <- getSomeReg x (reg_y, _format_y, code_y) <- getSomeReg y @@ -1149,7 +1158,7 @@ getRegister' config plat expr tmp <- getNewRegNat (intFormat w) return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w tmp) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w tmp) (OpReg w reg_y)) `snocOL` - (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64] + (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Subword operations on AArch64] CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32 || w == W64 @@ -1182,14 +1191,14 @@ getRegister' config plat expr return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) -- 3. Logic &&, || - CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> - return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w -> + return $ Any fmt (\d -> unitOL $ annExpr expr (AND fmt (OpReg w d) (OpReg w' r') op_bitmask)) where fmt = intFormat w w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg - CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> - return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | Just op_bitmask <- getBitmaskImm n w -> + return $ Any fmt (\d -> unitOL $ annExpr expr (ORR fmt (OpReg w d) (OpReg w' r') op_bitmask)) where fmt = intFormat w w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg @@ -1220,16 +1229,17 @@ getRegister' config plat expr code_y `appOL` op (OpReg w dst) (OpReg w reg_x) op_y) - -- A (potentially signed) integer operation. + -- A (potentially signed) integer operation that can have immediate arguments. -- In the case of 8- and 16-bit signed arithmetic we must first -- sign-extend both arguments to 32-bits. - -- See Note [Signed arithmetic on AArch64]. - intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) - intOpImm {- is signed -} True w op _encode_imm = intOp True w op - intOpImm False w op encode_imm = do + -- See Note [Subword operations on AArch64]. + intOpImm :: Bool -> SetsHighBits -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) + intOpImm {- is signed -} True trunc w op _encode_imm = intOp True trunc w op + intOpImm False trunc w op encode_imm = maintainHighBits trunc w <$> do -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o> + let w' = opRegWidth w (reg_x, format_x, code_x) <- getSomeReg x (op_y, format_y, code_y) <- case y of CmmLit (CmmInt n w) @@ -1241,40 +1251,29 @@ getRegister' config plat expr massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" -- This is the width of the registers on which the operation -- should be performed. - let w' = opRegWidth w return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` - op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + op (OpReg w' dst) (OpReg w' reg_x) (op_y) -- A (potentially signed) integer operation. -- In the case of 8- and 16-bit signed arithmetic we must first -- sign-extend both arguments to 32-bits. - -- See Note [Signed arithmetic on AArch64]. - intOp is_signed w op = do + -- See Note [Subword operations on AArch64]. + intOp is_signed clean_highbits w op = maintainHighBits clean_highbits w <$> do -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o> - (reg_x, format_x, code_x) <- getSomeReg x - (reg_y, format_y, code_y) <- getSomeReg y + let op_w = opRegWidth w + let setHighBits = if is_signed then signExtendRegister w (opRegWidth w) else id + (reg_x_sx, format_x, code_x) <- someReg =<< setHighBits <$> getRegister x + (reg_y_sx, format_y, code_y) <- someReg =<< setHighBits <$> getRegister y massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" - -- This is the width of the registers on which the operation - -- should be performed. - let w' = opRegWidth w - signExt r - | not is_signed = return (r, nilOL) - | otherwise = signExtendReg w w' r - (reg_x_sx, code_x_sx) <- signExt reg_x - (reg_y_sx, code_y_sx) <- signExt reg_y + return $ Any (intFormat w) $ \dst -> code_x `appOL` code_y `appOL` - -- sign-extend both operands - code_x_sx `appOL` - code_y_sx `appOL` - op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL` - truncateReg w' w dst -- truncate back to the operand's original width + op (OpReg op_w dst) (OpReg op_w reg_x_sx) (OpReg op_w reg_y_sx) floatOp w op = do (reg_fx, format_x, code_fx) <- getFloatReg x @@ -1465,9 +1464,9 @@ getRegister' config plat expr case op of -- Integer operations -- Add/Sub should only be Integer Options. - MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm + MO_Add w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (ADD (intFormat w) d x y)) getArithImm -- TODO: Handle sub-word case - MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm + MO_Sub w -> intOpImm False UnknownHighBits w (\d x y -> unitOL $ annExpr expr (SUB (intFormat w) d x y)) getArithImm -- Note [CSET] -- ~~~~~~~~~~~ @@ -1513,9 +1512,9 @@ getRegister' config plat expr MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm -- Signed multiply/divide - MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL (intFormat w) d x y) + MO_Mul w -> intOp True UnknownHighBits w (\d x y -> unitOL $ MUL (intFormat w) d x y) MO_S_MulMayOflo w -> do_mul_may_oflo w x y - MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV (intFormat w) d x y) + MO_S_Quot w -> intOp True UnknownHighBits w (\d x y -> unitOL $ SDIV (intFormat w) d x y) -- No native rem instruction. So we'll compute the following -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry @@ -1525,24 +1524,24 @@ getRegister' config plat expr -- '--------------------------' -- Note the swap in Rx and Ry. MO_S_Rem w -> withTempIntReg w $ \t -> - intOp True w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ]) + intOp True UnknownHighBits w (\d x y -> toOL [ SDIV (intFormat w) t x y, MSUB d t y x ]) -- Unsigned multiply/divide - MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) + MO_U_Quot w -> intOp False CleanHighBits w (\d x y -> unitOL $ UDIV d x y) MO_U_Rem w -> withTempIntReg w $ \t -> - intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) + intOp False CleanHighBits w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) -- Signed comparisons -- see Note [CSET] - MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ]) - MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ]) - MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ]) - MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) + MO_S_Ge w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGE ]) + MO_S_Le w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLE ]) + MO_S_Gt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SGT ]) + MO_S_Lt w -> intOp True CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d SLT ]) -- Unsigned comparisons - MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm - MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm - MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm - MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm + MO_U_Ge w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm + MO_U_Le w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm + MO_U_Gt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm + MO_U_Lt w -> intOpImm False CleanHighBits w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm -- Floating point arithmetic MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD (floatFormat w) d x y) @@ -1570,9 +1569,9 @@ getRegister' config plat expr MO_And w -> bitOpImm w (\d x y -> unitOL $ AND (intFormat w) d x y) getBitmaskImm MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR (intFormat w) d x y) getBitmaskImm MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR (intFormat w) d x y) getBitmaskImm - MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y) - MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y) - MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y) + MO_Shl w -> intOp False UnknownHighBits w (\d x y -> unitOL $ LSL d x y) + MO_U_Shr w -> intOp False CleanHighBits w (\d x y -> unitOL $ LSR d x y) + MO_S_Shr w -> intOp True UnknownHighBits w (\d x y -> unitOL $ ASR d x y) -- Vector operations MO_V_Add l w -> intVecOp l w (\fmt d x y -> unitOL $ ADD fmt d x y) @@ -1630,7 +1629,7 @@ getRegister' config plat expr _ -> pprPanic "Unsupported offset" (pdoc platform y) (reg_x, format_x, code_x) <- getSomeReg x massertPpr (isVecFormat format_x) $ text "MO_V_Extract: non-vector" - -- Always use UMOV. See Note [Signed arithmetic on AArch64] + -- Always use UMOV. See Note [Subword operations on AArch64] return $ Any format (\dst -> code_x `snocOL` UMOV (OpReg w dst) (OpVecLane w reg_x index)) MO_VF_Extract l w -> do @@ -1759,7 +1758,7 @@ getRegister' config plat expr tmp <- getNewRegNat format return $ Any format $ \dst -> code_x `appOL` code_y `appOL` - if dst == reg_y + if dst == reg_y --unlike MO_V_Insert here y/dst can overlap. then toOL [ MOV (OpReg W128 tmp) (OpReg W128 reg_x) , INS format (OpVecLane w tmp index) (OpScalarAsVec w reg_y) , MOV (OpReg W128 dst) (OpReg W128 tmp) @@ -1886,36 +1885,87 @@ isAArch64Bitmask width n = hasOneRun m = 64 == popCount m + countLeadingZeros m + countTrailingZeros m +-------------------------------------------------------------------------------- +-- Helpers to help enforcing Note [Subword operations on AArch64] +-------------------------------------------------------------------------------- + -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@. -signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) -signExtendReg w w' r = - case w of - W64 -> noop - W32 - | w' == W32 -> noop - | otherwise -> extend SXTW - W16 -> extend SXTH - W8 -> extend SXTB - _ -> panic "intOp" +signExtendInstr :: Width -> Width -> Reg -> Maybe (Reg -> Instr) +signExtendInstr w w' r = + case (w,w') of + (W64,_) -> Nothing + (W32,W32) -> Nothing + (W32,_) -> extend SXTW + (W16,_) -> extend SXTH + (W8 ,_) -> extend SXTB + _ -> panic "signExtendInstr:unexpectedWidth" + where + extend instr = Just $ \r' -> instr (OpReg w' r') (OpReg w r) + +-- | Sign extend the register if needed, otherwise use register as-is +signExtendRegister :: Width -> Width -> Register -> Register +signExtendRegister w w' register = case register of + Fixed _fmt reg code -> + maybe register + (\instr_ext -> Any (intFormat w') (\dst -> code `snocOL` instr_ext dst) ) + (signExtendInstr w w' reg) + Any _fmt code -> + Any (intFormat w') $ \dst -> + maybe (code dst) + (\instr_ext -> code dst `snocOL` instr_ext dst) + (signExtendInstr w w' dst) + +truncSubwordRegInstr :: Width -> Reg -> Maybe (Reg -> Instr) +truncSubwordRegInstr w_to r = + case w_to of + -- Asserted false, but be defensive for non-debug builds. + W64 -> Nothing + W32 -> Nothing + + -- Actual truncation + W16 -> trunc W32 UXTH + W8 -> trunc W32 UXTB + _ -> panic "truncateSubwordReg:unexpectedWidth" where - noop = return (r, nilOL) - extend instr = do - r' <- getNewRegNat (intFormat w') - return (r', unitOL $ instr (OpReg w' r') (OpReg w r)) - --- | Instructions to truncate the value in the given register from width @w@ --- down to width @w'@. -truncateReg :: Width -> Width -> Reg -> OrdList Instr -truncateReg w w' r = - case w of + trunc w instr = do + Just $ \r' -> instr (OpReg w r') (OpReg w r) + +-- | Like @truncateSubwordRegister@, but modifes the given argument register in place if we +-- need to truncate. +truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr +truncateSubwordRegInplace w_to r = do + case w_to of W64 -> nilOL - W32 - | w' == W32 -> nilOL - _ -> unitOL $ UBFM (OpReg w r) - (OpReg w r) - (OpImm (ImmInt 0)) - (OpImm $ ImmInt $ widthInBits w' - 1) + W32 -> nilOL + W16 -> trunc UXTH + W8 -> trunc UXTB + _ -> panic "truncateSubwordRegInplace:unexpectedWidth" + where + trunc instr = do + unitOL $ instr (OpReg W32 r) (OpReg W32 r) + +-- | Zeros the high words of the value represented by Register if needed according to +-- Note [Subword operations on AArch64] +truncateSubwordRegister :: Width -> Register -> Register +truncateSubwordRegister w register = case register of + Fixed _fmt reg code -> + maybe (swizzleRegisterRep register (intFormat w)) + (\r_instr -> Any (intFormat w) (\dst -> code `snocOL` r_instr dst)) + (truncSubwordRegInstr w reg) + Any _fmt code -> Any (intFormat w) $ \dst -> + maybe (code dst) (\r_inst -> code dst `snocOL` r_inst dst) (truncSubwordRegInstr w dst) + +data SetsHighBits = UnknownHighBits | CleanHighBits + +maintainHighBits :: SetsHighBits -> Width -> Register -> Register +maintainHighBits CleanHighBits _w x = x +maintainHighBits UnknownHighBits w x = truncateSubwordRegister w x + +-- Reinterpret the value in the register as different format. +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. @@ -2038,27 +2088,24 @@ genCondJump bid expr = do -- Generic case. CmmMachOp mop [x, y] -> do - let ubcond w cmp = do - -- compute both sides. - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y - let x' = OpReg w reg_x - y' = OpReg w reg_y - return $ case w of - W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - - sbcond w cmp = do - -- compute both sides. - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y + let icond is_signed w cmp = do + -- zero or sign extend the argument register(s) + let extend reg = + if is_signed + then someReg $ signExtendRegister w (opRegWidth w) reg + else someReg reg + + (reg_x, _format_x, code_x) <- extend =<< getRegister x + (reg_y, _format_y, code_y) <- extend =<< getRegister y + let x' = OpReg w reg_x y' = OpReg w reg_y - return $ case w of - W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + + return $ concatOL [code_x, code_y, + toOL [CMP x' y', (annExpr expr (BCOND cmp (TBlock bid)))]] + + let ubcond w cmp = icond False w cmp + sbcond w cmp = icond True w cmp fbcond w cmp = do -- ensure we get float regs @@ -2327,32 +2374,27 @@ genCCall target dest_regs arg_regs = do , [src_a, src_b] <- arg_regs , [dst_needed, dst_hi, dst_lo] <- dest_regs -> do - (reg_a', _format_x, code_a) <- getSomeReg src_a - (reg_b', _format_y, code_b) <- getSomeReg src_b + -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm). + -- sign extension always allocates a fresh temp for w < W32, + -- and is a noop for W32 (safe: SMULL reads both sources + -- atomically before writing the destination). + (reg_a, _format_x, code_a) <- someReg =<< signExtendRegister w W32 <$> getRegister src_a + (reg_b, _format_y, code_b) <- someReg =<< signExtendRegister w W32 <$> getRegister src_b let lo = getRegisterReg platform (CmmLocal dst_lo) hi = getRegisterReg platform (CmmLocal dst_hi) nd = getRegisterReg platform (CmmLocal dst_needed) w' = platformWordWidth platform - -- Sign-extend inputs to W32 for SMULL (Xd = Wn * Wm). - -- signExtendReg always allocates a fresh temp for w < W32, - -- and is a noop for W32 (safe: SMULL reads both sources - -- atomically before writing the destination). - (reg_a, code_a') <- signExtendReg w W32 reg_a' - (reg_b, code_b') <- signExtendReg w W32 reg_b' - return $ code_a `appOL` - code_b `appOL` - code_a' `appOL` - code_b' `snocOL` + code_b `snocOL` -- SMULL Xd, Wn, Wm: multiply two W32 values producing a -- 64-bit result. The low w bits of lo contain the truncated -- product, and hi gets the overflow (sign extension bits). SMULL (OpReg w' lo) (OpReg W32 reg_a) (OpReg W32 reg_b) `snocOL` ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` - truncateReg w' w lo `snocOL` + truncateSubwordRegInplace w lo `snocOL` -- CMN (compare negative) tests hi + lo' == 0, i.e. hi == -lo'. -- lo' = LSR(lo, w-1) gives 1 if lo is negative, 0 if positive. -- No overflow iff hi is the sign extension of lo: @@ -2362,7 +2404,7 @@ genCCall target dest_regs arg_regs = do -- NE to set nd = 1 when overflow occurred. CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` CSET (OpReg w' nd) NE `appOL` - truncateReg w' w hi + truncateSubwordRegInplace w hi -- Can't handle > 64 bit operands | otherwise -> unsupported (MO_S_Mul2 w) PrimTarget (MO_U_Mul2 w) @@ -2385,7 +2427,7 @@ genCCall target dest_regs arg_regs = do ) -- For sizes < platform width, we can just perform a multiply and shift -- Need to be careful to truncate the low half, but the upper half should be - -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained. + -- be ok if the invariant in Note [Subword operations on AArch64] is maintained. -- Currently this case can't be produced by the compiler since -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #) -- TODO: Remove? Or would the extra primop be useful for avoiding the extra @@ -2412,7 +2454,7 @@ genCCall target dest_regs arg_regs = do (OpImm (ImmInt $ widthInBits w)) -- lsb (OpImm (ImmInt $ widthInBits w)) -- width to extract `appOL` - truncateReg W64 w lo + truncateSubwordRegInplace w lo ) | otherwise -> unsupported (MO_U_Mul2 w) PrimTarget (MO_Clz w) @@ -2730,6 +2772,7 @@ genCCall target dest_regs arg_regs = do | [p_reg, val_reg] <- arg_regs -> do (p, _fmt_p, code_p) <- getSomeReg p_reg (val, fmt_val, code_val) <- getSomeReg val_reg + massert (fmt_val == intFormat w) let instr = case ord of MemOrderRelaxed -> STR _ -> STLR @@ -2845,6 +2888,7 @@ genCCall target dest_regs arg_regs = do W16 -> SXTH (OpReg W64 gpReg) (OpReg w r) _ -> panic "impossible" | otherwise + -- Relies on Note [Subword operations on AArch64] = MOV (OpReg w gpReg) (OpReg w r) accumCode' = accumCode `appOL` code_r `snocOL` @@ -2898,6 +2942,7 @@ genCCall target dest_regs arg_regs = do passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + -- readResults gpArgs fpArgs dest_regs reg_acc code_acc readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock) readResults _ _ [] _ accumCode = return accumCode readResults [] _ _ _ _ = do @@ -2915,7 +2960,14 @@ genCCall target dest_regs arg_regs = do r_dst = getRegisterReg platform (CmmLocal dst) if isFloatFormat format || isVecFormat format then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) - else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)) + else do + -- Needed, ffi calls can return garbage in high bits. + -- See Note [Subword operations on AArch64] + let !mov_instr = case w of + W8 -> UXTB + W16 -> UXTH + _ -> MOV + readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` mov_instr (OpReg w r_dst) (OpReg w gpReg)) unaryFloatOp w op arg_reg dest_reg = do platform <- getPlatform ===================================== compiler/GHC/CmmToAsm/AArch64/Instr.hs ===================================== @@ -771,7 +771,8 @@ data Instr | MOVZ Operand Operand | MVN Operand Operand -- rd = ~rn | ORR Format Operand Operand Operand -- rd = rn | op2 - -- Load and stores. + -- Load and stores, we support subwords by picking the subword variant + -- based on the format. -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register. | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr ===================================== compiler/GHC/CmmToAsm/AArch64/Ppr.hs ===================================== @@ -569,12 +569,8 @@ pprInstr platform instr = case instr of -- NOTE: GHC may do whacky things where it only load the lower part of an -- address. Not observing the correct size when loading will lead -- inevitably to crashes. - STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> - op2 (text "\tstrb") o1 o2 - STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> - op2 (text "\tstrh") o1 o2 - STR _f o1 o2 -> op2 (text "\tstr") o1 o2 - STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2 + STR f o1 o2 -> op2 (subword_suffix f $ text "\tstr") o1 o2 + STLR f o1 o2 -> op2 (subword_suffix f $ text "\tstlr") o1 o2 LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in @@ -622,12 +618,8 @@ pprInstr platform instr = case instr of op_adrp o1 adrp' $$ op_add o1 ldr' - LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> - op2 (text "\tldrb") o1 o2 - LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> - op2 (text "\tldrh") o1 o2 - LDR _f o1 o2 -> op2 (text "\tldr") o1 o2 - LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2 + LDR f o1 o2 -> op2 (subword_suffix f $ text "\tldr") o1 o2 + LDAR f o1 o2 -> op2 (subword_suffix f $ text "\tldar") o1 o2 -- 8. Synchronization Instructions ------------------------------------------- DMBISH DmbLoadStore -> line $ text "\tdmb ish" @@ -698,6 +690,12 @@ pprInstr platform instr = case instr of check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit" + -- Some instructions encode subword ops via b/h suffix on the instruction. + -- We handle this here relying on the format rather than the operands. + subword_suffix II8 t = t <> char 'b' + subword_suffix II16 t = t <> char 'h' + subword_suffix _ t = t + pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c ===================================== testsuite/tests/cmm/should_compile/Makefile ===================================== @@ -16,16 +16,3 @@ T16930: T23610: '$(TEST_HC)' $(TEST_HC_OPTS) T23610.cmm -S - -# The three seds below, in order: -# 1. Keep only the "Parsed Cmm" dump, since that is the one stage where the -# unreachable block still exists. -# 2. Rewrite goto targets: their label uniques survive -dsuppress-uniques -# (#21310). -# 3. Drop the "// CmmAssign"-style node annotations, which pprNode emits -# only on DEBUG compilers. -T27368-ppr-debug: - '$(TEST_HC)' $(TEST_HC_OPTS) -c -no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug -dsuppress-uniques -dsuppress-ticks T27368-ppr-debug.cmm 2>&1 \ - | sed -n '/^==* Parsed Cmm/,/^ \}\]/p' \ - | sed 's/goto c[0-9A-Za-z]*/goto _lbl_/g' \ - | sed 's| *// Cmm[A-Za-z]*$$||' ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr ===================================== @@ -0,0 +1,191 @@ + +==================== Parsed Cmm ==================== +[testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + goto c6; + c6: // global + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + goto c3; + c3: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + // unreachable blocks: + c5: // global + //tick src<T27368-ppr-debug.cmm:13:5-13> + _c1::I64 = _c1::I64 (+[W64]) 42; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + } + }] + + + +==================== Post control-flow optimisations (1) ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== Post switch plan ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== ThreadSanitizer instrumentation ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== Layout Stack ==================== +testUnreachable +{offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; +} + + + +==================== CAFEnv ==================== +[(c2, {}), (c4, {}), (c7, {})] + + + +==================== after setInfoTableStackMap ==================== +testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } +} + + + +==================== Post control-flow optimisations (2) ==================== +testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } +} + + + +==================== Post CPS Cmm ==================== +[testUnreachable() { // [R1] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + c7: // global + _c1::I64 = R1; + //tick src<T27368-ppr-debug.cmm:(6,1)-(19,1)> + if (_c1::I64 (>[W64]) 0) goto c2; else goto c4; + c2: // global + //tick src<T27368-ppr-debug.cmm:(7,14)-(9,3)> + //tick src<T27368-ppr-debug.cmm:17:5-12> + _c1::I64 = _c1::I64 (-[W64]) 1; + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + c4: // global + R1 = _c1::I64; + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; + } + }] + + ===================================== testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout deleted ===================================== @@ -1,27 +0,0 @@ -==================== Parsed Cmm ==================== -[testUnreachable() { // [R1] - { info_tbls: [] - stack_info: arg_space: 8 - } - {offset - _lbl_: - __locVar_::I64 = R1; - if (__locVar_::I64 > 0) goto _lbl_; else goto _lbl_; - _lbl_: - goto _lbl_; - _lbl_: - __locVar_::I64 = __locVar_::I64 - 1; - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - _lbl_: - goto _lbl_; - _lbl_: - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - // unreachable blocks: - _lbl_: - __locVar_::I64 = __locVar_::I64 + 42; - R1 = __locVar_::I64; - call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; - } - }] ===================================== testsuite/tests/cmm/should_compile/all.T ===================================== @@ -13,11 +13,9 @@ test('T20725', normal, compile, ['-package ghc']) test('T23610', normal, makefile_test, ['T23610']) test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1]), only_ways(['normal'])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques']) test('T24474', cmm_src, compile, ['-optc-g3']) -# -dppr-debug makes stored-but-unreachable blocks visible in Cmm dumps (#27368). -# Skipped on wordsize(32) targets, where the dump would say I32/P32, and on -# unregisterised builds, which print call targets with an extra load. -test('T27368-ppr-debug', [when(wordsize(32), skip), when(unregisterised(), skip)], - makefile_test, ['T27368-ppr-debug']) +# Grep for a `... = + .. 42 ..;` occurence from within the dead code block in the cmm dump output. +test('T27368-ppr-debug', [cmm_src, only_ways(['normal']), grep_errmsg(r'\=.*\+.*(42;)', [1])], + compile, ['-no-hs-main -ddump-cmm-verbose-by-proc -dppr-debug']) test('T24474-cmm-gets-c-opts', cmm_src, compile, ['-optc-DFOO']) test('T24474-cmm-opt-order', cmm_src, compile, ['-optc-DFOO ' '-optCmmP-UFOO ' ===================================== testsuite/tests/codeGen/should_run/T27430.hs ===================================== @@ -0,0 +1,44 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Data.Bits +import GHC.Word + +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8 +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word16 +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word32 + +x :: Word64 +x = 5 + +-- Those should give just x when truncated. +y8,y16,y32 :: Word64 +y8 = setBit x 8 +y16 = setBit x 16 +y32 = setBit x 32 + +eq8 :: Word8 -> Word8 -> Int +eq8 (W8# a) (W8# b) = I# (eqWord8# a b) + +eq16 :: Word16 -> Word16 -> Int +eq16 (W16# a) (W16# b) = I# (eqWord16# a b) + +eq32 :: Word32 -> Word32 -> Int +eq32 (W32# a) (W32# b) = I# (eqWord32# a b) + +{-# NOINLINE outline_eq8 #-} +outline_eq8 = eq8 +{-# NOINLINE outline_eq16 #-} +outline_eq16 = eq16 +{-# NOINLINE outline_eq32 #-} +outline_eq32 = eq32 + +main :: IO () +main = do + print (eq8 (u64_to_u8 x) (u64_to_u8 y8)) + print (eq16 (u64_to_u16 x) (u64_to_u16 y16)) + print (eq32 (u64_to_u32 x) (u64_to_u32 y32)) + + print (outline_eq8 (u64_to_u8 x) (u64_to_u8 y8)) + print (outline_eq16 (u64_to_u16 x) (u64_to_u16 y16)) + print (outline_eq32 (u64_to_u32 x) (u64_to_u32 y32)) ===================================== testsuite/tests/codeGen/should_run/T27430.stdout ===================================== @@ -0,0 +1,6 @@ +1 +1 +1 +1 +1 +1 ===================================== testsuite/tests/codeGen/should_run/T27430_c.c ===================================== @@ -0,0 +1,5 @@ +#include <stdint.h> + +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; } +uint16_t u64_to_u16(uint64_t v) { return (uint16_t)v; } +uint32_t u64_to_u32(uint64_t v) { return (uint32_t)v; } ===================================== testsuite/tests/codeGen/should_run/T27533.hs ===================================== @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes #-} + +import GHC.Exts +import GHC.IO (IO(..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Ptr (Ptr(..)) +import Data.Word (Word8) +import Numeric (showHex) +import System.IO + +foreign import prim "store8" store8# :: Addr# -> Word# +foreign import prim "load8" load8# :: Addr# -> Word# + +-- Read one byte at a given byte offset. Working a byte at a time keeps the +-- test independent of both endianness and word size: the buffer contents are +-- a fixed sequence of bytes in address order, whereas a word-sized read of +-- the same buffer would give 0x..43 on little-endian and 0x43.. on big-endian. +readByte :: Addr# -> Int -> IO Word +readByte a (I# i) = + IO (\s -> case readWord8OffAddr# a i s of + (# s', v #) -> (# s', W# (word8ToWord# v) #)) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + allocaBytes 8 $ \p@(Ptr a) -> do + -- 1. Silent corruption: release-store of 1 byte into an all-ones buffer. + -- The store must touch byte 0 and leave bytes 1..7 alone; a buggy NCG + -- widens it to a 4-byte store and zeroes bytes 1..3. + fillBytes p (0xFF :: Word8) 8 + case store8# a of _ -> return () -- case on unlifted Word# forces the call + bs <- mapM (readByte a) [0 .. 7] + putStrLn ("after 1-byte release-store: " ++ unwords (map (\b -> showHex b "") bs)) + -- expected 43 ff ff ff ff ff ff ff + -- buggy NCG gives 43 0 0 0 ff ff ff ff + + -- 2. SIGBUS: acquire-load of 1 byte at an odd address (well-defined). + r <- IO (\s -> (# s, W# (load8# (a `plusAddr#` 1#)) #)) + putStrLn ("acquire byte load at p+1: 0x" ++ showHex r "") + -- expected 0xff; buggy NCG dies with SIGBUS before printing ===================================== testsuite/tests/codeGen/should_run/T27533.stdout ===================================== @@ -0,0 +1,2 @@ +after 1-byte release-store: 43 ff ff ff ff ff ff ff +acquire byte load at p+1: 0xff ===================================== testsuite/tests/codeGen/should_run/T27533_cmm.cmm ===================================== @@ -0,0 +1,14 @@ +#include "Cmm.h" + +// Release-store one byte at p. Must touch exactly 1 byte. +store8 (W_ p) { + %release I8[p] = 67 :: I8; + return (0); +} + +// Acquire-load one byte from p. +load8 (W_ p) { + I8 v; + v = %acquire I8[p]; + return (TO_ZXW_(v)); +} ===================================== testsuite/tests/codeGen/should_run/T27537.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE lt8 #-} +lt8 :: Int -> Word -> Int -- ltWord8# 254 255: must be 1 +lt8 (I# m) (W# n) = I# (ltWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eq8 #-} +eq8 :: Int -> Word -> Int -- eqWord8# 254 254: must be 1 +eq8 (I# m) (W# n) = I# (eqWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n)) + +{-# NOINLINE eqi16 #-} +eqi16 :: Int -> Int -> Int -- eqInt16# (-2) (-2): must be 1 +eqi16 (I# m) (I# n) = I# (eqInt16# (intToInt16# m) (word16ToInt16# (wordToWord16# (int2Word# n)))) + +{-# NOINLINE rem8 #-} +rem8 :: Int -> Word -> Word -- remWord8# 254 100: must be 54 +rem8 (I# m) (W# n) = W# (word8ToWord# (remWord8# (int8ToWord8# (intToInt8# m)) (wordToWord8# n))) + +main :: IO () +main = do + print (lt8 (-2) 255) + print (eq8 (-2) 254) + print (eqi16 (-2) 65534) + print (rem8 (-2) 100) ===================================== testsuite/tests/codeGen/should_run/T27537.stdout ===================================== @@ -0,0 +1,4 @@ +1 +1 +1 +54 ===================================== testsuite/tests/codeGen/should_run/T27538.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +{-# NOINLINE ix #-} +ix :: Int +ix = 0 + +{-# NOINLINE f #-} +f :: Int8# -> Int# +f x = if isTrue# (x `ltInt8#` intToInt8# 0#) + then (int8ToWord8# x) `gtWord8#` wordToWord8# 200## + else 1# + +main :: IO () +main = do + -- Test for use of byte-width read. + let !(I# i) = ix + x = indexInt8OffAddr# "\x80"# i + putStrLn ("f(0x80) = " ++ show (I# (f x))) ===================================== testsuite/tests/codeGen/should_run/T27538.stdout ===================================== @@ -0,0 +1 @@ +f(0x80) = 0 ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -295,3 +295,12 @@ test('aarch64-sxtw-run', when(unregisterised(), skip)], multi_compile_and_run, ['aarch64-sxtw-run', [('aarch64-sxtw-cmm.cmm', '')], '-O']) + +test('T27430', [req_c, extra_ways(['optasm'])], compile_and_run, ['T27430_c.c']) + +test('T27533', [req_cmm, extra_ways(['optasm'])], multi_compile_and_run, + ['T27533', [('T27533_cmm.cmm', '')], '-O']) + +test('T27537', normal, compile_and_run, ['-O']) + +test('T27538', normal, compile_and_run, ['-O']) ===================================== testsuite/tests/simd/should_run/T27565.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Main (main) where +import GHC.Exts +import GHC.Int (Int8(..), Int16(..), Int32(..), Int64(..)) + +{-# OPAQUE broadcast_i8 #-} +broadcast_i8 :: Int8# -> Int8X16# +broadcast_i8 x = broadcastInt8X16# x + +{-# OPAQUE broadcast_i16 #-} +broadcast_i16 :: Int16# -> Int16X8# +broadcast_i16 x = broadcastInt16X8# x + +{-# OPAQUE broadcast_i32 #-} +broadcast_i32 :: Int32# -> Int32X4# +broadcast_i32 x = broadcastInt32X4# x + +{-# OPAQUE broadcast_i64 #-} +broadcast_i64 :: Int64# -> Int64X2# +broadcast_i64 x = broadcastInt64X2# x + +main :: IO () +main = do + case unpackInt8X16# (broadcast_i8 (intToInt8# 32#)) of + (# a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15 #) -> + print [ I8# a0, I8# a1, I8# a2, I8# a3, I8# a4, I8# a5, I8# a6, I8# a7 + , I8# a8, I8# a9, I8# a10, I8# a11, I8# a12, I8# a13, I8# a14, I8# a15 ] + case unpackInt16X8# (broadcast_i16 (intToInt16# 32#)) of + (# b0,b1,b2,b3,b4,b5,b6,b7 #) -> + print [ I16# b0, I16# b1, I16# b2, I16# b3, I16# b4, I16# b5, I16# b6, I16# b7 ] + case unpackInt32X4# (broadcast_i32 (intToInt32# 32#)) of + (# c0,c1,c2,c3 #) -> + print [ I32# c0, I32# c1, I32# c2, I32# c3 ] + case unpackInt64X2# (broadcast_i64 (intToInt64# 32#)) of + (# d0,d1 #) -> + print [ I64# d0, I64# d1 ] ===================================== testsuite/tests/simd/should_run/T27565.stdout ===================================== @@ -0,0 +1,4 @@ +[32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32] +[32,32,32,32,32,32,32,32] +[32,32,32,32] +[32,32] ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -217,3 +217,5 @@ test('StackAlignment64' , compile_and_run if have_cpu_feature('avx512f') else compile , ['StackAlignment64_main.c'] ) + +test('T27565', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e60eb3bc61d55421adcf33ca39e8db… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e60eb3bc61d55421adcf33ca39e8db… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/improve-closure-property-check] 4 commits: Reuse the UnitIndexCache after initialising multiple home units
by Wolfgang Jeltsch (＠jeltsch) 26 Aug '26

26 Aug '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC Commits: 555b4614 by fendor at 2026-08-26T15:41:59+02:00 Reuse the UnitIndexCache after initialising multiple home units - - - - - da4f57bf by Wolfgang Jeltsch at 2026-08-26T21:15:55+03:00 Improve the `mhu-closure` makefile - - - - - 7f45fea4 by Wolfgang Jeltsch at 2026-08-26T21:17:28+03:00 Re-implement the home unit closure check Resolves #27051. - - - - - ad88ceb0 by Wolfgang Jeltsch at 2026-08-26T21:54:49+03:00 Adapt `mhu-closure` to the inclusion of implicitly used units - - - - - 9 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Index.hs - testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr - testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -54,7 +54,6 @@ import GHC.Runtime.Context import Language.Haskell.Syntax.ImpExp import GHC.Types.UnresolvedImport -import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.Maybe as M @@ -71,12 +70,14 @@ import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs import GHC.Utils.Constants +import GHC.Utils.Monad.State.Strict import GHC.Types.Error import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc +import GHC.Types.Unique.Set import GHC.Types.Unique.Map import GHC.Types.PkgQual import GHC.Types.Basic @@ -91,9 +92,12 @@ import GHC.Unit.Module.Graph import GHC.Unit.Module.Deps import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Module.Stage +import GHC.Unit.External.Index (GlobalUnitKey, mkGlobalUnitKey) import Data.Either ( partitionEithers, lefts ) +import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) import qualified Data.Set as Set import Control.Concurrent.MVar @@ -101,7 +105,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe -import Data.List (partition) +import Data.List (sort, partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first, bimap) @@ -933,52 +937,85 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do -- * Check/validate properties and error out -------------------------------------------------------------------------------- --- | This function checks then important property that if both p and q are home units --- then any dependency of p, which transitively depends on q is also a home unit. --- --- See Note [Multiple Home Units], section 'Closure Property'. -checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] -checkHomeUnitsClosed ue - | Set.null bad_unit_ids = [] - | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] +-- | Checks whether the given unit environment has the closure property. See +-- the section “Closure Property” in @Note [Multiple Home Units]@. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed unit_env + | null offenders = [] + | otherwise = [ + singleMessage $ + mkPlainErrorMsgEnvelope error_source_span $ + DriverHomePackagesNotClosed (sort offenders) + ] where - home_id_set = HUG.allUnits $ ue_home_unit_graph ue - bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") - downwards_closure :: Graph (Node UnitId UnitId) - downwards_closure = graphFromEdgedVerticesUniq graphNodes + home_unit_data :: [(UnitId, HomeUnitEnv)] + home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env) - inverse_closure = graphReachability $ transposeG downwards_closure + home_units :: UniqSet UnitId + home_units = mkUniqSet (map fst home_unit_data) - upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + offenders :: [(UnitId, UnitId)] + offenders + = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data)) $ + Set.empty + where - all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) - all_unit_direct_deps - = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + collect :: [UnitState] -> State (Set GlobalUnitKey) [(UnitId, UnitId)] + collect [] + = pure [] + collect (current_unit_state : remaining_unit_states) + = (++) <$> collect_for_home_unit + (unitInfoMap current_unit_state) + (map (toUnitId . fst) $ explicitUnits $ current_unit_state) + <*> collect remaining_unit_states where - go rest this this_uis = - plusUniqMap_C Set.union - (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) - rest - where - external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) - this_units = homeUnitEnv_units this_uis - this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go Set.empty home_id_set - where - go done todo - = case Set.minView todo of - Nothing -> [] - Just (uid, todo') - | Set.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends Set.\\ done) `Set.union` todo' - in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' + + collect_for_home_unit :: UnitInfoMap + -> [UnitId] + -> State (Set GlobalUnitKey) [(UnitId, UnitId)] + collect_for_home_unit _ [] + = return [] + collect_for_home_unit unit_info_map (current_unit : remaining_units) = do + let + + unit_info :: UnitInfo + unit_info + = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $ + lookupUniqMap unit_info_map current_unit + where + + unit_not_found_msg :: String + unit_not_found_msg = "Unit not found during closure property check" + + global_unit_key :: GlobalUnitKey + global_unit_key = mkGlobalUnitKey current_unit (unitAbiHash unit_info) + + has_been_processed <- gets (Set.member global_unit_key) + if has_been_processed + then collect_for_home_unit unit_info_map remaining_units + else do + modify (Set.insert global_unit_key) + let + + needed_units :: [UnitId] + needed_units = unitDepends unit_info + + current_offenders :: [(UnitId, UnitId)] + current_offenders + | current_unit `elementOfUniqSet` home_units + = [] + | otherwise + = map ((,) current_unit) $ + nonDetEltsUniqSet $ + mkUniqSet needed_units `intersectUniqSets` home_units + + remaining_offenders <- collect_for_home_unit unit_info_map $ + needed_units ++ remaining_units + return $ current_offenders ++ remaining_offenders + + error_source_span :: SrcSpan + error_source_span = mkGeneralSrcSpan (fsLit "<command line>") -------------------------------------------------------------------------------- -- * Enable Code Gen for Template Haskell @@ -1763,7 +1800,7 @@ data NodeRes v -- -- See also Note [Downsweep Control Flow and Caching] dfsBuild :: (Ord k, Monad m) - => Maybe (Map.Map k (NodeRes v)) + => Maybe (Map k (NodeRes v)) -- ^ Base map, existing results. We won't re-expand any of the nodes -- already present in this map. -> [n] @@ -1773,7 +1810,7 @@ dfsBuild :: (Ord k, Monad m) -> (n -> m (NodeRes (v,[n]))) -- ^ Expand this node into its payload result and into the list of -- children nodes to visit next. - -> m (Map.Map k (NodeRes v)) + -> m (Map k (NodeRes v)) -- ^ The result accumulates the payload of expanding the root nodes -- and all nodes transitively reachable from those roots. dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map) ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -235,10 +235,17 @@ instance Diagnostic DriverMessage where "but no output will be generated.") $$ (text "There is no module named" <+> quotes (ppr mod_name) <> text ".")) - DriverHomePackagesNotClosed needed_unit_ids - -> mkSimpleDecorated $ vcat ([text "Home units are not closed." - , text "It is necessary to also load the following units:" ] - ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverHomePackagesNotClosed offending_dependencies + -> mkSimpleDecorated $ + hang (text "Some units are not loaded but depend on loaded units.") + 4 + (vcat (map pprDependency offending_dependencies)) + where + + pprDependency :: (UnitId, UnitId) -> SDoc + pprDependency (external_unit, home_unit) + = ppr external_unit <+> arrow <+> ppr home_unit + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason DriverInconsistentDynFlags msg ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -369,7 +369,7 @@ data DriverMessage where DriverRedirectedNoMain :: !ModuleName -> DriverMessage - DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage DriverInterfaceError :: !IfaceMessage -> DriverMessage ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -145,8 +145,15 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkUnitCycles initial_dflags home_unit_graph let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph - unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + newUnitEnv <- do + env <- liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) + -- We need to reuse the 'UnitIndexCache' as we used it above in 'initUnits'. + -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] why this must be shared. + pure $ assertUnitEnvInvariant $ env + { ue_uic = hscUIC hsc_env + } + + let final_hsc_env = hsc_env { hsc_unit_env = newUnitEnv } GHC.setSession final_hsc_env ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -443,13 +443,11 @@ The flow: Closure Property ---------------- -You must perform a clean cut of the dependency graph. - -> Any dependency which is not a home unit must not (transitively) depend on a home unit. - -For example, if you have three packages p, q and r, then if p depends on q which -depends on r then it is illegal to load both p and r as home units but not q, -because q is a dependency of the home unit p which depends on another home unit r. +A unit environment must have the closure property, which means that, whenever +some units @h₁@ and @h₂@ have been loaded as home units, @h₁@ does not directly +or indirectly depend on an external unit that directly or indirectly depends +on @h₂@. 'GHC.Driver.Downsweep.checkHomeUnitsClosed' checks whether a given unit +environment indeed has this property. Offsetting Paths ---------------- ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -308,6 +308,7 @@ data GlobalUnitKey = GlobalUnitKey !UnitId -- ^ Unit Id of the 'UnitInfo' !UnitAbiHash -- ^ ABI hash of the 'UnitInfo' + deriving (Eq, Ord) globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile ===================================== @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk SETUP=../Setup -v0 +CONFIGURE=configure \ + $(CABAL_MINIMAL_BUILD) \ + --with-ghc='$(TEST_HC)' \ + --with-hc-pkg='$(GHC_PKG)' \ + --ghc-options='$(TEST_HC_OPTS)' \ + --package-db=../tmp.d +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp +ONLY_BASE=-hide-all-packages -package base -mhu-closure: clean - $(MAKE) -s --no-print-directory clean +mhu-closure: clean pkg-database + ! $(TEST_BUILD) -unit @unitP + ! $(TEST_BUILD) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) -unit @unitP -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitR1 + $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR + ! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR + ! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1 + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR + $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1 + +.PHONY: pkg-database +pkg-database: '$(GHC_PKG)' init tmp.d '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup - cd p && $(SETUP) clean - cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0 cd p && $(SETUP) build cd p && $(SETUP) register --inplace - cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=q-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0 cd q && $(SETUP) build cd q && $(SETUP) register --inplace - cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=r-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0 cd r && $(SETUP) build cd r && $(SETUP) register --inplace - # This should work - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ - # So should this - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR - # This should error with a closure message - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR - # This should work, even though r1 is not in the package db - '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1 - # This should fail, even though r1 is not in the package db - ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1 +.PHONY: clean +clean: + $(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o ifeq "$(CLEANUP)" "1" $(MAKE) -s --no-print-directory clean endif - -clean : - $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) - ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr ===================================== @@ -1,10 +1,28 @@ <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 <command line>: error: [GHC-03271] - Home units are not closed. - It is necessary to also load the following units: - - q-0.1.0.0 + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + r-0.1.0.0 -> q-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 + +<command line>: error: [GHC-03271] + Some units are not loaded but depend on loaded units. + q-0.1.0.0 -> p-0.1.0.0 ===================================== testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout ===================================== @@ -1,3 +1,6 @@ +[1 of 3] Compiling P[p-0.1.0.0] +[2 of 3] Compiling Q[q-0.1.0.0] +[3 of 3] Compiling R[r-0.1.0.0] [1 of 1] Compiling P [1 of 2] Compiling P[p-0.1.0.0] [2 of 2] Compiling Q[q-0.1.0.0] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebd3f23d37929fe81704bafb51069d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebd3f23d37929fe81704bafb51069d… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0