July 2025 - ghc-commits

[Git][ghc/ghc][wip/romes/24212] Read Toolchain.Target files rather than 'settings'
by Rodrigo Mesquita (＠alt-romes) 14 Jul '25

14 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC Commits: 1ef14990 by Rodrigo Mesquita at 2025-07-14T14:07:14+01:00 Read Toolchain.Target files rather than 'settings' This commit makes GHC read `lib/targets/default.target`, a file with a serialized value of `ghc-toolchain`'s `GHC.Toolchain.Target`. Moreover, it removes all the now-redundant entries from `lib/settings` that are configured as part of a `Target` but were being written into `settings`. This makes it easier to support multiple targets from the same compiler (aka runtime retargetability). `ghc-toolchain` can be re-run many times standalone to produce a `Target` description for different targets, and, in the future, GHC will be able to pick at runtime amongst different `Target` files. This commit only makes it read the default `Target` configured in-tree or configured when installing the bindist. The remaining bits of `settings` need to be moved to `Target` in follow up commits, but ultimately they all should be moved since they are per-target relevant. Fixes #24212 - - - - - 26 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/SysTools/BaseDir.hs - compiler/ghc.cabal.in - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Base.hs - hadrian/src/Rules/Generate.hs - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − m4/fp_settings.m4 - m4/fp_setup_windows_toolchain.m4 - + m4/subst_tooldir.m4 - mk/hsc2hs.in - testsuite/tests/ghc-api/T20757.hs - testsuite/tests/ghc-api/settings-escape/T24265.hs - testsuite/tests/ghc-api/settings-escape/T24265.stderr - + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -145,6 +145,7 @@ import GHC.Foreign (withCString, peekCString) import qualified Data.Set as Set import qualified GHC.LanguageExtensions as LangExt +import GHC.Toolchain.Target (Target) -- ----------------------------------------------------------------------------- -- DynFlags @@ -178,6 +179,7 @@ data DynFlags = DynFlags { toolSettings :: {-# UNPACK #-} !ToolSettings, platformMisc :: {-# UNPACK #-} !PlatformMisc, rawSettings :: [(String, String)], + rawTarget :: Target, tmpDir :: TempDir, llvmOptLevel :: Int, -- ^ LLVM optimisation level @@ -656,6 +658,7 @@ defaultDynFlags mySettings = targetPlatform = sTargetPlatform mySettings, platformMisc = sPlatformMisc mySettings, rawSettings = sRawSettings mySettings, + rawTarget = sRawTarget mySettings, tmpDir = panic "defaultDynFlags: uninitialized tmpDir", ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -280,6 +280,9 @@ import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) +import GHC.Toolchain +import GHC.Toolchain.Program + import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -403,6 +406,7 @@ settings dflags = Settings , sToolSettings = toolSettings dflags , sPlatformMisc = platformMisc dflags , sRawSettings = rawSettings dflags + , sRawTarget = rawTarget dflags } pgm_L :: DynFlags -> String @@ -3454,9 +3458,58 @@ compilerInfo dflags -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the -- key) - : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) - (rawSettings dflags) - ++ [("Project version", projectVersion dflags), + : map (fmap expandDirectories) + (rawSettings dflags) + ++ + [("C compiler command", queryCmd $ ccProgram . tgtCCompiler), + ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler), + ("C++ compiler command", queryCmd $ cxxProgram . tgtCxxCompiler), + ("C++ compiler flags", queryFlags $ cxxProgram . tgtCxxCompiler), + ("C compiler link flags", queryFlags $ ccLinkProgram . tgtCCompilerLink), + ("C compiler supports -no-pie", queryBool $ ccLinkSupportsNoPie . tgtCCompilerLink), + ("CPP command", queryCmd $ cppProgram . tgtCPreprocessor), + ("CPP flags", queryFlags $ cppProgram . tgtCPreprocessor), + ("Haskell CPP command", queryCmd $ hsCppProgram . tgtHsCPreprocessor), + ("Haskell CPP flags", queryFlags $ hsCppProgram . tgtHsCPreprocessor), + ("JavaScript CPP command", queryCmdMaybe jsCppProgram tgtJsCPreprocessor), + ("JavaScript CPP flags", queryFlagsMaybe jsCppProgram tgtJsCPreprocessor), + ("C-- CPP command", queryCmd $ cmmCppProgram . tgtCmmCPreprocessor), + ("C-- CPP flags", queryFlags $ cmmCppProgram . tgtCmmCPreprocessor), + ("C-- CPP supports -g0", queryBool $ cmmCppSupportsG0 . tgtCmmCPreprocessor), + ("ld supports compact unwind", queryBool $ ccLinkSupportsCompactUnwind . tgtCCompilerLink), + ("ld supports filelist", queryBool $ ccLinkSupportsFilelist . tgtCCompilerLink), + ("ld supports single module", queryBool $ ccLinkSupportsSingleModule . tgtCCompilerLink), + ("ld is GNU ld", queryBool $ ccLinkIsGnu . tgtCCompilerLink), + ("Merge objects command", queryCmdMaybe mergeObjsProgram tgtMergeObjs), + ("Merge objects flags", queryFlagsMaybe mergeObjsProgram tgtMergeObjs), + ("Merge objects supports response files", queryBool $ maybe False mergeObjsSupportsResponseFiles . tgtMergeObjs), + ("ar command", queryCmd $ arMkArchive . tgtAr), + ("ar flags", queryFlags $ arMkArchive . tgtAr), + ("ar supports at file", queryBool $ arSupportsAtFile . tgtAr), + ("ar supports -L", queryBool $ arSupportsDashL . tgtAr), + ("ranlib command", queryCmdMaybe ranlibProgram tgtRanlib), + ("otool command", queryCmdMaybe id tgtOtool), + ("install_name_tool command", queryCmdMaybe id tgtInstallNameTool), + ("windres command", queryCmd $ fromMaybe (Program "/bin/false" []) . tgtWindres), + ("cross compiling", queryBool (not . tgtLocallyExecutable)), + ("target platform string", query targetPlatformTriple), + ("target os", query (show . archOS_OS . tgtArchOs)), + ("target arch", query (show . archOS_arch . tgtArchOs)), + ("target word size", query $ show . wordSize2Bytes . tgtWordSize), + ("target word big endian", queryBool $ (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness), + ("target has GNU nonexec stack", queryBool tgtSupportsGnuNonexecStack), + ("target has .ident directive", queryBool tgtSupportsIdentDirective), + ("target has subsections via symbols", queryBool tgtSupportsSubsectionsViaSymbols), + ("Unregisterised", queryBool tgtUnregisterised), + ("LLVM target", query tgtLlvmTarget), + ("LLVM llc command", queryCmdMaybe id tgtLlc), + ("LLVM opt command", queryCmdMaybe id tgtOpt), + ("LLVM llvm-as command", queryCmdMaybe id tgtLlvmAs), + ("LLVM llvm-as flags", queryFlagsMaybe id tgtLlvmAs), + ("Tables next to code", queryBool tgtTablesNextToCode), + ("Leading underscore", queryBool tgtSymbolsHaveLeadingUnderscore) + ] ++ + [("Project version", projectVersion dflags), ("Project Git commit id", cProjectGitCommitId), ("Project Version Int", cProjectVersionInt), ("Project Patch Level", cProjectPatchLevel), @@ -3513,9 +3566,16 @@ compilerInfo dflags showBool False = "NO" platform = targetPlatform dflags isWindows = platformOS platform == OSMinGW32 - useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags - expandDirectories :: FilePath -> Maybe FilePath -> String -> String - expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd + expandDirectories = expandToolDir (toolDir dflags) . expandTopDir (topDir dflags) + query :: (Target -> a) -> a + query f = f (rawTarget dflags) + queryFlags f = query (unwords . map escapeArg . prgFlags . f) + queryCmd f = expandDirectories (query (prgPath . f)) + queryBool = showBool . query + + queryCmdMaybe, queryFlagsMaybe :: (a -> Program) -> (Target -> Maybe a) -> String + queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f)) + queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f) -- Note [Special unit-ids] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -3843,3 +3903,19 @@ updatePlatformConstants dflags mconstants = do let platform1 = (targetPlatform dflags) { platform_constants = mconstants } let dflags1 = dflags { targetPlatform = platform1 } return dflags1 + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== compiler/GHC/Settings.hs ===================================== @@ -23,7 +23,6 @@ module GHC.Settings , sMergeObjsSupportsResponseFiles , sLdIsGnuLd , sGccSupportsNoPie - , sUseInplaceMinGW , sArSupportsDashL , sPgm_L , sPgm_P @@ -75,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform import GHC.Unit.Types +import GHC.Toolchain.Target data Settings = Settings { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion @@ -87,6 +87,10 @@ data Settings = Settings -- You shouldn't need to look things up in rawSettings directly. -- They should have their own fields instead. , sRawSettings :: [(String, String)] + + -- Store the target to print out information about the raw target description + -- (e.g. in --info) + , sRawTarget :: Target } data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId } @@ -102,7 +106,6 @@ data ToolSettings = ToolSettings , toolSettings_mergeObjsSupportsResponseFiles :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool - , toolSettings_useInplaceMinGW :: Bool , toolSettings_arSupportsDashL :: Bool , toolSettings_cmmCppSupportsG0 :: Bool @@ -221,8 +224,6 @@ sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings -sUseInplaceMinGW :: Settings -> Bool -sUseInplaceMinGW = toolSettings_useInplaceMinGW . sToolSettings sArSupportsDashL :: Settings -> Bool sArSupportsDashL = toolSettings_arSupportsDashL . sToolSettings ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -1,4 +1,4 @@ - +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,18 +16,20 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic -import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir import GHC.Unit.Types import Control.Monad.Trans.Except import Control.Monad.IO.Class -import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory +import GHC.Toolchain.Program +import GHC.Toolchain +import GHC.Data.Maybe +import Data.Bifunctor (Bifunctor(second)) data SettingsError = SettingsError_MissingData String @@ -44,6 +46,7 @@ initSettings top_dir = do libexec :: FilePath -> FilePath libexec file = top_dir </> ".." </> "bin" </> file settingsFile = installed "settings" + targetFile = installed $ "targets" </> "default.target" readFileSafe :: FilePath -> ExceptT SettingsError m String readFileSafe path = liftIO (doesFileExist path) >>= \case @@ -55,85 +58,72 @@ initSettings top_dir = do Just s -> pure s Nothing -> throwE $ SettingsError_BadData $ "Can't parse " ++ show settingsFile + targetStr <- readFileSafe targetFile + target <- case maybeReadFuzzy @Target targetStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse as Target " ++ show targetFile let mySettings = Map.fromList settingsList getBooleanSetting :: String -> ExceptT SettingsError m Bool getBooleanSetting key = either pgmError pure $ getRawBooleanSetting settingsFile mySettings key - -- On Windows, by mingw is often distributed with GHC, - -- so we look in TopDir/../mingw/bin, - -- as well as TopDir/../../mingw/bin for hadrian. - -- But we might be disabled, in which we we don't do that. - useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain" - -- see Note [topdir: How GHC finds its files] -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated - mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir + mtool_dir <- liftIO $ findToolDir top_dir -- see Note [tooldir: How GHC finds mingw on Windows] - -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally - -- introduce unescaped spaces. See #24265 and #25204. - let escaped_top_dir = escapeArg top_dir - escaped_mtool_dir = fmap escapeArg mtool_dir - - getSetting_raw key = either pgmError pure $ + let getSetting_raw key = either pgmError pure $ getRawSetting settingsFile mySettings key getSetting_topDir top key = either pgmError pure $ getRawFilePathSetting top settingsFile mySettings key getSetting_toolDir top tool key = - expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key - - getSetting :: String -> ExceptT SettingsError m String + expandToolDir tool <$> getSetting_topDir top key getSetting key = getSetting_topDir top_dir key - getToolSetting :: String -> ExceptT SettingsError m String getToolSetting key = getSetting_toolDir top_dir mtool_dir key - getFlagsSetting :: String -> ExceptT SettingsError m [String] - getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key - -- Make sure to unescape, as we have escaped top_dir and tool_dir. + + expandDirVars top tool = expandToolDir tool . expandTopDir top + + getToolPath :: (Target -> Program) -> String + getToolPath key = expandDirVars top_dir mtool_dir (prgPath . key $ target) + + getMaybeToolPath :: (Target -> Maybe Program) -> String + getMaybeToolPath key = getToolPath (fromMaybe (Program "" []) . key) + + getToolFlags :: (Target -> Program) -> [String] + getToolFlags key = expandDirVars top_dir mtool_dir <$> (prgFlags . key $ target) + + getTool :: (Target -> Program) -> (String, [String]) + getTool key = (getToolPath key, getToolFlags key) -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. - targetPlatformString <- getSetting_raw "target platform string" - cc_prog <- getToolSetting "C compiler command" - cxx_prog <- getToolSetting "C++ compiler command" - cc_args0 <- getFlagsSetting "C compiler flags" - cxx_args <- getFlagsSetting "C++ compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" - cpp_prog <- getToolSetting "CPP command" - cpp_args <- map Option <$> getFlagsSetting "CPP flags" - hs_cpp_prog <- getToolSetting "Haskell CPP command" - hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" - js_cpp_prog <- getToolSetting "JavaScript CPP command" - js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" - cmmCpp_prog <- getToolSetting "C-- CPP command" - cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" - - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings - - let unreg_cc_args = if platformUnregisterised platform - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cc_args = cc_args0 ++ unreg_cc_args - - -- The extra flags we need to pass gcc when we invoke it to compile .hc code. - -- - -- -fwrapv is needed for gcc to emit well-behaved code in the presence of - -- integer wrap around (#952). - extraGccViaCFlags = if platformUnregisterised platform - -- configure guarantees cc support these flags - then ["-fwrapv", "-fno-builtin"] - else [] - - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldSupportsSingleModule <- getBooleanSetting "ld supports single module" - mergeObjsSupportsResponseFiles <- getBooleanSetting "Merge objects supports response files" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - arSupportsDashL <- getBooleanSetting "ar supports -L" - + targetHasLibm <- getBooleanSetting "target has libm" + let + (cc_prog, cc_args0) = getTool (ccProgram . tgtCCompiler) + (cxx_prog, cxx_args) = getTool (cxxProgram . tgtCxxCompiler) + (cpp_prog, cpp_args) = getTool (cppProgram . tgtCPreprocessor) + (hs_cpp_prog, hs_cpp_args) = getTool (hsCppProgram . tgtHsCPreprocessor) + (js_cpp_prog, js_cpp_args) = getTool (maybe (Program "" []) jsCppProgram . tgtJsCPreprocessor) + (cmmCpp_prog, cmmCpp_args) = getTool (cmmCppProgram . tgtCmmCPreprocessor) + + platform = getTargetPlatform targetHasLibm target + + unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cc_args = cc_args0 ++ unreg_cc_args + + -- The extra flags we need to pass gcc when we invoke it to compile .hc code. + -- + -- -fwrapv is needed for gcc to emit well-behaved code in the presence of + -- integer wrap around (#952). + extraGccViaCFlags = if platformUnregisterised platform + -- configure guarantees cc support these flags + then ["-fwrapv", "-fno-builtin"] + else [] -- The package database is either a relative path to the location of the settings file -- OR an absolute path. @@ -148,41 +138,20 @@ initSettings top_dir = do -- architecture-specific stuff is done when building Config.hs unlit_path <- getToolSetting "unlit command" - windres_path <- getToolSetting "windres command" - ar_path <- getToolSetting "ar command" - otool_path <- getToolSetting "otool command" - install_name_tool_path <- getToolSetting "install_name_tool command" - ranlib_path <- getToolSetting "ranlib command" - - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, 'as' and 'ld' are simply 'gcc' - cc_link_args <- getFlagsSetting "C compiler link flags" - let as_prog = cc_prog - as_args = map Option cc_args - ld_prog = cc_prog - ld_args = map Option (cc_args ++ cc_link_args) - ld_r_prog <- getToolSetting "Merge objects command" - ld_r_args <- getFlagsSetting "Merge objects flags" - let ld_r - | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option ld_r_args) - - llvmTarget <- getSetting_raw "LLVM target" - - -- We just assume on command line - lc_prog <- getToolSetting "LLVM llc command" - lo_prog <- getToolSetting "LLVM opt command" - las_prog <- getToolSetting "LLVM llvm-as command" - las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags" - - let iserv_prog = libexec "ghc-iserv" + -- Other things being equal, 'as' is simply 'gcc' + let (cc_link, cc_link_args) = getTool (ccLinkProgram . tgtCCompilerLink) + as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_link + ld_args = map Option (cc_args ++ cc_link_args) + ld_r = do + ld_r_prog <- tgtMergeObjs target + let (ld_r_path, ld_r_args) = getTool (mergeObjsProgram . const ld_r_prog) + pure (ld_r_path, map Option ld_r_args) + iserv_prog = libexec "ghc-iserv" targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries" ghcWithInterpreter <- getBooleanSetting "Use interpreter" - useLibFFI <- getBooleanSetting "Use LibFFI" baseUnitId <- getSetting_raw "base unit-id" @@ -206,36 +175,38 @@ initSettings top_dir = do } , sToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule - , toolSettings_mergeObjsSupportsResponseFiles = mergeObjsSupportsResponseFiles - , toolSettings_ldIsGnuLd = ldIsGnuLd - , toolSettings_ccSupportsNoPie = gccSupportsNoPie - , toolSettings_useInplaceMinGW = useInplaceMinGW - , toolSettings_arSupportsDashL = arSupportsDashL - , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 - - , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args) - , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args) - , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) - , toolSettings_pgm_F = "" - , toolSettings_pgm_c = cc_prog - , toolSettings_pgm_cxx = cxx_prog - , toolSettings_pgm_cpp = (cpp_prog, cpp_args) - , toolSettings_pgm_a = (as_prog, as_args) - , toolSettings_pgm_l = (ld_prog, ld_args) - , toolSettings_pgm_lm = ld_r - , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_ar = ar_path - , toolSettings_pgm_otool = otool_path - , toolSettings_pgm_install_name_tool = install_name_tool_path - , toolSettings_pgm_ranlib = ranlib_path - , toolSettings_pgm_lo = (lo_prog,[]) - , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_las = (las_prog, las_args) - , toolSettings_pgm_i = iserv_prog + { toolSettings_ldSupportsCompactUnwind = ccLinkSupportsCompactUnwind $ tgtCCompilerLink target + , toolSettings_ldSupportsFilelist = ccLinkSupportsFilelist $ tgtCCompilerLink target + , toolSettings_ldSupportsSingleModule = ccLinkSupportsSingleModule $ tgtCCompilerLink target + , toolSettings_ldIsGnuLd = ccLinkIsGnu $ tgtCCompilerLink target + , toolSettings_ccSupportsNoPie = ccLinkSupportsNoPie $ tgtCCompilerLink target + , toolSettings_mergeObjsSupportsResponseFiles + = maybe False mergeObjsSupportsResponseFiles + $ tgtMergeObjs target + , toolSettings_arSupportsDashL = arSupportsDashL $ tgtAr target + , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 $ tgtCmmCPreprocessor target + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (hs_cpp_prog, map Option hs_cpp_args) + , toolSettings_pgm_JSP = (js_cpp_prog, map Option js_cpp_args) + , toolSettings_pgm_CmmP = (cmmCpp_prog, map Option cmmCpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_cxx = cxx_prog + , toolSettings_pgm_cpp = (cpp_prog, map Option cpp_args) + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_lm = ld_r + , toolSettings_pgm_windres = getMaybeToolPath tgtWindres + , toolSettings_pgm_ar = getToolPath (arMkArchive . tgtAr) + , toolSettings_pgm_otool = getMaybeToolPath tgtOtool + , toolSettings_pgm_install_name_tool = getMaybeToolPath tgtInstallNameTool + , toolSettings_pgm_ranlib = getMaybeToolPath (fmap ranlibProgram . tgtRanlib) + , toolSettings_pgm_lo = (getMaybeToolPath tgtOpt,[]) + , toolSettings_pgm_lc = (getMaybeToolPath tgtLlc,[]) + , toolSettings_pgm_las = second (map Option) $ + getTool (fromMaybe (Program "" []) . tgtLlvmAs) + , toolSettings_pgm_i = iserv_prog , toolSettings_opt_L = [] , toolSettings_opt_P = [] , toolSettings_opt_JSP = [] @@ -260,65 +231,30 @@ initSettings top_dir = do , sTargetPlatform = platform , sPlatformMisc = PlatformMisc - { platformMisc_targetPlatformString = targetPlatformString + { platformMisc_targetPlatformString = targetPlatformTriple target , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_libFFI = useLibFFI - , platformMisc_llvmTarget = llvmTarget + , platformMisc_libFFI = tgtUseLibffiForAdjustors target + , platformMisc_llvmTarget = tgtLlvmTarget target , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs } , sRawSettings = settingsList + , sRawTarget = target } -getTargetPlatform - :: FilePath -- ^ Settings filepath (for error messages) - -> RawSettings -- ^ Raw settings file contents - -> Either String Platform -getTargetPlatform settingsFile settings = do - let - getBooleanSetting = getRawBooleanSetting settingsFile settings - readSetting :: (Show a, Read a) => String -> Either String a - readSetting = readRawSetting settingsFile settings - - targetArchOS <- getTargetArchOS settingsFile settings - targetWordSize <- readSetting "target word size" - targetWordBigEndian <- getBooleanSetting "target word big endian" - targetLeadingUnderscore <- getBooleanSetting "Leading underscore" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" - targetHasIdentDirective <- getBooleanSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" - targetHasLibm <- getBooleanSetting "target has libm" - crossCompiling <- getBooleanSetting "cross compiling" - tablesNextToCode <- getBooleanSetting "Tables next to code" - - pure $ Platform - { platformArchOS = targetArchOS - , platformWordSize = targetWordSize - , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian - , platformUnregisterised = targetUnregisterised - , platformHasGnuNonexecStack = targetHasGnuNonexecStack - , platformHasIdentDirective = targetHasIdentDirective - , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols - , platformIsCrossCompiling = crossCompiling - , platformLeadingUnderscore = targetLeadingUnderscore - , platformTablesNextToCode = tablesNextToCode +getTargetPlatform :: Bool {-^ Does target have libm -} -> Target -> Platform +getTargetPlatform targetHasLibm Target{..} = Platform + { platformArchOS = tgtArchOs + , platformWordSize = case tgtWordSize of WS4 -> PW4 + WS8 -> PW8 + , platformByteOrder = tgtEndianness + , platformUnregisterised = tgtUnregisterised + , platformHasGnuNonexecStack = tgtSupportsGnuNonexecStack + , platformHasIdentDirective = tgtSupportsIdentDirective + , platformHasSubsectionsViaSymbols = tgtSupportsSubsectionsViaSymbols + , platformIsCrossCompiling = not tgtLocallyExecutable + , platformLeadingUnderscore = tgtSymbolsHaveLeadingUnderscore + , platformTablesNextToCode = tgtTablesNextToCode , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } - --- ---------------------------------------------------------------------------- --- Escape Args helpers --- ---------------------------------------------------------------------------- - --- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== compiler/GHC/SysTools/BaseDir.hs ===================================== @@ -90,13 +90,10 @@ the build system finds and wires through the toolchain information. 3) The next step is to generate the settings file: The file `cfg/system.config.in` is preprocessed by configure and the output written to `system.config`. This serves the same purpose as `config.mk` but it rewrites - the values that were exported. As an example `SettingsCCompilerCommand` is - rewritten to `settings-c-compiler-command`. + the values that were exported. Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to - the settings `keys` in the `system.config`. As an example, - `settings-c-compiler-command` is mapped to - `SettingsFileSetting_CCompilerCommand`. + the settings `keys` in the `system.config`. The last part of this is the `generateSettings` in `src/Rules/Generate.hs` which produces the desired settings file out of Hadrian. This is the @@ -122,15 +119,13 @@ play nice with the system compiler instead. -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir - :: Bool -- ^ whether we use the ambient mingw toolchain - -> Maybe FilePath -- ^ tooldir + :: Maybe FilePath -- ^ tooldir -> String -> String #if defined(mingw32_HOST_OS) -expandToolDir False (Just tool_dir) s = expandPathVar "tooldir" tool_dir s -expandToolDir False Nothing _ = panic "Could not determine $tooldir" -expandToolDir True _ s = s +expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir Nothing _ = panic "Could not determine $tooldir" #else -expandToolDir _ _ s = s +expandToolDir _ s = s #endif -- | Returns a Unix-format path pointing to TopDir. @@ -164,13 +159,13 @@ tryFindTopDir Nothing -- Returns @Nothing@ when not on Windows. -- When called on Windows, it either throws an error when the -- tooldir can't be located, or returns @Just tooldirpath@. --- If the distro toolchain is being used we treat Windows the same as Linux +-- If the distro toolchain is being used, there will be no variables to +-- substitute for anyway, so this is a no-op. findToolDir - :: Bool -- ^ whether we use the ambient mingw toolchain - -> FilePath -- ^ topdir + :: FilePath -- ^ topdir -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) -findToolDir False top_dir = go 0 (top_dir </> "..") [] +findToolDir top_dir = go 0 (top_dir </> "..") [] where maxDepth = 3 go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath) go k path tried @@ -183,7 +178,6 @@ findToolDir False top_dir = go 0 (top_dir </> "..") [] if oneLevel then return (Just path) else go (k+1) (path </> "..") tried' -findToolDir True _ = return Nothing #else -findToolDir _ _ = return Nothing +findToolDir _ = return Nothing #endif ===================================== compiler/ghc.cabal.in ===================================== @@ -131,6 +131,7 @@ Library semaphore-compat, stm, rts, + ghc-toolchain, ghc-boot == @ProjectVersionMunged@, ghc-heap == @ProjectVersionMunged@, ghci == @ProjectVersionMunged@ ===================================== configure.ac ===================================== @@ -132,6 +132,7 @@ AC_ARG_ENABLE(distro-toolchain, [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])], [EnableDistroToolchain=NO] ) +AC_SUBST([EnableDistroToolchain]) if test "$EnableDistroToolchain" = "YES"; then TarballsAutodownload=NO @@ -752,8 +753,6 @@ FP_PROG_AR_NEEDS_RANLIB dnl ** Check to see whether ln -s works AC_PROG_LN_S -FP_SETTINGS - dnl ** Find the path to sed AC_PATH_PROGS(SedCmd,gsed sed,sed) ===================================== distrib/configure.ac.in ===================================== @@ -89,8 +89,9 @@ AC_ARG_ENABLE(distro-toolchain, [AS_HELP_STRING([--enable-distro-toolchain], [Do not use bundled Windows toolchain binaries.])], [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])], - [EnableDistroToolchain=@SettingsUseDistroMINGW@] + [EnableDistroToolchain=@EnableDistroToolchain@] ) +AC_SUBST([EnableDistroToolchain]) if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/]) @@ -384,8 +385,6 @@ fi AC_SUBST(BaseUnitId) -FP_SETTINGS - # We get caught by # http://savannah.gnu.org/bugs/index.php?1516 # $(eval ...) inside conditionals causes errors @@ -418,6 +417,34 @@ AC_OUTPUT VALIDATE_GHC_TOOLCHAIN([default.target],[default.target.ghc-toolchain]) +if test "$EnableDistroToolchain" = "YES"; then + # If the user specified --enable-distro-toolchain then we just use the + # executable names, not paths. We do this by finding strings of paths to + # programs and keeping the basename only: + cp default.target default.target.bak + + while IFS= read -r line; do + if echo "$line" | grep -q 'prgPath = "'; then + path=$(echo "$line" | sed -E 's/.*prgPath = "([[^"]]+)".*/\1/') + base=$(basename "$path") + echo "$line" | sed "s|$path|$base|" + else + echo "$line" + fi + done < default.target.bak > default.target + echo "Applied --enable-distro-toolchain basename substitution to default.target:" + cat default.target +fi + +if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then + # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN. + # We need to issue a substitution to use $tooldir, + # See Note [tooldir: How GHC finds mingw on Windows] + SUBST_TOOLDIR([default.target]) + echo "Applied tooldir substitution to default.target:" + cat default.target +fi + rm -Rf acargs acghc-toolchain actmp-ghc-toolchain echo "****************************************************" ===================================== hadrian/bindist/Makefile ===================================== @@ -85,67 +85,24 @@ WrapperBinsDir=${bindir} # N.B. this is duplicated from includes/ghc.mk. lib/settings : config.mk @rm -f $@ - @echo '[("C compiler command", "$(SettingsCCompilerCommand)")' >> $@ - @echo ',("C compiler flags", "$(SettingsCCompilerFlags)")' >> $@ - @echo ',("C++ compiler command", "$(SettingsCxxCompilerCommand)")' >> $@ - @echo ',("C++ compiler flags", "$(SettingsCxxCompilerFlags)")' >> $@ - @echo ',("C compiler link flags", "$(SettingsCCompilerLinkFlags)")' >> $@ - @echo ',("C compiler supports -no-pie", "$(SettingsCCompilerSupportsNoPie)")' >> $@ - @echo ',("CPP command", "$(SettingsCPPCommand)")' >> $@ - @echo ',("CPP flags", "$(SettingsCPPFlags)")' >> $@ - @echo ',("Haskell CPP command", "$(SettingsHaskellCPPCommand)")' >> $@ - @echo ',("Haskell CPP flags", "$(SettingsHaskellCPPFlags)")' >> $@ - @echo ',("JavaScript CPP command", "$(SettingsJavaScriptCPPCommand)")' >> $@ - @echo ',("JavaScript CPP flags", "$(SettingsJavaScriptCPPFlags)")' >> $@ - @echo ',("C-- CPP command", "$(SettingsCmmCPPCommand)")' >> $@ - @echo ',("C-- CPP flags", "$(SettingsCmmCPPFlags)")' >> $@ - @echo ',("C-- CPP supports -g0", "$(SettingsCmmCPPSupportsG0)")' >> $@ - @echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@ - @echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@ - @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@ - @echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@ - @echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@ - @echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@ - @echo ',("Merge objects supports response files", "$(MergeObjsSupportsResponseFiles)")' >> $@ - @echo ',("ar command", "$(SettingsArCommand)")' >> $@ - @echo ',("ar flags", "$(ArArgs)")' >> $@ - @echo ',("ar supports at file", "$(ArSupportsAtFile)")' >> $@ - @echo ',("ar supports -L", "$(ArSupportsDashL)")' >> $@ - @echo ',("ranlib command", "$(SettingsRanlibCommand)")' >> $@ - @echo ',("otool command", "$(SettingsOtoolCommand)")' >> $@ - @echo ',("install_name_tool command", "$(SettingsInstallNameToolCommand)")' >> $@ - @echo ',("windres command", "$(SettingsWindresCommand)")' >> $@ - @echo ',("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@ - @echo ',("cross compiling", "$(CrossCompiling)")' >> $@ - @echo ',("target platform string", "$(TARGETPLATFORM)")' >> $@ - @echo ',("target os", "$(HaskellTargetOs)")' >> $@ + @echo '[("target os", "$(HaskellTargetOs)")' >> $@ @echo ',("target arch", "$(HaskellTargetArch)")' >> $@ - @echo ',("target word size", "$(TargetWordSize)")' >> $@ - @echo ',("target word big endian", "$(TargetWordBigEndian)")' >> $@ - @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ - @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ - @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ - @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ - @echo ',("LLVM target", "$(LLVMTarget)")' >> $@ - @echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@ - @echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@ - @echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@ - @echo ',("LLVM llvm-as flags", "$(SettingsLlvmAsFlags)")' >> $@ - @echo ',("Use inplace MinGW toolchain", "$(SettingsUseDistroMINGW)")' >> $@ - @echo + @echo ',("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@ @echo ',("target RTS linker only supports shared libraries", "$(TargetRTSLinkerOnlySupportsSharedLibs)")' >> $@ @echo ',("Use interpreter", "$(GhcWithInterpreter)")' >> $@ @echo ',("Support SMP", "$(GhcWithSMP)")' >> $@ @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ - @echo ',("Tables next to code", "$(TablesNextToCode)")' >> $@ - @echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@ - @echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@ @echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ @echo "]" >> $@ +lib/targets/default.target : config.mk default.target + @rm -f $@ + @echo "Copying the bindist-configured default.target to lib/targets/default.target" + cp default.target $@ + # We need to install binaries relative to libraries. BINARIES = $(wildcard ./bin/*) .PHONY: install_bin_libdir @@ -167,7 +124,7 @@ install_bin_direct: $(INSTALL_PROGRAM) ./bin/* "$(DESTDIR)$(WrapperBinsDir)/" .PHONY: install_lib -install_lib: lib/settings +install_lib: lib/settings lib/targets/default.target @echo "Copying libraries to $(DESTDIR)$(ActualLibsDir)" $(INSTALL_DIR) "$(DESTDIR)$(ActualLibsDir)" ===================================== hadrian/bindist/config.mk.in ===================================== @@ -133,7 +133,7 @@ INSTALL_DIR = $(INSTALL) -m 755 -d CrossCompiling = @CrossCompiling@ CrossCompilePrefix = @CrossCompilePrefix@ GhcUnregisterised = @Unregisterised@ -EnableDistroToolchain = @SettingsUseDistroMINGW@ +EnableDistroToolchain = @EnableDistroToolchain@ BaseUnitId = @BaseUnitId@ # The THREADED_RTS requires `BaseReg` to be in a register and the @@ -205,31 +205,3 @@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ LeadingUnderscore = @LeadingUnderscore@ LlvmTarget = @LlvmTarget@ - -SettingsCCompilerCommand = @SettingsCCompilerCommand@ -SettingsCxxCompilerCommand = @SettingsCxxCompilerCommand@ -SettingsCPPCommand = @SettingsCPPCommand@ -SettingsCPPFlags = @SettingsCPPFlags@ -SettingsHaskellCPPCommand = @SettingsHaskellCPPCommand@ -SettingsHaskellCPPFlags = @SettingsHaskellCPPFlags@ -SettingsJavaScriptCPPCommand = @SettingsJavaScriptCPPCommand@ -SettingsJavaScriptCPPFlags = @SettingsJavaScriptCPPFlags@ -SettingsCmmCPPCommand = @SettingsCmmCPPCommand@ -SettingsCmmCPPFlags = @SettingsCmmCPPFlags@ -SettingsCmmCPPSupportsG0 = @SettingsCmmCPPSupportsG0@ -SettingsCCompilerFlags = @SettingsCCompilerFlags@ -SettingsCxxCompilerFlags = @SettingsCxxCompilerFlags@ -SettingsCCompilerLinkFlags = @SettingsCCompilerLinkFlags@ -SettingsCCompilerSupportsNoPie = @SettingsCCompilerSupportsNoPie@ -SettingsMergeObjectsCommand = @SettingsMergeObjectsCommand@ -SettingsMergeObjectsFlags = @SettingsMergeObjectsFlags@ -SettingsArCommand = @SettingsArCommand@ -SettingsOtoolCommand = @SettingsOtoolCommand@ -SettingsInstallNameToolCommand = @SettingsInstallNameToolCommand@ -SettingsRanlibCommand = @SettingsRanlibCommand@ -SettingsWindresCommand = @SettingsWindresCommand@ -SettingsLibtoolCommand = @SettingsLibtoolCommand@ -SettingsLlcCommand = @SettingsLlcCommand@ -SettingsOptCommand = @SettingsOptCommand@ -SettingsLlvmAsCommand = @SettingsLlvmAsCommand@ -SettingsUseDistroMINGW = @SettingsUseDistroMINGW@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,7 +79,7 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] -settings-use-distro-mingw = @SettingsUseDistroMINGW@ +settings-use-distro-mingw = @EnableDistroToolchain@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Base.hs ===================================== @@ -151,6 +151,7 @@ ghcLibDeps stage iplace = do , "llvm-passes" , "ghc-interp.js" , "settings" + , "targets" -/- "default.target" , "ghc-usage.txt" , "ghci-usage.txt" , "dyld.mjs" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -10,7 +10,7 @@ import qualified Data.Set as Set import Base import qualified Context import Expression -import Hadrian.Oracles.TextFile (lookupSystemConfig) +import Hadrian.Oracles.TextFile (lookupSystemConfig, getTargetTarget) import Oracles.Flag hiding (arSupportsAtFile, arSupportsDashL) import Oracles.ModuleFiles import Oracles.Setting @@ -24,7 +24,6 @@ import Target import Utilities import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) -import GHC.Toolchain.Program import GHC.Platform.ArchOS import Settings.Program (ghcWithInterpreter) @@ -263,6 +262,7 @@ generateRules = do let prefix = root -/- stageString stage -/- "lib" go gen file = generate file (semiEmptyTarget (succStage stage)) gen (prefix -/- "settings") %> \out -> go (generateSettings out) out + (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out where file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out @@ -425,7 +425,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" + , interpolateVar "EnableDistroToolchain" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -483,62 +483,14 @@ generateSettings settingsFile = do let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path settings <- traverse sequence $ - [ ("C compiler command", queryTarget ccPath) - , ("C compiler flags", queryTarget ccFlags) - , ("C++ compiler command", queryTarget cxxPath) - , ("C++ compiler flags", queryTarget cxxFlags) - , ("C compiler link flags", queryTarget clinkFlags) - , ("C compiler supports -no-pie", queryTarget linkSupportsNoPie) - , ("CPP command", queryTarget cppPath) - , ("CPP flags", queryTarget cppFlags) - , ("Haskell CPP command", queryTarget hsCppPath) - , ("Haskell CPP flags", queryTarget hsCppFlags) - , ("JavaScript CPP command", queryTarget jsCppPath) - , ("JavaScript CPP flags", queryTarget jsCppFlags) - , ("C-- CPP command", queryTarget cmmCppPath) - , ("C-- CPP flags", queryTarget cmmCppFlags) - , ("C-- CPP supports -g0", queryTarget cmmCppSupportsG0') - , ("ld supports compact unwind", queryTarget linkSupportsCompactUnwind) - , ("ld supports filelist", queryTarget linkSupportsFilelist) - , ("ld supports single module", queryTarget linkSupportsSingleModule) - , ("ld is GNU ld", queryTarget linkIsGnu) - , ("Merge objects command", queryTarget mergeObjsPath) - , ("Merge objects flags", queryTarget mergeObjsFlags) - , ("Merge objects supports response files", queryTarget mergeObjsSupportsResponseFiles') - , ("ar command", queryTarget arPath) - , ("ar flags", queryTarget arFlags) - , ("ar supports at file", queryTarget arSupportsAtFile') - , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", queryTarget otoolPath) - , ("install_name_tool command", queryTarget installNameToolPath) - , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. - , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) - , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) - , ("target platform string", queryTarget targetPlatformTriple) - , ("target os", queryTarget (show . archOS_OS . tgtArchOs)) + [ ("target os", queryTarget (show . archOS_OS . tgtArchOs)) , ("target arch", queryTarget (show . archOS_arch . tgtArchOs)) - , ("target word size", queryTarget wordSize) - , ("target word big endian", queryTarget isBigEndian) - , ("target has GNU nonexec stack", queryTarget (yesNo . Toolchain.tgtSupportsGnuNonexecStack)) - , ("target has .ident directive", queryTarget (yesNo . Toolchain.tgtSupportsIdentDirective)) - , ("target has subsections via symbols", queryTarget (yesNo . Toolchain.tgtSupportsSubsectionsViaSymbols)) + , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("target has libm", expr $ lookupSystemConfig "target-has-libm") - , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) - , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", queryTarget llcPath) - , ("LLVM opt command", queryTarget optPath) - , ("LLVM llvm-as command", queryTarget llvmAsPath) - , ("LLVM llvm-as flags", queryTarget llvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") - , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) , ("Support SMP", expr $ yesNo <$> targetSupportsSMP) , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) - , ("Tables next to code", queryTarget (yesNo . tgtTablesNextToCode)) - , ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore)) - , ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors) , ("RTS expects libdw", yesNo <$> getFlag UseLibdw) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) @@ -550,40 +502,6 @@ generateSettings settingsFile = do ("[" ++ showTuple s) : ((\s' -> "," ++ showTuple s') <$> ss) ++ ["]"] - where - ccPath = prgPath . ccProgram . tgtCCompiler - ccFlags = escapeArgs . prgFlags . ccProgram . tgtCCompiler - cxxPath = prgPath . cxxProgram . tgtCxxCompiler - cxxFlags = escapeArgs . prgFlags . cxxProgram . tgtCxxCompiler - clinkFlags = escapeArgs . prgFlags . ccLinkProgram . tgtCCompilerLink - linkSupportsNoPie = yesNo . ccLinkSupportsNoPie . tgtCCompilerLink - cppPath = prgPath . cppProgram . tgtCPreprocessor - cppFlags = escapeArgs . prgFlags . cppProgram . tgtCPreprocessor - hsCppPath = prgPath . hsCppProgram . tgtHsCPreprocessor - hsCppFlags = escapeArgs . prgFlags . hsCppProgram . tgtHsCPreprocessor - jsCppPath = maybe "" (prgPath . jsCppProgram) . tgtJsCPreprocessor - jsCppFlags = maybe "" (escapeArgs . prgFlags . jsCppProgram) . tgtJsCPreprocessor - cmmCppPath = prgPath . cmmCppProgram . tgtCmmCPreprocessor - cmmCppFlags = escapeArgs . prgFlags . cmmCppProgram . tgtCmmCPreprocessor - cmmCppSupportsG0' = yesNo . cmmCppSupportsG0 . tgtCmmCPreprocessor - mergeObjsPath = maybe "" (prgPath . mergeObjsProgram) . tgtMergeObjs - mergeObjsFlags = maybe "" (escapeArgs . prgFlags . mergeObjsProgram) . tgtMergeObjs - linkSupportsSingleModule = yesNo . ccLinkSupportsSingleModule . tgtCCompilerLink - linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink - linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink - linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink - llcPath = maybe "" prgPath . tgtLlc - optPath = maybe "" prgPath . tgtOpt - llvmAsPath = maybe "" prgPath . tgtLlvmAs - llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs - arPath = prgPath . arMkArchive . tgtAr - arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr - arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr - arSupportsDashL' = yesNo . arSupportsDashL . tgtAr - otoolPath = maybe "" prgPath . tgtOtool - installNameToolPath = maybe "" prgPath . tgtInstallNameTool - ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib - mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs isBigEndian, wordSize :: Toolchain.Target -> String isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Internal.ResponseFile ( getArgsWithResponseFiles, unescapeArgs, - escapeArgs, + escapeArgs, escapeArg, expandResponse ) where ===================================== m4/fp_settings.m4 deleted ===================================== @@ -1,171 +0,0 @@ -dnl Note [How we configure the bundled windows toolchain] -dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the -dnl bundled windows toolchain, the GHC settings file must refer to the -dnl toolchain through a path relative to $tooldir (binary distributions on -dnl Windows should work without configure, so the paths must be relative to the -dnl installation). However, hadrian expects the configured toolchain to use -dnl full paths to the executable. -dnl -dnl This is how the bundled windows toolchain is configured, to define the -dnl toolchain with paths to the executables, while still writing into GHC -dnl settings the paths relative to $tooldir: -dnl -dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked -dnl -dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths -dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc) -dnl -dnl * Later on, in FP_SETTINGS, we substitute occurrences of the path to the -dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR). -dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to -dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir. -dnl -dnl * Finally, hadrian will also substitute the mingw prefix by $tooldir before writing the toolchain to the settings file (see generateSettings) -dnl -dnl The ghc-toolchain program isn't concerned with any of these complications: -dnl it is passed either the full paths to the toolchain executables, or the bundled -dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain -dnl will, as always, output target files with full paths to the executables. -dnl -dnl Hadrian accounts for this as it does for the toolchain executables -dnl configured by configure -- in fact, hadrian doesn't need to know whether -dnl the toolchain description file was generated by configure or by -dnl ghc-toolchain. - -# SUBST_TOOLDIR -# ---------------------------------- -# $1 - the variable where to search for occurrences of the path to the -# inplace mingw, and update by substituting said occurrences by -# the value of $mingw_install_prefix, where the mingw toolchain will be at -# install time -# -# See Note [How we configure the bundled windows toolchain] -AC_DEFUN([SUBST_TOOLDIR], -[ - dnl and Note [How we configure the bundled windows toolchain] - $1=`echo "$$1" | sed 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g'` -]) - -# FP_SETTINGS -# ---------------------------------- -# Set the variables used in the settings file -AC_DEFUN([FP_SETTINGS], -[ - SettingsUseDistroMINGW="$EnableDistroToolchain" - - SettingsCCompilerCommand="$CC" - SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" - SettingsCxxCompilerCommand="$CXX" - SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2" - SettingsCPPCommand="$CPPCmd" - SettingsCPPFlags="$CONF_CPP_OPTS_STAGE2" - SettingsHaskellCPPCommand="$HaskellCPPCmd" - SettingsHaskellCPPFlags="$HaskellCPPArgs" - SettingsJavaScriptCPPCommand="$JavaScriptCPPCmd" - SettingsJavaScriptCPPFlags="$JavaScriptCPPArgs" - SettingsCmmCPPCommand="$CmmCPPCmd" - SettingsCmmCPPFlags="$CmmCPPArgs" - SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" - SettingsArCommand="$ArCmd" - SettingsRanlibCommand="$RanlibCmd" - SettingsMergeObjectsCommand="$MergeObjsCmd" - SettingsMergeObjectsFlags="$MergeObjsArgs" - - AS_CASE( - ["$CmmCPPSupportsG0"], - [True], [SettingsCmmCPPSupportsG0=YES], - [False], [SettingsCmmCPPSupportsG0=NO], - [AC_MSG_ERROR(Unknown CPPSupportsG0 value $CmmCPPSupportsG0)] - ) - - if test -z "$WindresCmd"; then - SettingsWindresCommand="/bin/false" - else - SettingsWindresCommand="$WindresCmd" - fi - - # LLVM backend tools - SettingsLlcCommand="$LlcCmd" - SettingsOptCommand="$OptCmd" - SettingsLlvmAsCommand="$LlvmAsCmd" - SettingsLlvmAsFlags="$LlvmAsFlags" - - if test "$EnableDistroToolchain" = "YES"; then - # If the user specified --enable-distro-toolchain then we just use the - # executable names, not paths. - SettingsCCompilerCommand="$(basename $SettingsCCompilerCommand)" - SettingsHaskellCPPCommand="$(basename $SettingsHaskellCPPCommand)" - SettingsCmmCPPCommand="$(basename $SettingsCmmCPPCommand)" - SettingsJavaScriptCPPCommand="$(basename $SettingsJavaScriptCPPCommand)" - SettingsLdCommand="$(basename $SettingsLdCommand)" - SettingsMergeObjectsCommand="$(basename $SettingsMergeObjectsCommand)" - SettingsArCommand="$(basename $SettingsArCommand)" - SettingsWindresCommand="$(basename $SettingsWindresCommand)" - SettingsLlcCommand="$(basename $SettingsLlcCommand)" - SettingsOptCommand="$(basename $SettingsOptCommand)" - SettingsLlvmAsCommand="$(basename $SettingsLlvmAsCommand)" - fi - - if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then - # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN. - # We need to issue a substitution to use $tooldir, - # See Note [tooldir: How GHC finds mingw on Windows] - SUBST_TOOLDIR([SettingsCCompilerCommand]) - SUBST_TOOLDIR([SettingsCCompilerFlags]) - SUBST_TOOLDIR([SettingsCxxCompilerCommand]) - SUBST_TOOLDIR([SettingsCxxCompilerFlags]) - SUBST_TOOLDIR([SettingsCCompilerLinkFlags]) - SUBST_TOOLDIR([SettingsCPPCommand]) - SUBST_TOOLDIR([SettingsCPPFlags]) - SUBST_TOOLDIR([SettingsHaskellCPPCommand]) - SUBST_TOOLDIR([SettingsHaskellCPPFlags]) - SUBST_TOOLDIR([SettingsCmmCPPCommand]) - SUBST_TOOLDIR([SettingsCmmCPPFlags]) - SUBST_TOOLDIR([SettingsJavaScriptCPPCommand]) - SUBST_TOOLDIR([SettingsJavaScriptCPPFlags]) - SUBST_TOOLDIR([SettingsMergeObjectsCommand]) - SUBST_TOOLDIR([SettingsMergeObjectsFlags]) - SUBST_TOOLDIR([SettingsArCommand]) - SUBST_TOOLDIR([SettingsRanlibCommand]) - SUBST_TOOLDIR([SettingsWindresCommand]) - SUBST_TOOLDIR([SettingsLlcCommand]) - SUBST_TOOLDIR([SettingsOptCommand]) - SUBST_TOOLDIR([SettingsLlvmAsCommand]) - SUBST_TOOLDIR([SettingsLlvmAsFlags]) - fi - - # Mac-only tools - SettingsOtoolCommand="$OtoolCmd" - SettingsInstallNameToolCommand="$InstallNameToolCmd" - - SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" - - AC_SUBST(SettingsCCompilerCommand) - AC_SUBST(SettingsCxxCompilerCommand) - AC_SUBST(SettingsCPPCommand) - AC_SUBST(SettingsCPPFlags) - AC_SUBST(SettingsHaskellCPPCommand) - AC_SUBST(SettingsHaskellCPPFlags) - AC_SUBST(SettingsCmmCPPCommand) - AC_SUBST(SettingsCmmCPPFlags) - AC_SUBST(SettingsCmmCPPSupportsG0) - AC_SUBST(SettingsJavaScriptCPPCommand) - AC_SUBST(SettingsJavaScriptCPPFlags) - AC_SUBST(SettingsCCompilerFlags) - AC_SUBST(SettingsCxxCompilerFlags) - AC_SUBST(SettingsCCompilerLinkFlags) - AC_SUBST(SettingsCCompilerSupportsNoPie) - AC_SUBST(SettingsMergeObjectsCommand) - AC_SUBST(SettingsMergeObjectsFlags) - AC_SUBST(SettingsArCommand) - AC_SUBST(SettingsRanlibCommand) - AC_SUBST(SettingsOtoolCommand) - AC_SUBST(SettingsInstallNameToolCommand) - AC_SUBST(SettingsWindresCommand) - AC_SUBST(SettingsLlcCommand) - AC_SUBST(SettingsOptCommand) - AC_SUBST(SettingsLlvmAsCommand) - AC_SUBST(SettingsLlvmAsFlags) - AC_SUBST(SettingsUseDistroMINGW) -]) ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -77,6 +77,7 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ # $2 the location that the windows toolchain will be installed in relative to the libdir AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ + # TODO: UPDATE COMMENT # N.B. The parameters which get plopped in the `settings` file used by the # resulting compiler are computed in `FP_SETTINGS`. Specifically, we use # $$topdir-relative paths instead of fullpaths to the toolchain, by replacing ===================================== m4/subst_tooldir.m4 ===================================== @@ -0,0 +1,45 @@ +dnl Note [How we configure the bundled windows toolchain] +dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the +dnl bundled windows toolchain, the GHC settings file must refer to the +dnl toolchain through a path relative to $tooldir (binary distributions on +dnl Windows should work without configure, so the paths must be relative to the +dnl installation). However, hadrian expects the configured toolchain to use +dnl full paths to the executable. +dnl +dnl This is how the bundled windows toolchain is configured, to define the +dnl toolchain with paths to the executables, while still writing into GHC +dnl settings the paths relative to $tooldir: +dnl +dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked +dnl +dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths +dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc) +dnl +dnl * Later on, at the end of distrib/configure.ac, we substitute occurrences of the path to the +dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR). +dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to +dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir. +dnl +dnl The ghc-toolchain program isn't concerned with any of these complications: +dnl it is passed either the full paths to the toolchain executables, or the bundled +dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain +dnl will, as always, output target files with full paths to the executables. +dnl +dnl Hadrian accounts for this as it does for the toolchain executables +dnl configured by configure -- in fact, hadrian doesn't need to know whether +dnl the toolchain description file was generated by configure or by +dnl ghc-toolchain. + +# SUBST_TOOLDIR +# ---------------------------------- +# $1 - the filepath where to search for occurrences of the path to the +# inplace mingw, and update by substituting said occurrences by +# the value of $mingw_install_prefix, where the mingw toolchain will be at +# install time +# +# See Note [How we configure the bundled windows toolchain] +AC_DEFUN([SUBST_TOOLDIR], +[ + sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' +]) ===================================== mk/hsc2hs.in ===================================== @@ -1,6 +1,6 @@ -HSC2HS_C="@SettingsCCompilerFlags@" +HSC2HS_C="@CONF_CC_OPTS_STAGE2@" -HSC2HS_L="@SettingsCCompilerLinkFlags@" +HSC2HS_L="@CONF_GCC_LINKER_OPTS_STAGE2@" tflag="--template=$libdir/template-hsc.h" Iflag="-I$includedir/include/" ===================================== testsuite/tests/ghc-api/T20757.hs ===================================== @@ -3,4 +3,4 @@ module Main where import GHC.SysTools.BaseDir main :: IO () -main = findToolDir False "/" >>= print +main = findToolDir "/" >>= print ===================================== testsuite/tests/ghc-api/settings-escape/T24265.hs ===================================== @@ -16,6 +16,13 @@ import System.Environment import System.IO (hPutStrLn, stderr) import System.Exit (exitWith, ExitCode(ExitFailure)) +import GHC.Toolchain +import GHC.Toolchain.Program +import GHC.Toolchain.Tools.Cc +import GHC.Toolchain.Tools.Cpp +import GHC.Toolchain.Tools.Cxx +import GHC.Toolchain.Lens + -- Precondition: this test case must be executed in a directory with a space. -- -- First we get the current settings file and amend it with extra arguments that we *know* @@ -30,35 +37,29 @@ main :: IO () main = do libdir:_args <- getArgs - (rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do + (rawSettingOpts, rawTargetOpts, originalSettings) <- runGhc (Just libdir) $ do dflags <- hsc_dflags <$> getSession - pure (rawSettings dflags, settings dflags) + pure (rawSettings dflags, rawTarget dflags, settings dflags) top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces" - let argsWithSpaces = "\"-some option\" -some\\ other" - numberOfExtraArgs = length $ unescapeArgs argsWithSpaces - -- These are all options that can have multiple 'String' or 'Option' values. - -- We explicitly do not add 'C compiler link flags' here, as 'initSettings' - -- already adds the options of "C compiler flags" to this config field. - multipleArguments = Set.fromList - [ "Haskell CPP flags" - , "JavaScript CPP flags" - , "C-- CPP flags" - , "C compiler flags" - , "C++ compiler flags" - , "CPP flags" - , "Merge objects flags" + let argsWithSpaces l = over l (++["-some option", "-some\\ other"]) + numberOfExtraArgs = 2 + -- Test it on a handfull of list of flags + multipleArguments = + [ _tgtHsCpp % _hsCppProg % _prgFlags -- "Haskell CPP flags" + , _tgtCC % _ccProgram % _prgFlags -- "C compiler flags" + , _tgtCxx % _cxxProgram % _prgFlags -- "C++ compiler flags" + , _tgtCpp % _cppProg % _prgFlags -- "CPP flags" ] - let rawSettingOptsWithExtraArgs = - map (\(name, args) -> if Set.member name multipleArguments - then (name, args ++ " " ++ argsWithSpaces) - else (name, args)) rawSettingOpts + targetWithExtraArgs = foldr argsWithSpaces rawTargetOpts multipleArguments -- write out the modified settings. We try to keep it legible writeFile (top_dir ++ "/settings") $ - "[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]" + "[" ++ (intercalate "\n," (map show rawSettingOpts)) ++ "]" + writeFile (top_dir ++ "/targets/default.target") $ + show targetWithExtraArgs settingsm <- runExceptT $ initSettings top_dir @@ -113,12 +114,6 @@ main = do -- Setting 'Haskell CPP flags' contains '$topdir' reference. -- Resolving those while containing spaces, should not introduce more options. recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings) - -- Setting 'JavaScript CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "JavaScript CPP flags" (map showOpt . snd . toolSettings_pgm_JSP . sToolSettings) - -- Setting 'C-- CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "C-- CPP flags" (map showOpt . snd . toolSettings_pgm_CmmP . sToolSettings) -- Setting 'C compiler flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings) @@ -133,10 +128,6 @@ main = do -- Setting 'CPP flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "CPP flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings) - -- Setting 'Merge objects flags' contains strings with spaces. - -- GHC should not split these by word. - -- If 'Nothing', ignore this test, otherwise the same assertion holds as before. - recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings) -- Setting 'C compiler command' contains '$topdir' reference. -- Spaces in the final filepath should not be escaped. recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings) ===================================== testsuite/tests/ghc-api/settings-escape/T24265.stderr ===================================== @@ -1,9 +1,5 @@ === 'Haskell CPP flags' contains 2 new entries: True Contains spaces: True -=== 'JavaScript CPP flags' contains 2 new entries: True - Contains spaces: True -=== 'C-- CPP flags' contains 2 new entries: True - Contains spaces: True === 'C compiler flags' contains 2 new entries: True Contains spaces: True === 'C compiler link flags' contains 2 new entries: True @@ -12,5 +8,4 @@ Contains spaces: True === 'CPP flags' contains 2 new entries: True Contains spaces: True -=== 'Merge objects flags' contains expected entries: True === FilePath 'C compiler' contains escaped spaces: False ===================================== testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep ===================================== ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -534,4 +534,3 @@ mkTarget opts = do } return t ---- ROMES:TODO: fp_settings.m4 in general which I don't think was ported completely (e.g. the basenames and windows llvm-XX and such) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -7,6 +7,9 @@ module GHC.Toolchain.Target , WordSize(..), wordSize2Bytes + -- ** Lenses + , _tgtCC, _tgtCxx, _tgtCpp, _tgtHsCpp + -- * Re-exports , ByteOrder(..) ) where @@ -137,3 +140,29 @@ instance Show Target where , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] + +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_tgtCC :: Lens Target Cc +_tgtCC = Lens tgtCCompiler (\x o -> o {tgtCCompiler = x}) + +_tgtCxx :: Lens Target Cxx +_tgtCxx = Lens tgtCxxCompiler (\x o -> o {tgtCxxCompiler = x}) + +_tgtCpp :: Lens Target Cpp +_tgtCpp = Lens tgtCPreprocessor (\x o -> o {tgtCPreprocessor = x}) + +_tgtHsCpp :: Lens Target HsCpp +_tgtHsCpp = Lens tgtHsCPreprocessor (\x o -> o {tgtHsCPreprocessor = x}) + +_tgtJsCpp :: Lens Target (Maybe JsCpp) +_tgtJsCpp = Lens tgtJsCPreprocessor (\x o -> o {tgtJsCPreprocessor = x}) + +_tgtCmmCpp :: Lens Target CmmCpp +_tgtCmmCpp = Lens tgtCmmCPreprocessor (\x o -> o {tgtCmmCPreprocessor = x}) + +_tgtMergeObjs :: Lens Target (Maybe MergeObjs) +_tgtMergeObjs = Lens tgtMergeObjs (\x o -> o {tgtMergeObjs = x}) + ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs ===================================== @@ -5,6 +5,9 @@ module GHC.Toolchain.Tools.Cpp , Cpp(..), findCpp , JsCpp(..), findJsCpp , CmmCpp(..), findCmmCpp + + -- * Lenses + , _cppProg, _hsCppProg, _jsCppProg, _cmmCppProg ) where import Control.Monad @@ -188,3 +191,18 @@ findCpp progOpt cc = checking "for C preprocessor" $ do let cppProgram = addFlagIfNew "-E" cpp2 return Cpp{cppProgram} +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_cppProg :: Lens Cpp Program +_cppProg = Lens cppProgram (\x o -> o{cppProgram = x}) + +_hsCppProg :: Lens HsCpp Program +_hsCppProg = Lens hsCppProgram (\x o -> o{hsCppProgram = x}) + +_jsCppProg :: Lens JsCpp Program +_jsCppProg = Lens jsCppProgram (\x o -> o{jsCppProgram = x}) + +_cmmCppProg :: Lens CmmCpp Program +_cmmCppProg = Lens cmmCppProgram (\x o -> o{cmmCppProgram = x}) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs ===================================== @@ -4,7 +4,7 @@ module GHC.Toolchain.Tools.Cxx ( Cxx(..) , findCxx -- * Helpful utilities - , compileCxx + , compileCxx, _cxxProgram ) where import System.FilePath View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ef14990d11543059e7629adea0845c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ef14990d11543059e7629adea0845c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/24212] 20 commits: Implement user-defined allocation limit handlers
by Rodrigo Mesquita (＠alt-romes) 14 Jul '25

14 Jul '25

Rodrigo Mesquita pushed to branch wip/romes/24212 at Glasgow Haskell Compiler / GHC Commits: ea2c6673 by Teo Camarasu at 2025-07-08T13:24:43-04:00 Implement user-defined allocation limit handlers Allocation Limits allow killing a thread if they allocate more than a user-specified limit. We extend this feature to allow more versatile behaviour. - We allow not killing the thread if the limit is exceeded. - We allow setting a custom handler to be called when the limit is exceeded. User-specified allocation limit handlers run in a fresh thread and are passed the ThreadId of the thread that exceeded its limit. We introduce utility functions for getting and setting the allocation limits of other threads, so that users can reset the limit of a thread from a handler. Both of these are somewhat coarse-grained as we are unaware of the allocations in the current nursery chunk. We provide several examples of usages in testsuite/tests/rts/T22859.hs Resolves #22859 - - - - - 03e047f9 by Simon Hengel at 2025-07-08T13:25:25-04:00 Fix typo in using.rst - - - - - 67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00 compiler: Import AnnotationWrapper from ghc-internal Since `GHC.Desugar` exported from `base` has been deprecated. - - - - - 813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-compact: Eliminate dependency on ghc-prim - - - - - 0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Eliminate dependency on ghc-prim - - - - - 480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Drop redundant import - - - - - 03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00 ghc-prim: Bump version to 0.13.1 There are no interface changes from 0.13.0 but the implementation now lives in `ghc-internal`. - - - - - d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00 template-haskell: Bump version number to 2.24.0.0 Bumps exceptions submodule. - - - - - 004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump GHC version number to 9.14 - - - - - eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump parsec to 3.1.18.0 Bumps parsec submodule. - - - - - 86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00 unix: Bump to 2.8.7.0 Bumps unix submodule. - - - - - 89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00 binary: Bump to 0.8.9.3 Bumps binary submodule. - - - - - 55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00 Win32: Bump to 2.14.2.0 Bumps Win32 submodule. - - - - - 7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00 base: Bump version to 4.22.0 Bumps various submodules. - - - - - ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00 base: Export displayExceptionWithInfo This function should be exposed from base following CLC#285 Approved change in CLC#344 Fixes #26058 - - - - - 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - ccef90b4 by Rodrigo Mesquita at 2025-07-14T13:49:35+01:00 ghc-toolchain: Use ByteOrder rather than new Endianness Don't introduce a duplicate datatype when the previous one is equivalent and already used elsewhere. This avoids unnecessary translation between the two. - - - - - 1a08530e by Rodrigo Mesquita at 2025-07-14T13:52:08+01:00 Read Toolchain.Target files rather than 'settings' This commit makes GHC read `lib/targets/default.target`, a file with a serialized value of `ghc-toolchain`'s `GHC.Toolchain.Target`. Moreover, it removes all the now-redundant entries from `lib/settings` that are configured as part of a `Target` but were being written into `settings`. This makes it easier to support multiple targets from the same compiler (aka runtime retargetability). `ghc-toolchain` can be re-run many times standalone to produce a `Target` description for different targets, and, in the future, GHC will be able to pick at runtime amongst different `Target` files. This commit only makes it read the default `Target` configured in-tree or configured when installing the bindist. The remaining bits of `settings` need to be moved to `Target` in follow up commits, but ultimately they all should be moved since they are per-target relevant. Fixes #24212 - - - - - 96 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/SysTools/BaseDir.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/ghc.cabal.in - configure.ac - distrib/configure.ac.in - docs/users_guide/eventlog-formats.rst - docs/users_guide/using.rst - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Base.hs - hadrian/src/Rules/Generate.hs - libraries/Win32 - libraries/array - libraries/base/base.cabal.in - libraries/base/src/Control/Exception.hs - libraries/binary - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/GHC/Compact.hs - libraries/ghc-compact/GHC/Compact/Serialized.hs - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/System/Mem/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/text - libraries/unix - − m4/fp_settings.m4 - m4/fp_setup_windows_toolchain.m4 - + m4/subst_tooldir.m4 - mk/hsc2hs.in - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsStartup.c - rts/RtsSymbols.c - rts/Schedule.c - rts/external-symbols.list.in - rts/include/rts/storage/GC.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/ghc-api/T20757.hs - testsuite/tests/ghc-api/settings-escape/T24265.hs - testsuite/tests/ghc-api/settings-escape/T24265.stderr - + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/T22859.stderr - testsuite/tests/rts/all.T - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/PlatformDetails.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d585fb63786fb4aec7bb900855e80a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d585fb63786fb4aec7bb900855e80a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bump-win32-tarballs] 2 commits: testsuite: Mark T12497 as fixed
by Ben Gamari (＠bgamari) 14 Jul '25

14 Jul '25

Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC Commits: 2433b8c9 by Ben Gamari at 2025-07-13T18:31:44-04:00 testsuite: Mark T12497 as fixed Thanks to the LLVM toolchain update. Closes #22694. - - - - - 298cf6b7 by Ben Gamari at 2025-07-13T18:35:17-04:00 testsuite: Accept new output of T11223_link_order_a_b_2_fail on Windows The archive member number changed due to the fact that llvm-ar now uses a string table. - - - - - 3 changed files: - testsuite/tests/rts/all.T - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 Changes: ===================================== testsuite/tests/rts/all.T ===================================== @@ -426,9 +426,7 @@ test('T10296b', [only_ways(['threaded2'])], compile_and_run, ['']) test('numa001', [ extra_run_opts('8'), unless(unregisterised(), extra_ways(['debug_numa'])), req_ghc_with_threaded_rts ] , compile_and_run, ['']) -test('T12497', [ unless(opsys('mingw32'), skip), expect_broken(22694) - ], - makefile_test, ['T12497']) +test('T12497', normal, makefile_test, ['T12497']) test('T13617', [ unless(opsys('mingw32'), skip)], makefile_test, ['T13617']) ===================================== testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 ===================================== @@ -3,7 +3,7 @@ GHC runtime linker: fatal error: I found a duplicate definition for symbol whilst processing object file E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libfoo_link_lib_3.a The symbol was previously defined in - E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#2:bar_link_lib_3.o) + E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#3:bar_link_lib_3.o) This could be caused by: * Loading two different object files which export the same symbol * Specifying the same object file twice on the GHCi command line ===================================== testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 ===================================== @@ -3,7 +3,7 @@ GHC runtime linker: fatal error: I found a duplicate definition for symbol whilst processing object file E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libfoo_link_lib_3.a The symbol was previously defined in - E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#2:bar_link_lib_3.o) + E:\ghc-dev\msys64\home\Tamar\ghc\testsuite\tests\rts\T11223\T11223_link_order_a_b_2_fail.run\libbar_link_lib_3.a(#3:bar_link_lib_3.o) This could be caused by: * Loading two different object files which export the same symbol * Specifying the same object file twice on the GHCi command line View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d8fce70410b784a2da1c73a82fbb8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d8fce70410b784a2da1c73a82fbb8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/ctorig-stuff] 84 commits: Consider `PromotedDataCon` in `tyConStupidTheta`
by Apoorv Ingle (＠ani) 14 Jul '25

14 Jul '25

Apoorv Ingle pushed to branch wip/ani/ctorig-stuff at Glasgow Haskell Compiler / GHC Commits: 8d33d048 by Berk Özkütük at 2025-07-07T20:42:20-04:00 Consider `PromotedDataCon` in `tyConStupidTheta` Haddock checks data declarations for the stupid theta so as not to pretty-print them as empty contexts. Type data declarations end up as `PromotedDataCon`s by the time Haddock performs this check, causing a panic. This commit extends `tyConStupidTheta` so that it returns an empty list for `PromotedDataCon`s. This decision was guided by the fact that type data declarations never have data type contexts (see (R1) in Note [Type data declarations]). Fixes #25739. - - - - - a26243fd by Ryan Hendrickson at 2025-07-07T20:43:07-04:00 haddock: Document instances from other packages When attaching instances to `Interface`s, it isn't enough just to look for instances in the list of `Interface`s being processed. We also need to look in the modules on which they depend, including those outside of this package. Fixes #25147. Fixes #26079. - - - - - 0fb24420 by Rodrigo Mesquita at 2025-07-07T20:43:49-04:00 hadrian: Fallback logic for internal interpreter When determining whether to build the internal interpreter, the `make` build system had a fallback case for platforms not in the list of explicitly-supported operating systems and architectures. This fallback says we should try to build the internal interpreter if building dynamic GHC programs (if the architecture is unknown). Fixes #24098 - - - - - fe925bd4 by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Reference Wasm FFI section - - - - - 5856284b by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Fix too-short heading warning - - - - - a48dcdf3 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Reorganise documentation for allocate* functions Consolodate interface information into the .h file, keeping just implementation details in the .c file. Use Notes stlye in the .h file and refer to notes from the .c file. - - - - - de5b528c by Duncan Coutts at 2025-07-07T20:45:18-04:00 Introduce common utilities for allocating arrays The intention is to share code among the several places that do this already. - - - - - b321319d by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Heap.c The CMM primop can now report heap overflow. - - - - - 1d557ffb by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in ThreadLabels.c Replacing a local utility. - - - - - e59a1430 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Threads.c Replacing local open coded version. - - - - - 482df1c9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Add exitHeapOverflow helper utility This will be useful with the array alloc functions, since unlike allocate/allocateMaybeFail, they do not come in two versions. So if it's not convenient to propagate failure, then one can use this. - - - - - 4d3ec8f9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Weak.c Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The benefit of this is that it allows us to referece CCS_SYSTEM even when we're not in PROFILING mode. That makes abstracting over profiling vs normal mode a lot easier. - - - - - 0c4f2fde by Duncan Coutts at 2025-07-07T20:45:18-04:00 Convert the array alloc primops to use the new array alloc utils - - - - - a3354ad9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 While we're at it, add one missing 'likely' hint To a cmm primops that raises an exception, like the others now do. - - - - - 33b546bd by meooow25 at 2025-07-07T20:46:09-04:00 Keep scanl' strict in the head on rewrite `scanl'` forces elements to WHNF when the corresponding `(:)`s are forced. The rewrite rule for `scanl'` missed forcing the first element, which is fixed here with a `seq`. - - - - - 8a69196e by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 73d3f864 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 docs: Case continuation BCOs This commit documents a subtle interaction between frames for case BCOs and their parents frames. Namely, case continuation BCOs may refer to (non-local) variables that are part of the parent's frame. The note expanding a bit on these details is called [Case continuation BCOs] - - - - - d7aeddcf by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key idea is simple: When step-out is enabled, traverse the runtime stack until a continuation BCO is found -- and enable the breakpoint heading that BCO explicitly using its tick-index. The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`. Since PUSH_ALTS BCOs (representing case continuations) were never headed by a breakpoint (unlike the case alternatives they push), we introduced the BRK_ALTS instruction to allow the debugger to set a case continuation to stop at the breakpoint heading the alternative that is taken. This is further described in `Note [Debugger: BRK_ALTS]`. Fixes #26042 - - - - - 5d9adf51 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Filter step-out stops by SrcSpan To implement step-out, the RTS looks for the first continuation frame on the stack and explicitly enables its entry breakpoint. However, some continuations will be contained in the function from which step-out was initiated (trivial example is a case expression). Similarly to steplocal, we will filter the breakpoints at which the RTS yields to the debugger based on the SrcSpan. When doing step-out, only stop if the breakpoint is /not/ contained in the function from which we initiated it. This is especially relevant in monadic statements such as IO which is compiled to a long chain of case expressions. See Note [Debugger: Filtering step-out stops] - - - - - 7677adcc by Cheng Shao at 2025-07-08T07:40:29-04:00 compiler: make ModBreaks serializable - - - - - 14f67c6d by Rodrigo Mesquita at 2025-07-08T07:40:29-04:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - 9d3f484a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - b595f713 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - d223227a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 7fdd0a3d by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - 5e4da31b by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 741ac3a8 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 0414fcc9 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refact: Split InternalModBreaks out of ModBreaks There are currently two competing ways of referring to a Breakpoint: 1. Using the Tick module + Tick index 2. Using the Info module + Info index 1. The Tick index is allocated during desugaring in `mkModBreaks`. It is used to refer to a breakpoint associated to a Core Tick. For a given Tick module, there are N Ticks indexed by Tick index. 2. The Info index is allocated during code generation (in StgToByteCode) and uniquely identifies the breakpoints at runtime (and is indeed used to determine which breakpoint was hit at runtime). Why we need both is described by Note [Breakpoint identifiers]. For every info index we used to keep a `CgBreakInfo`, a datatype containing information relevant to ByteCode Generation, in `ModBreaks`. This commit splits out the `IntMap CgBreakInfo` out of `ModBreaks` into a new datatype `InternalModBreaks`. - The purpose is to separate the `ModBreaks` datatype, which stores data associated from tick-level information which is fixed after desugaring, from the unrelated `IntMap CgBreakInfo` information accumulated during bytecode generation. - We move `ModBreaks` to GHC.HsToCore.Breakpoints The new `InternalModBreaks` simply combines the `IntMap CgBreakInfo` with `ModBreaks`. After code generation we construct an `InternalModBreaks` with the `CgBreakInfo`s we accumulated and the existing `ModBreaks` and store that in the compiled BCO in `bc_breaks`. - Note that we previously only updated the `modBreaks_breakInfo` field of `ModBreaks` at this exact location, and then stored the updated `ModBreaks` in the same `bc_breaks`. - We put this new datatype in GHC.ByteCode.Breakpoints The rest of the pipeline for which CgBreakInfo is relevant is accordingly updated to also use `InternalModBreaks` - - - - - 2a097955 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Use BreakpointIds in bytecode gen Small clean up to use BreakpointId and InternalBreakpointId more uniformly in bytecode generation rather than using Module + Ix pairs - - - - - 0515cc2f by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 ghci: Allocate BreakArrays at link time only Previously, a BreakArray would be allocated with a slot for every tick in a module at `mkModBreaks`, in HsToCore. However, this approach has a few downsides: - It interleaves interpreter behaviour (allocating arrays for breakpoints) within the desugarer - It is inflexible in the sense it is impossible for the bytecode generator to add "internal" breakpoints that can be triggered at runtime, because those wouldn't have a source tick. (This is relevant for our intended implementation plan of step-out in #26042) - It ties the BreakArray indices to the *tick* indexes, while at runtime we would rather just have the *info* indexes (currently we have both because BreakArrays are indexed by the *tick* one). Paving the way for #26042 and #26064, this commit moves the allocation of BreakArrays to bytecode-loading time -- akin to what is done for CCS arrays. Since a BreakArray is allocated only when bytecode is linked, if a breakpoint is set (e.g. `:break 10`) before the bytecode is linked, there will exist no BreakArray to trigger the breakpoint in. Therefore, the function to allocate break arrays (`allocateBreakArrays`) is exposed and also used in GHC.Runtime.Eval to allocate a break array when a breakpoint is set, if it doesn't exist yet (in the linker env). - - - - - 8016561f by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add a test for T26176 - - - - - 454cd682 by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add test for #14010 This test started to work in GHC 9.6 and has worked since. This MR just adds a regression test - - - - - ea2c6673 by Teo Camarasu at 2025-07-08T13:24:43-04:00 Implement user-defined allocation limit handlers Allocation Limits allow killing a thread if they allocate more than a user-specified limit. We extend this feature to allow more versatile behaviour. - We allow not killing the thread if the limit is exceeded. - We allow setting a custom handler to be called when the limit is exceeded. User-specified allocation limit handlers run in a fresh thread and are passed the ThreadId of the thread that exceeded its limit. We introduce utility functions for getting and setting the allocation limits of other threads, so that users can reset the limit of a thread from a handler. Both of these are somewhat coarse-grained as we are unaware of the allocations in the current nursery chunk. We provide several examples of usages in testsuite/tests/rts/T22859.hs Resolves #22859 - - - - - 03e047f9 by Simon Hengel at 2025-07-08T13:25:25-04:00 Fix typo in using.rst - - - - - 67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00 compiler: Import AnnotationWrapper from ghc-internal Since `GHC.Desugar` exported from `base` has been deprecated. - - - - - 813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-compact: Eliminate dependency on ghc-prim - - - - - 0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Eliminate dependency on ghc-prim - - - - - 480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Drop redundant import - - - - - 03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00 ghc-prim: Bump version to 0.13.1 There are no interface changes from 0.13.0 but the implementation now lives in `ghc-internal`. - - - - - d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00 template-haskell: Bump version number to 2.24.0.0 Bumps exceptions submodule. - - - - - 004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump GHC version number to 9.14 - - - - - eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump parsec to 3.1.18.0 Bumps parsec submodule. - - - - - 86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00 unix: Bump to 2.8.7.0 Bumps unix submodule. - - - - - 89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00 binary: Bump to 0.8.9.3 Bumps binary submodule. - - - - - 55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00 Win32: Bump to 2.14.2.0 Bumps Win32 submodule. - - - - - 7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00 base: Bump version to 4.22.0 Bumps various submodules. - - - - - ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00 base: Export displayExceptionWithInfo This function should be exposed from base following CLC#285 Approved change in CLC#344 Fixes #26058 - - - - - 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - 1064d428 by Apoorv Ingle at 2025-07-13T23:24:02-05:00 - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed. - Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx` - `tcXExpr` is less hacky now - do not look through HsExpansion applications - kill OrigPat and remove HsThingRn From VAExpansion - look through XExpr ExpandedThingRn while inferring type of head - always set in generated code after stepping inside a ExpandedThingRn - fixing record update error messages - remove special case of tcbody from tcLambdaMatches - wrap last stmt expansion in a HsPar so that the error messages are prettier - remove special case of dsExpr for ExpandedThingTc - make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn - fixing error messages for rebindable - - - - - 08c3422b by Apoorv Ingle at 2025-07-13T23:24:02-05:00 fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs - - - - - 3d9d7755 by Apoorv Ingle at 2025-07-13T23:24:02-05:00 move setQLInstLevel inside tcInstFun - - - - - e0d2cee3 by Apoorv Ingle at 2025-07-13T23:24:02-05:00 ignore ds warnings originating from gen locations - - - - - fd973345 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 filter expr stmts error msgs - - - - - 9cdc7d5d by Apoorv Ingle at 2025-07-13T23:24:03-05:00 exception for AppDo while making error ctxt - - - - - 06e81188 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 moving around things for locations and error ctxts - - - - - 2642c7f5 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements - - - - - b106975a by Apoorv Ingle at 2025-07-13T23:24:03-05:00 accept test cases with changed error messages ------------------------- Metric Decrease: T9020 ------------------------- - - - - - 713d39ca by Apoorv Ingle at 2025-07-13T23:24:03-05:00 look through PopErrCtxt while splitting exprs in application chains - - - - - 180dbc1a by Apoorv Ingle at 2025-07-13T23:24:03-05:00 check the right origin for record selector incomplete warnings - - - - - b2781fdf by Apoorv Ingle at 2025-07-13T23:24:03-05:00 kill VAExpansion - - - - - d79a6a34 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - bc8c1310 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 do not suppress pprArising - - - - - ca44e03f by Apoorv Ingle at 2025-07-13T23:24:03-05:00 kill VACall - - - - - fd6b0693 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 kill AppCtxt - - - - - 901e421b by Apoorv Ingle at 2025-07-13T23:24:03-05:00 remove addHeadCtxt - - - - - 9904b6f3 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 fix pprArising for MonadFailErrors - - - - - 34beb3a0 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 rename ctxt to sloc - - - - - ec6a5a12 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 fix RepPolyDoBind error message herald - - - - - 87b98b93 by Apoorv Ingle at 2025-07-13T23:24:03-05:00 SrcCodeCtxt more changes - - - - - 59f3bc6c by Apoorv Ingle at 2025-07-13T23:24:03-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - cadafb2d by Apoorv Ingle at 2025-07-13T23:24:03-05:00 make error messages for records saner - - - - - 65d228aa by Apoorv Ingle at 2025-07-13T23:24:03-05:00 accept the right test output - - - - - e691cf3a by Apoorv Ingle at 2025-07-13T23:24:04-05:00 make make sure to set inGenerated code for RecordUpdate checks - - - - - 8f41ac59 by Apoorv Ingle at 2025-07-13T23:24:04-05:00 rename HsThingRn to SrcCodeOrigin - - - - - 909aeb20 by Apoorv Ingle at 2025-07-13T23:24:04-05:00 minor lclenv getter setter changes - - - - - a4034728 by Apoorv Ingle at 2025-07-13T23:24:04-05:00 fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin - - - - - 000adfee by Apoorv Ingle at 2025-07-13T23:24:04-05:00 undo test changes - - - - - e44614ef by Apoorv Ingle at 2025-07-13T23:24:04-05:00 fix unused do binding warning error location - - - - - aed0281b by Apoorv Ingle at 2025-07-13T23:24:04-05:00 FRRRecordUpdate message change - - - - - b45afebd by Apoorv Ingle at 2025-07-13T23:24:04-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - 95fe544c by Apoorv Ingle at 2025-07-13T23:24:04-05:00 kill ExpectedFunTyOrig - - - - - b99d0532 by Apoorv Ingle at 2025-07-14T06:57:23-05:00 update argument position number of CtOrigin - - - - - 228 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/eventlog-formats.rst - docs/users_guide/exts/doandifthenelse.rst - docs/users_guide/exts/ffi.rst - docs/users_guide/ghci.rst - docs/users_guide/using.rst - ghc/GHCi/UI.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Program.hs - libraries/Win32 - libraries/array - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Control/Exception.hs - libraries/binary - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/GHC/Compact.hs - libraries/ghc-compact/GHC/Compact/Serialized.hs - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/System/Mem/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/text - libraries/unix - + rts/AllocArray.c - + rts/AllocArray.h - rts/Disassembler.c - rts/Heap.c - rts/Interpreter.c - rts/Interpreter.h - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsStartup.c - rts/RtsSymbols.c - rts/RtsUtils.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/ThreadLabels.c - rts/Threads.c - rts/Weak.c - rts/external-symbols.list.in - rts/include/Rts.h - rts/include/rts/Bytecodes.h - rts/include/rts/Constants.h - rts/include/rts/prof/CCS.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/GC.h - rts/include/rts/storage/Heap.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/rts.cabal - rts/sm/Storage.c - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/default/default-fail05.stderr - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d.hs - + testsuite/tests/ghci.debugger/scripts/T26042d.script - + testsuite/tests/ghci.debugger/scripts/T26042d.stdout - + testsuite/tests/ghci.debugger/scripts/T26042e.hs - + testsuite/tests/ghci.debugger/scripts/T26042e.script - + testsuite/tests/ghci.debugger/scripts/T26042e.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f.hs - + testsuite/tests/ghci.debugger/scripts/T26042f.script - + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr - + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - + testsuite/tests/ghci.debugger/scripts/T26042g.hs - + testsuite/tests/ghci.debugger/scripts/T26042g.script - + testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/indexed-types/should_fail/T26176.hs - + testsuite/tests/indexed-types/should_fail/T26176.stderr - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/indexed-types/should_fail/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T13393.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - + testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/T22859.stderr - testsuite/tests/rts/all.T - + testsuite/tests/typecheck/should_compile/T14010.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T24064.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail168.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr - utils/haddock/CHANGES.md - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock-test/src/Test/Haddock/Config.hs - utils/haddock/haddock.cabal - utils/haddock/html-test/ref/Bug1004.html - + utils/haddock/html-test/ref/Bug25739.html - + utils/haddock/html-test/src/Bug25739.hs - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1864b1a8995c39e7dea7f994de527… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1864b1a8995c39e7dea7f994de527… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/perf_notes_docs
by Andreas Klebinger (＠AndreasK) 14 Jul '25

14 Jul '25

Andreas Klebinger pushed new branch wip/andreask/perf_notes_docs at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/perf_notes_docs You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T20264] Fix two tricky buglets
by Simon Peyton Jones (＠simonpj) 14 Jul '25

14 Jul '25

Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 83ac6b6b by Simon Peyton Jones at 2025-07-14T12:00:17+01:00 Fix two tricky buglets - - - - - 2 changed files: - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/FloatIn.hs ===================================== @@ -432,9 +432,20 @@ idRuleAndUnfoldingVars of x. No need for type variables, hence not using idFreeVars. -} +fiExpr platform to_drop (_,AnnLet (AnnNonRec bndr (rhs_fvs, rhs)) body) + | Just bind' <- is_tyco_rhs rhs -- See Note [Don't float in type or coercion lets] + = wrapFloats drop_here $ + Let bind' (fiExpr platform body_drop body) + where + is_tyco_rhs :: CoreExprWithFVs' -> Maybe CoreBind + is_tyco_rhs (AnnType ty) = Just (NonRec bndr (Type ty)) + is_tyco_rhs (AnnCoercion co) = Just (NonRec bndr (Coercion co)) + is_tyco_rhs _ = Nothing + + (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop + rhs_fvs [freeVarsOf body] + fiExpr platform to_drop (_,AnnLet bind body) - | Just bind' <- is_tyco_bind bind -- See Note [Don't float in type or coercion lets] - = Let bind' (fiExpr platform to_drop body) | otherwise = fiExpr platform (after ++ new_float : before) body -- to_drop is in reverse dependency order @@ -442,10 +453,6 @@ fiExpr platform to_drop (_,AnnLet bind body) (before, new_float, after) = fiBind platform to_drop bind body_fvs body_fvs = freeVarsOf body - is_tyco_bind :: CoreBindWithFVs -> Maybe CoreBind - is_tyco_bind (AnnNonRec bndr (_, AnnType ty)) = Just (NonRec bndr (Type ty)) - is_tyco_bind (AnnNonRec bndr (_, AnnCoercion co)) = Just (NonRec bndr (Coercion co)) - is_tyco_bind _ = Nothing {- Note [Floating primops] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -530,7 +537,7 @@ Note [Don't float in type or coercion lets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't float type-lets or coercion-lets inward. Doing so does not save allocation; and if we did we't have to be careful of the variables -mentiond in the idType of the case-binder. For example +mentioned in the idType of the case-binder. For example \(x :: Maybe b) -> let a = Maybe b in case x of (cb :: a) of { Just y -> ... } We must not float the `a = Maybe b` into the case alternatives, because ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2718,9 +2718,10 @@ occAnalApp !env (Var fun, args, ticks) -- we don't want to occ-anal them twice in the runRW# case! -- This caused #18296 | fun `hasKey` runRWKey - , [t1, t2, arg] <- args + , [a1@(Type t1), a2@(Type t2), arg] <- args , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg - = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + = WUD (usage `addTyCoOccs` occAnalTy t1 `addTyCoOccs` occAnalTy t2) + (mkTicks ticks $ mkApps (Var fun) [a1, a2, arg']) occAnalApp env (Var fun_id, args, ticks) = WUD all_uds (mkTicks ticks app') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83ac6b6bf44a2abc0e6110d75f5943e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83ac6b6bf44a2abc0e6110d75f5943e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T20264] Wibble imports again
by Simon Peyton Jones (＠simonpj) 14 Jul '25

14 Jul '25

Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 028e1bea by Simon Peyton Jones at 2025-07-14T09:02:59+01:00 Wibble imports again - - - - - 1 changed file: - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -128,7 +128,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , nonDetCmpUnique ) -import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, TyCoOccInfo(..) ) +import GHC.Types.Basic( TypeOrConstraint(..), TyCoOccInfo(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/028e1beaf3bd9c98ecb3d6c33793f20… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/028e1beaf3bd9c98ecb3d6c33793f20… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T20264] Wibble imports
by Simon Peyton Jones (＠simonpj) 14 Jul '25

14 Jul '25

Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 26ad8ab2 by Simon Peyton Jones at 2025-07-14T08:13:03+01:00 Wibble imports - - - - - 1 changed file: - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -128,7 +128,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , nonDetCmpUnique ) -import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo, TyCoOccInfo(..) ) +import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, TyCoOccInfo(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/26ad8ab2d90bd3454eac1a3b14be9a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/26ad8ab2d90bd3454eac1a3b14be9a0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/ctorig-stuff] 6 commits: fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin,...
by Apoorv Ingle (＠ani) 14 Jul '25

14 Jul '25

Apoorv Ingle pushed to branch wip/ani/ctorig-stuff at Glasgow Haskell Compiler / GHC Commits: e12c1e9d by Apoorv Ingle at 2025-06-29T20:27:28-05:00 fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin - - - - - d37adc69 by Apoorv Ingle at 2025-06-29T21:37:38-05:00 undo test changes - - - - - bde2465e by Apoorv Ingle at 2025-07-02T16:02:03-05:00 fix unused do binding warning error location - - - - - e199446b by Apoorv Ingle at 2025-07-02T16:11:44-05:00 FRRRecordUpdate message change - - - - - 2fb3b1ba by Apoorv Ingle at 2025-07-07T00:16:14-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - e1864b1a by Apoorv Ingle at 2025-07-13T21:14:25-05:00 kill ExpectedFunTyOrig - - - - - 17 changed files: - compiler/GHC/Hs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/deSugar/should_compile/T10662.stderr - testsuite/tests/deSugar/should_compile/T3263-1.stderr - testsuite/tests/deSugar/should_compile/T3263-2.stderr - testsuite/tests/ghci.debugger/scripts/break029.script - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -38,8 +38,6 @@ module GHC.Hs ( HsModule(..), AnnsModule(..), HsParsedModule(..), XModulePs(..), - SrcCodeCtxt(..), isUserCodeCtxt, isGeneratedCodeCtxt - ) where -- friends: @@ -149,17 +147,3 @@ data HsParsedModule = HsParsedModule { -- the .hi file, so that we can force recompilation if any of -- them change (#3589) } - --- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression --- is a user generated code or a compiler generated expansion of some user written code -data SrcCodeCtxt - = UserCode - | GeneratedCode SrcCodeOrigin - -isUserCodeCtxt :: SrcCodeCtxt -> Bool -isUserCodeCtxt UserCode = True -isUserCodeCtxt _ = False - -isGeneratedCodeCtxt :: SrcCodeCtxt -> Bool -isGeneratedCodeCtxt UserCode = False -isGeneratedCodeCtxt _ = True ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -1234,8 +1234,8 @@ Other places that requires from the same treatment: -- Warn about certain types of values discarded in monadic bindings (#3263) warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs m_ty elt_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind +warnDiscardedDoBindings rhs@(L rhs_loc _) m_ty elt_ty + = putSrcSpanDsA rhs_loc $ do { warn_unused <- woptM Opt_WarnUnusedDoBind ; warn_wrong <- woptM Opt_WarnWrongDoBind ; when (warn_unused || warn_wrong) $ do { fam_inst_envs <- dsGetFamInstEnvs ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -189,8 +189,8 @@ tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_expr code_ctxt + ; code_orig <- getSrcCodeOrigin + ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args ; tc_args <- tcValArgs do_ql rn_fun inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args @@ -417,8 +417,8 @@ tcApp rn_expr exp_res_ty ; let tc_head = (tc_fun, fun_loc) -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt + ; code_orig <- getSrcCodeOrigin + ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma @@ -857,8 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) - = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs - | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) + = do { let herald = ExpectedFunTyArg pos (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int @@ -877,7 +876,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i = do { arg_nu <- newOpenFlexiFRRTyVarTy $ - FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i + FRRExpectedFunTy (ExpectedFunTyArg i (HsExprTcThing tc_fun) arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -976,7 +976,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = ExpectedFunTySyntaxOp orig op + herald = ExpectedFunTySyntaxOp 1 orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1005,7 +1005,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = ExpectedFunTySyntaxOp orig op + herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -655,7 +655,7 @@ tcInferOverLit lit@(OverLit { ol_val = val ; let thing = NameThing from_name mb_thing = Just thing - herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) + herald = ExpectedFunTyArg 1 thing (HsLit noExtField hs_lit) ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -118,7 +118,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments arity <- checkArgCounts matches - + ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) @@ -138,7 +138,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty ; return (wrap_fun, r) } where mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn - herald = ExpectedFunTyMatches (NameThing fun_name) matches + funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts }) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -698,7 +698,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Note [View patterns and polymorphism] -- Expression must be a function - ; let herald = ExpectedFunTyViewPat $ unLoc expr + ; let herald = ExpectedFunTyViewPat 1 $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty -- See Note [View patterns and polymorphism] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -17,7 +17,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin ) +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) import GHC.Tc.Zonk.Monad ( ZonkM ) @@ -120,7 +120,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int + | FunTysCtxt !CtOrigin !Type !Int !Int -- | In the result of a function call. | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int -- | In the declaration of a type constructor. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,13 +21,14 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvSrcCodeCtxt - , setLclEnvSrcCodeCtxt - , setLclCtxtSrcCodeCtxt + , getLclEnvSrcCodeOrigin + , setLclEnvSrcCodeOrigin + , setLclCtxtSrcCodeOrigin , lclEnvInGeneratedCode , addLclEnvErrCtxt + , ErrCtxtStack (..) , ArrowCtxt(..) , ThBindEnv , TcTypeEnv @@ -35,7 +36,7 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeCtxt (..), isGeneratedCodeCtxt ) +import GHC.Hs ( SrcCodeOrigin ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -90,11 +91,29 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } + +data ErrCtxtStack + = UserCodeCtxt {err_ctxt :: [ErrCtxt]} + | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin + , err_ctxt :: [ErrCtxt] } + +isGeneratedCodeCtxt :: ErrCtxtStack -> Bool +isGeneratedCodeCtxt UserCodeCtxt{} = False +isGeneratedCodeCtxt _ = True + +get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin +get_src_code_origin (UserCodeCtxt{}) = Nothing +get_src_code_origin es = Just $ src_code_origin es + +modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack +modify_err_ctxt_stack f (UserCodeCtxt e) = UserCodeCtxt (f e) +modify_err_ctxt_stack _ c = c -- any updates on the err context in generated context should be ignored + + data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_in_gen_code :: SrcCodeCtxt, + tcl_ctxt :: ErrCtxtStack, tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -159,28 +178,28 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt }) +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) }) +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) }) -getLclEnvSrcCodeCtxt :: TcLclEnv -> SrcCodeCtxt -getLclEnvSrcCodeCtxt = tcl_in_gen_code . tcl_lcl_ctxt +getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt -lclEnvInGeneratedCode :: TcLclEnv -> Bool -lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt +setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv +setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) -lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_in_gen_code +setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt +setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) } -setLclCtxtSrcCodeCtxt :: SrcCodeCtxt -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeCtxt userOrGen env = env { tcl_in_gen_code = userOrGen } +lclCtxtInGeneratedCode :: TcLclCtxt -> Bool +lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt -setLclEnvSrcCodeCtxt :: SrcCodeCtxt -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeCtxt userOrGen = modifyLclCtxt (\ctxt -> setLclCtxtSrcCodeCtxt userOrGen ctxt) +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt getLclEnvBinderStack :: TcLclEnv -> TcBinderStack getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeCtxtCtOrigin, + srcCodeOriginCtOrigin, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, isWantedSuperclassOrigin, @@ -45,7 +45,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, + pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -653,6 +653,62 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice + | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin + + + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + | forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp Int + !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat Int + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + Int + -- ^ Argument number + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches Int + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + + + data NonLinearPatternReason = LazyPatternReason | GeneralisedPatternReason @@ -737,7 +793,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (HsProjection _ _) = SectionOrigin +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" @@ -763,18 +819,14 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o +exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin -srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e -srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin -srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p -srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin -srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e -srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e +srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin e Nothing = exprCtOrigin e +srcCodeOriginCtOrigin _ (Just e) = ExpansionOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -800,6 +852,14 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk +pprCtOrigin (ExpansionOrigin o) + = ctoHerald <+> what + where what :: SDoc + what = case o of + OrigStmt{} -> text "a do statement" + OrigExpr e -> pprCtO (exprCtOrigin e) + OrigPat p -> text "a pattern" <+> ppr p + pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -912,9 +972,38 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) +pprCtOrigin (ExpectedFunTySyntaxOp i orig op) = + vcat [ sep [ the_arg_of i + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] +pprCtOrigin (ExpectedFunTyViewPat i expr) = + vcat [ the_arg_of i <+> text "the view pattern" + , nest 2 (ppr expr) ] +pprCtOrigin (ExpectedFunTyArg i fun arg) = + sep [ text "The" <+> speakNth i <+> text "argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] +pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts })) + | null alts + = the_arg_of i <+> quotes (ppr fun) + | otherwise + = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) +pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin + +the_arg_of :: Int -> SDoc +the_arg_of i = text "The" <+> speakNth i <+> text "argument of" + +binder_of :: SDoc -> SDoc +binder_of what = text "The binder of the" <+> what <+> text "expression" + + -- | Short one-liners pprCtO :: HasDebugCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] @@ -940,7 +1029,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoStmtOrigin = text "a do statement" +pprCtO DoStmtOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" @@ -983,6 +1072,14 @@ pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" pprCtO (ImpedanceMatching {}) = text "combining required constraints" pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] +pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)] +pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement" +pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e +pprCtO (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" +pprCtO (ExpectedFunTyViewPat{}) = text "a view pattern" +pprCtO (ExpectedFunTyArg{}) = text "a funtion head" +pprCtO (ExpectedFunTyMatches{}) = text "a match statement" +pprCtO (ExpectedFunTyLam{}) = text "a lambda expression" pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") @@ -1195,7 +1292,7 @@ data FixedRuntimeRepContext -- -- See 'ExpectedFunTyOrigin' for more details. | FRRExpectedFunTy - !ExpectedFunTyOrigin + !CtOrigin -- !ExpectedFunTyOrigin !Int -- ^ argument position (1-indexed) @@ -1228,11 +1325,10 @@ mkFRRUnboxedSum = FRRUnboxedSum -- and is reported separately. pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) - = sep [ text "The field", quotes (ppr lbl) + = sep [ text "The field", quotes (ppr lbl) -- TODO ANI: Where does this get used? Add missing test? , text "of the record constructor" ] -pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) - = sep [ text "The record update at field" - , quotes (ppr lbl) ] +pprFixedRuntimeRepContext (FRRRecordUpdate lbl _) + = sep [ text "The field", quotes (ppr lbl) ] pprFixedRuntimeRepContext (FRRBinder binder) = sep [ text "The binder" , quotes (ppr binder) ] @@ -1277,8 +1373,8 @@ pprFixedRuntimeRepContext FRRBindStmtGuard = sep [ text "The body of the bind statement" ] pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext -pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos) - = pprExpectedFunTyOrigin funTyOrig arg_pos +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) + = pprCtOrigin funTyOrig instance Outputable FixedRuntimeRepContext where ppr = pprFixedRuntimeRepContext @@ -1431,102 +1527,56 @@ instance Outputable FRRArrowContext where -- Uses 'pprExpectedFunTyOrigin'. -- See 'FixedRuntimeRepContext' for the situations in which -- representation-polymorphism checks are performed. -data ExpectedFunTyOrigin - - -- | A rebindable syntax operator is expected to have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - = forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) - -- ^ rebindable syntax operator - - -- | A view pattern must have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder - | ExpectedFunTyViewPat - !(HsExpr GhcRn) - -- ^ function used in the view pattern - - -- | Need to be able to extract an argument type from a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyApp - | forall (p :: Pass) - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg - !TypedThing - -- ^ function - !(HsExpr (GhcPass p)) - -- ^ argument - - -- | Ensure that a function defined by equations indeed has a function type - -- with the appropriate number of arguments. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern - | ExpectedFunTyMatches - !TypedThing - -- ^ name of the function - !(MatchGroup GhcRn (LHsExpr GhcRn)) - -- ^ equations - - -- | Ensure that a lambda abstraction has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyLambda, RepPolyMatch - | ExpectedFunTyLam HsLamVariant - !(HsExpr GhcRn) - -- ^ the entire lambda-case expression - -pprExpectedFunTyOrigin :: ExpectedFunTyOrigin - -> Int -- ^ argument position (starting at 1) - -> SDoc -pprExpectedFunTyOrigin funTy_origin i = - case funTy_origin of - ExpectedFunTySyntaxOp orig op -> - vcat [ sep [ the_arg_of - , text "the rebindable syntax operator" - , quotes (ppr op) ] - , nest 2 (ppr orig) ] - ExpectedFunTyViewPat expr -> - vcat [ the_arg_of <+> text "the view pattern" - , nest 2 (ppr expr) ] - ExpectedFunTyArg fun arg -> - sep [ text "The argument" - , quotes (ppr arg) - , text "of" - , quotes (ppr fun) ] - ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) - | null alts - -> the_arg_of <+> quotes (ppr fun) - | otherwise - -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts - <+> text "for" <+> quotes (ppr fun) - ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant - where - the_arg_of :: SDoc - the_arg_of = text "The" <+> speakNth i <+> text "argument of" - binder_of :: SDoc -> SDoc - binder_of what = text "The binder of the" <+> what <+> text "expression" -pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc +-- pprExpectedFunTyOrigin :: -- ExpectedFunTyOrigin +-- -- -> Int -- ^ argument position (starting at 1) +-- -> SDoc +-- pprExpectedFunTyOrigin funTy_origin = +-- case funTy_origin of +-- ExpectedFunTySyntaxOp i orig op -> +-- vcat [ sep [ the_arg_of +-- , text "the rebindable syntax operator" +-- , quotes (ppr op) ] +-- , nest 2 (ppr orig) ] +-- ExpectedFunTyViewPat i expr -> +-- vcat [ the_arg_of <+> text "the view pattern" +-- , nest 2 (ppr expr) ] +-- ExpectedFunTyArg fun arg -> +-- sep [ text "The argument" +-- , quotes (ppr arg) +-- , text "of" +-- , quotes (ppr fun) ] +-- ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts }) +-- | null alts +-- -> the_arg_of <+> quotes (ppr fun) +-- | otherwise +-- -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts +-- <+> text "for" <+> quotes (ppr fun) +-- ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant +-- where +-- the_arg_of :: Int -> SDoc +-- the_arg_of i = text "The" <+> speakNth i <+> text "argument of" + +-- binder_of :: SDoc -> SDoc +-- binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: CtOrigin -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" -pprExpectedFunTyHerald (ExpectedFunTyArg fun _) +pprExpectedFunTyHerald (ExpectedFunTyArg _ fun _) = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to" ] -pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) +pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" <+> quotes (pprSetDepth (PartWay 1) (ppr expr)) -- The pprSetDepth makes the lambda abstraction print briefly , text "has" ] +pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcCodeCtxt, + getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -400,8 +400,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! - tcl_in_gen_code = UserCode, - tcl_ctxt = [], + tcl_ctxt = UserCodeCtxt [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, @@ -978,21 +977,21 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = UserCode }) + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)}) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -getSrcCodeCtxt :: TcRn SrcCodeCtxt -getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv +getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) +getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a -setInGeneratedCode scOrig thing_inside = - updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside +setInGeneratedCode sco thing_inside = + updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -135,7 +135,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: ExpectedFunTyOrigin + :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -241,7 +241,7 @@ Ugh! -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -776,7 +776,7 @@ Example: -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + CtOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -905,19 +905,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) +new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType) new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: ExpectedFunTyOrigin +mkFunTysMsg :: CtOrigin -> (VisArity, TcType) -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -- See Note [Reporting application arity errors] ===================================== testsuite/tests/deSugar/should_compile/T10662.stderr ===================================== @@ -1,6 +1,6 @@ -T10662.hs:2:8: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + +T10662.hs:3:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘String’ Suggested fix: Suppress this warning by saying ‘_ <- return $ let a = "hello" in a’ - ===================================== testsuite/tests/deSugar/should_compile/T3263-1.stderr ===================================== @@ -1,8 +1,8 @@ -T3263-1.hs:24:6: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + +T3263-1.hs:25:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ Suggested fix: Suppress this warning by saying ‘_ <- nonNullM’ -T3263-1.hs:34:6: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] +T3263-1.hs:35:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ Suggested fix: Suppress this warning by saying ‘_ <- nonNullM’ - ===================================== testsuite/tests/deSugar/should_compile/T3263-2.stderr ===================================== @@ -1,10 +1,10 @@ -T3263-2.hs:24:6: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] + +T3263-2.hs:25:3: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ Suggested fix: Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ -T3263-2.hs:36:6: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] +T3263-2.hs:37:3: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ Suggested fix: Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ - ===================================== testsuite/tests/ghci.debugger/scripts/break029.script ===================================== @@ -1,4 +1,5 @@ :load break029.hs :step f 3 :step +:step y ===================================== testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr ===================================== @@ -13,8 +13,7 @@ RepPolyRecordUpdate.hs:7:35: error: [GHC-55287] X a :: TYPE rep RepPolyRecordUpdate.hs:13:9: error: [GHC-55287] - • The argument ‘fld’ of ‘MkX’ - does not have a fixed runtime representation. + • The field ‘fld’ does not have a fixed runtime representation. Its type is: a0 :: TYPE rep0 When unifying: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8b26e98f2b3699aba58e9c3928e71… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8b26e98f2b3699aba58e9c3928e71… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T20264] Proper occurrence analysis for TyCoVars
by Simon Peyton Jones (＠simonpj) 13 Jul '25

13 Jul '25

Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: e69b3f51 by Simon Peyton Jones at 2025-07-13T23:52:25+01:00 Proper occurrence analysis for TyCoVars - - - - - 11 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -42,7 +42,8 @@ module GHC.Core ( foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, + flattenBinds, glomValBinds, mapBindBndrs, collectFunSimple, exprToType, @@ -2174,7 +2175,6 @@ foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds where fold_bind = (foldBindersOfBindStrict f) - rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] @@ -2189,6 +2189,21 @@ flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds flattenBinds [] = [] +glomValBinds :: [Bind b] -> [Bind b] +-- Glom all the value bindings into a single Rec; +-- Leave any type bindings as NonRecs, bringing them to the front +glomValBinds bs = go [] bs + where + go prs (b@(NonRec _ (Type {})) : bs) = b : go prs bs + go prs (NonRec b r : bs) = go ((b,r) : prs) bs + go prs (Rec rprs : bs) = go (rprs ++ prs) bs + go [] [] = [] + go prs [] = [Rec prs] + +mapBindBndrs :: (b -> b) -> Bind b -> Bind b +mapBindBndrs f (NonRec b r) = NonRec (f b) r +mapBindBndrs f (Rec prs) = Rec (mapFst f prs) + -- | We often want to strip off leading lambdas before getting down to -- business. Variants are 'collectTyBinders', 'collectValBinders', -- and 'collectTyAndValBinders' ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -39,7 +39,6 @@ import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Predicate ( isDictId ) import GHC.Core.Type -import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) import GHC.Data.Maybe( orElse ) @@ -50,6 +49,7 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Types.Id +import GHC.Types.Name( isExternalName ) import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Tickish @@ -65,6 +65,8 @@ import GHC.Utils.Misc import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) +import qualified Data.Semigroup as S( Semigroup(..) ) +import qualified Data.Monoid as S( Monoid(..) ) import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty (..)) @@ -100,18 +102,15 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds init_env = initOccEnv { occ_rule_act = active_rule , occ_unf_act = active_unf } - WUD final_usage occ_anald_binds = go binds init_env - WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds binds) - initial_uds + WUD final_usage occ_anald_binds = go binds init_env + WUD _ occ_anald_glommed_binds = go (glomValBinds binds) init_env -- It's crucial to re-analyse the glommed-together bindings -- so that we establish the right loop breakers. Otherwise -- we can easily create an infinite loop (#9583 is an example) -- - -- Also crucial to re-analyse the /original/ bindings - -- in case the first pass accidentally discarded as dead code - -- a binding that was actually needed (albeit before its + -- Also crucial to re-analyse the /original/ bindings, not the + -- occ_anald_binds, in case the first pass accidentally discarded as + -- dead code a binding that was actually needed (albeit before its -- definition site). #17724 threw this up. initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) @@ -971,16 +970,32 @@ occAnalBind -> WithUsageDetails r -- Of the whole let(rec) occAnalBind env lvl ire (Rec pairs) thing_inside combine - = addInScopeList env (map fst pairs) $ \env -> + = addInScope env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds in WUD bind_uds (combine binds' body') -occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine - | isTyVar bndr -- A type let; we don't gather usage info - = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside - in WUD body_uds (combine [NonRec bndr rhs] res) +occAnalBind !env _lvl _ire (NonRec bndr rhs) thing_inside combine + | isTyCoVar bndr -- A type/coercion let + = let !(WUD body_uds (occ,res)) + = addInScopeOne env bndr $ \env_body -> + let !(WUD inner_uds inner_res) = thing_inside env_body + !tyco_occ = lookupTyCoOcc inner_uds bndr + in (WUD inner_uds (tyco_occ, inner_res)) + + rhs_tyco_occs = case rhs of + Type ty -> occAnalTy ty + Coercion co -> occAnalCo co + _ -> pprPanic "occAnalBind" (ppr (NonRec bndr rhs)) + in + case occ of + TyCoDead -> WUD body_uds res + _ -> WUD (body_uds `addTyCoOccs` rhs_tyco_occs) + (combine [NonRec bndr' rhs] res) + where + bndr' = tagTyCoBinder occ bndr +occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine -- /Existing/ non-recursive join points -- See Note [Occurrence analysis for join points] | mb_join@(JoinPoint {}) <- idJoinPointHood bndr @@ -1134,19 +1149,13 @@ occAnalRec :: OccEnv -> TopLevelFlag -> WithUsageDetails [CoreBind] -- The NonRec case is just like a Let (NonRec ...) above +-- except that type variables can't occur occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) (WUD body_uds binds) - -- Currently we don't gather occ-info for tyvars, - -- so we never discard dead bindings -- Need to fix this - | isTyVar bndr - = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds - !bndr' = tagged_bndr - in WUD (body_uds `andUDs` rhs_uds') - (NonRec bndr' rhs' : binds) - - | isDeadOcc occ -- Check for dead code: see Note [Dead code] + | assertPpr (not (isTyVar bndr)) (ppr bndr) $ + -- Rec blocks have no TyVar bindings in them + isDeadOcc occ -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise @@ -1705,7 +1714,7 @@ rank (r, _, _) = r makeNode :: OccEnv -> ImpRuleEdges -> VarSet -> (Var, CoreExpr) -> LetrecNode -- See Note [Recursive bindings: the grand plan] -makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) +makeNode !_env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) = -- This is a type binding, e.g. let @x = Maybe Int in ... assert (isTyVar bndr) $ DigraphNode { node_payload = details @@ -1719,8 +1728,7 @@ makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty)) , nd_weak_fvs = emptyVarSet , nd_active_rule_fvs = emptyVarSet } - rhs_env = setNonTailCtxt OccRhs env - rhs_uds = occAnalTy rhs_env rhs_ty + rhs_uds = mkTyCoUDs (occAnalTy rhs_ty) rhs_fvs = udFreeVars bndr_set rhs_uds makeNode !env imp_rule_edges bndr_set (bndr, rhs) @@ -2229,9 +2237,9 @@ occ_anal_lam_tail env (Cast expr co) = let WUD expr_uds expr' = occ_anal_lam_tail env expr -- co_uds: see Note [Gather occurrences of coercion variables] - co_uds = occAnalCo env co + co_uds = occAnalCo co - usage1 = expr_uds `andUDs` co_uds + usage1 = expr_uds `addTyCoOccs` co_uds -- usage2: see Note [Occ-anal and cast worker/wrapper] usage2 = case expr of @@ -2436,14 +2444,54 @@ float ==> This is worse than the slow cascade, so we only want to say "certainly_inline" if it really is certain. Look at the note with preInlineUnconditionally for the various clauses. See #24582 for an example of the two getting out of sync. +-} + +{- ********************************************************************* +* * + Types +* * +********************************************************************* -} +newtype TyCoOccs = TyCoOccs { get_tyco_occs :: TyCoOccEnv } -************************************************************************ +instance S.Semigroup TyCoOccs where + (TyCoOccs o1) <> (TyCoOccs o2) = TyCoOccs (plusTyCoOccEnv o1 o2) + +instance S.Monoid TyCoOccs where + mempty = TyCoOccs emptyVarEnv + +occTyCoFolder :: TyCoFolder TyCoVarSet TyCoOccs +occTyCoFolder + = TyCoFolder { tcf_view = \_ -> Nothing -- No need to expand synonyms + , tcf_tyvar = do_var + , tcf_covar = do_var + , tcf_hole = \_ h -> pprPanic "occTyCoFolder:hole" (ppr h) + , tcf_tycobinder = do_binder } + where + do_var :: TyCoVarSet -> TyCoVar -> TyCoOccs + do_var locals tcv + | tcv `elemVarSet` locals = mempty + | isExternalName (varName tcv) = mempty -- TyVars from other modules + | otherwise = TyCoOccs (unitVarEnv tcv TyCoOne) + + do_binder :: TyCoVarSet -> TyCoVar -> ForAllTyFlag -> TyCoVarSet + do_binder locals tcv _ = extendVarSet locals tcv + +occAnalTy :: Type -> TyCoOccEnv +occAnalCo :: Coercion -> TyCoOccEnv +occAnalTy ty = get_tyco_occs (occ_anal_ty ty) +occAnalCo co = get_tyco_occs (occ_anal_co co) + +occ_anal_ty :: Type -> TyCoOccs +occ_anal_co :: Coercion -> TyCoOccs +(occ_anal_ty, _, occ_anal_co, _) = foldTyCo occTyCoFolder emptyVarSet +-- No need to return a modified type, unlike expressions + +{- ********************************************************************* * * Expressions * * -************************************************************************ --} +********************************************************************* -} occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr] occAnalList !_ [] = WUD emptyDetails [] @@ -2452,50 +2500,6 @@ occAnalList env (e:es) = let (WUD uds2 es') = occAnalList env es in WUD (uds1 `andUDs` uds2) (e' : es') -occAnalTys :: OccEnv -> [Type] -> UsageDetails -occAnalTys env tys = foldr (andUDs . occAnalTy env) emptyDetails tys - -occAnalTy :: OccEnv -> Type -> UsageDetails --- No need to return a modified type, unlike expressions -occAnalTy env (TyVarTy tv) = mkOneTyVarOcc env tv -occAnalTy _ (LitTy {}) = emptyDetails -occAnalTy env (AppTy t1 t2) = occAnalTy env t1 `andUDs` occAnalTy env t2 -occAnalTy env (CastTy ty co) = occAnalTy env ty `andUDs` occAnalCo env co -occAnalTy env (CoercionTy co) = occAnalCo env co -occAnalTy env (TyConApp _ tys) = occAnalTys env tys -occAnalTy env (ForAllTy (Bndr tv _) ty) = delBndrsFromUDs [tv] (occAnalTy env ty) -occAnalTy env (FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) - = occAnalTy env w `andUDs` occAnalTy env arg `andUDs` occAnalTy env res - -occAnalCos :: OccEnv -> [Coercion] -> UsageDetails -occAnalCos env cos = foldr (andUDs . occAnalCo env) emptyDetails cos - -occAnalMCo :: OccEnv -> MCoercion -> UsageDetails -occAnalMCo _ MRefl = emptyDetails -occAnalMCo env (MCo co) = occAnalCo env co - -occAnalCo :: OccEnv -> Coercion -> UsageDetails -occAnalCo !env (Refl ty) = occAnalTy env ty -occAnalCo !env (GRefl _ ty mco) = occAnalTy env ty `andUDs` occAnalMCo env mco -occAnalCo !env (AppCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2 -occAnalCo env (CoVarCo cv) = mkOneIdOcc env cv NotInteresting 0 -occAnalCo _ (HoleCo hole) = pprPanic "occAnalCo:HoleCo" (ppr hole) -occAnalCo env (SymCo co) = occAnalCo env co -occAnalCo env (TransCo co1 co2) = occAnalCo env co1 `andUDs` occAnalCo env co2 -occAnalCo env (AxiomCo _ cos) = occAnalCos env cos -occAnalCo env (SelCo _ co) = occAnalCo env co -occAnalCo env (LRCo _ co) = occAnalCo env co -occAnalCo env (InstCo co arg) = occAnalCo env co `andUDs` occAnalCo env arg -occAnalCo env (KindCo co) = occAnalCo env co -occAnalCo env (SubCo co) = occAnalCo env co -occAnalCo env (TyConAppCo _ _ cos) = occAnalCos env cos -occAnalCo !env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) - = occAnalCo env cw `andUDs` occAnalCo env c1 `andUDs` occAnalCo env c2 -occAnalCo env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos }) - = occAnalTy env t1 `andUDs` occAnalTy env t2 `andUDs` occAnalCos env cos -occAnalCo env (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) - = occAnalCo env kind_co `andUDs` delBndrsFromUDs [tv] (occAnalCo env co) - occAnal :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids @@ -2510,8 +2514,8 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], []) -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. -occAnal env (Type ty) = WUD (occAnalTy env ty) (Type ty) -occAnal env (Coercion co) = WUD (occAnalCo env co) (Coercion co) +occAnal _env (Type ty) = WUD (mkTyCoUDs (occAnalTy ty)) (Type ty) +occAnal _env (Coercion co) = WUD (mkTyCoUDs (occAnalCo co)) (Coercion co) {- Note [Gather occurrences of coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2589,10 +2593,10 @@ occAnal env (Tick tickish body) occAnal env (Cast expr co) = let (WUD expr_uds expr') = occAnal env expr - co_uds = occAnalCo env co + co_uds = occAnalCo co -- co_uds: see Note [Gather occurrences of coercion variables] - uds = markAllNonTail (expr_uds `andUDs` co_uds) - -- co_uds': calls inside expr aren't tail calls any more + uds = markAllNonTail (expr_uds `addTyCoOccs` co_uds) + -- markAllNonTail: calls inside expr aren't tail calls any more in WUD uds (Cast expr' co) occAnal env app@(App _ _) @@ -2614,7 +2618,9 @@ occAnal env (Case scrut bndr ty alts) tagged_bndr = tagLamBinder alts_usage bndr in WUD alts_usage (tagged_bndr, alts') - total_usage = markAllNonTail scrut_usage `andUDs` alts_usage + total_usage = markAllNonTail scrut_usage + `andUDs` alts_usage + `addTyCoOccs` occAnalTy ty -- Alts can have tail calls, but the scrutinee can't in WUD total_usage (Case scrut' tagged_bndr ty alts') @@ -2719,7 +2725,7 @@ occAnalApp !env (Var fun, args, ticks) occAnalApp env (Var fun_id, args, ticks) = WUD all_uds (mkTicks ticks app') where - -- Lots of banged bindings: this is a very heavily bit of code, + -- Lots of banged bindings: this is a very heavily used bit of code, -- so it pays not to make lots of thunks here, all of which -- will ultimately be forced. !(fun', fun_id') = lookupBndrSwap env fun_id @@ -3136,24 +3142,23 @@ addInScope :: OccEnv -> [Var] -- We do not assume that the bndrs are in scope order; in fact the -- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order --- Fast path when the is no environment-munging to do --- This is rather common: notably at top level, but nested too addInScope env bndrs thing_inside | null bndrs -- E.g. nullary constructors in a `case` = thing_inside env + -- Fast path when the is no environment-munging to do + -- This is rather common: notably at top level, but nested too | isEmptyVarEnv (occ_bs_env env) , isEmptyVarEnv (occ_join_points env) , WUD uds res <- thing_inside env = WUD (delBndrsFromUDs bndrs uds) res -addInScope env bndrs thing_inside + -- Normal path + | let !(env', bad_joins) = preprocess_env env bndr_set + !(WUD uds res) = thing_inside env' + uds' = postprocess_uds bndrs bad_joins uds + bndr_set = mkVarSet bndrs = WUD uds' res - where - bndr_set = mkVarSet bndrs - !(env', bad_joins) = preprocess_env env bndr_set - !(WUD uds res) = thing_inside env' - uds' = postprocess_uds bndrs bad_joins uds preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo) preprocess_env env@(OccEnv { occ_join_points = join_points @@ -3668,8 +3673,8 @@ For example, in (case x of A -> y; B -> y; C -> True), -} -type IdOccEnv = VarEnv LocalOcc -- A finite map from an expression's - -- free variables to their usage +type IdOccEnv = IdEnv LocalOcc -- A finite map from an expression's + -- free variables to their usage data LocalOcc -- See Note [LocalOcc] = OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences @@ -3690,9 +3695,7 @@ localTailCallInfo (ManyOccL tci) = tci -- For TyVars and CoVars we gather only whether it occurs once or -- many times; we aren't interested in case-branches or tail-calls -data TyCoOccEnv = VarEnv TyCoOcc - -data TyCoOcc = OneOccTyCo | ManyOccTyCo +type TyCoOccEnv = TyCoVarEnv TyCoOccInfo type ZappedSet = IdOccEnv type ZappedTyCoSet = TyCoOccEnv @@ -3704,24 +3707,19 @@ data UsageDetails , ud_z_many :: !ZappedSet -- apply 'markMany' to these , ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these , ud_z_tail :: !ZappedSet -- zap tail-call info for these + , ud_tyco_env :: !TyCoOccEnv - , ud_z_tyzo :: !ZappedTyCoSet + , ud_z_tyco :: !ZappedTyCoSet -- These ones occur many times } -- INVARIANT: `ud_z_many`, `ud_z_in_lam` and `ud_z_tail` -o -- are all subsets of ud_id_env - -- `ud_z_tyco` is a subset of ud_tycon_env + -- are all subsets of ud_id_env + -- `ud_z_tyco` is a subset of ud_tyco_env instance Outputable UsageDetails where - ppr ud@(UD { ud_id_env = env, ud_tyco_env = tyco_env }) - = text "UD" <+> (braces $ fsep $ punctuate comma $ - [ ppr uq <+> text ":->" <+> ppr (lookupOccByUnique ud uq) - | uq <- nonDetStrictFoldVarEnv_Directly do_one [] id_env ] - ++ - [ ppr uq <+> text ":->" <+> ppr (lookupTyCoOccByUnique ud uq) - | uq <- nonDetStrictFoldVarEnv_Directly do_one [] tyco_env ]) - where - do_one :: Unique -> a -> [Unique] -> [Unique] - do_one uniq _ uniqs = uniq : uniqs + ppr (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = text "UD" <+> (braces $ vcat + [ text "ud_id_env =" <+> ppr id_env + , text "ud_tyco_env =" <+> ppr tyco_env ]) --------------------- -- | TailUsageDetails captures the result of applying 'occAnalLamTail' @@ -3743,18 +3741,13 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +plusTyCoOccEnv :: TyCoOccEnv -> TyCoOccEnv -> TyCoOccEnv +plusTyCoOccEnv env1 env2 = plusVarEnv_C plusTyCoOccInfo env1 env2 + +andUDs, orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc -mkOneTyVarOcc :: OccEnv -> TyVar -> UsageDetails -mkOneTyVarOcc !_env tv - = mkSimpleDetails (unitVarEnv tv occ) - where - occ = OneOccL { lo_n_br = 1, lo_int_cxt = NotInteresting - , lo_tail = NoTailCallInfo } - mkOneIdOcc :: OccEnv -> Var -> InterestingCxt -> JoinArity -> UsageDetails mkOneIdOcc !env id int_cxt arity | assert (not (isTyVar id)) $ @@ -3765,10 +3758,10 @@ mkOneIdOcc !env id int_cxt arity = -- See Note [Occurrence analysis for join points] assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $ -- We only put non-empty join-points into occ_join_points - mkSimpleDetails (extendVarEnv join_uds id occ) + mkIdUDs (extendVarEnv join_uds id occ) | otherwise - = mkSimpleDetails (unitVarEnv id occ) + = mkIdUDs (unitVarEnv id occ) where occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt @@ -3786,11 +3779,15 @@ add_many_occ v env = extendVarEnv env v (ManyOccL NoTailCallInfo) addManyOccs :: UsageDetails -> VarSet -> UsageDetails addManyOccs uds var_set | isEmptyVarSet var_set = uds - | otherwise = uds { ud_env = add_to (ud_env uds) } + | otherwise = uds { ud_id_env = add_to (ud_id_env uds) } where add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes +addTyCoOccs :: UsageDetails -> TyCoOccEnv -> UsageDetails +addTyCoOccs uds@(UD { ud_tyco_env = env}) extras + = uds { ud_tyco_env = env `plusTyCoOccEnv` extras } + addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails -- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var] -- Add any TyCoVars free in the type of a lambda-binder @@ -3801,39 +3798,52 @@ addLamTyCoVarOccs uds bndrs add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr) emptyDetails :: UsageDetails -emptyDetails = mkSimpleDetails emptyVarEnv +emptyDetails = UD { ud_id_env = emptyVarEnv + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_tail = emptyVarEnv + , ud_tyco_env = emptyVarEnv + , ud_z_tyco = emptyVarEnv } isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env +isEmptyDetails (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = isEmptyVarEnv id_env && isEmptyVarEnv tyco_env + +mkIdUDs :: IdOccEnv -> UsageDetails +mkIdUDs env = emptyDetails { ud_id_env = env } -mkSimpleDetails :: IdOccEnv -> UsageDetails -mkSimpleDetails env = UD { ud_env = env - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_tail = emptyVarEnv } +mkTyCoUDs :: TyCoOccEnv -> UsageDetails +mkTyCoUDs env = emptyDetails { ud_tyco_env = env } modifyUDEnv :: (IdOccEnv -> IdOccEnv) -> UsageDetails -> UsageDetails -modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env } +modifyUDEnv f uds@(UD { ud_id_env = env }) = uds { ud_id_env = f env } delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails -- Delete these binders from the UsageDetails --- But /add/ the free vars of the types -delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many - , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail }) - = UD { ud_env = env `delVarEnvList` bndrs +-- But /add/ the free vars of the types. That may seem odd, but this is +-- a very convenient place to do it! +delBndrsFromUDs bndrs (UD { ud_id_env = env, ud_z_many = z_many + , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail + , ud_tyco_env = tyco_env, ud_z_tyco = z_tyco }) + = UD { ud_id_env = env `delVarEnvList` bndrs , ud_z_many = z_many `delVarEnvList` bndrs , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs - , ud_z_tail = z_tail `delVarEnvList` bndrs } + , ud_z_tail = z_tail `delVarEnvList` bndrs + , ud_tyco_env = adjust bndrs tyco_env + , ud_z_tyco = z_tyco `delVarEnvList` bndrs + } where - ty_fvs [] = emptyVarSet - ty_fvs (b:bs) = tyCoVarsOfType b `unionVarSet` - (ty_fvs bs `delVarSet` b) + adjust :: [Var] -> TyCoOccEnv -> TyCoOccEnv + -- Delete binders, but add the free vars of their types + adjust [] env = env + adjust (b:bs) env = occAnalTy (varType b) `plusTyCoOccEnv` + (adjust bs env `delVarEnv` b) markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail :: UsageDetails -> UsageDetails -markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env } -markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env } -markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env } +markAllMany ud@(UD { ud_id_env = env }) = ud { ud_z_many = env } +markAllInsideLam ud@(UD { ud_id_env = env }) = ud { ud_z_in_lam = env } +markAllNonTail ud@(UD { ud_id_env = env }) = ud { ud_z_tail = env } markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails @@ -3846,7 +3856,7 @@ markAllNonTailIf False ud = ud lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo lookupTailCallInfo uds id - | UD { ud_z_tail = z_tail, ud_env = env } <- uds + | UD { ud_z_tail = z_tail, ud_id_env = env } <- uds , not (id `elemVarEnv` z_tail) , Just occ <- lookupVarEnv env id = localTailCallInfo occ @@ -3855,9 +3865,10 @@ lookupTailCallInfo uds id udFreeVars :: VarSet -> UsageDetails -> VarSet -- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env +udFreeVars bndrs (UD { ud_id_env = id_env, ud_tyco_env = tyco_env }) + = restrictFreeVars bndrs id_env `unionVarSet` restrictFreeVars bndrs tyco_env -restrictFreeVars :: VarSet -> IdOccEnv -> VarSet +restrictFreeVars :: VarSet -> VarEnv a -> VarSet restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs ------------------- @@ -3867,15 +3878,19 @@ combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) -> UsageDetails -> UsageDetails -> UsageDetails {-# INLINE combineUsageDetailsWith #-} combineUsageDetailsWith plus_occ_info - uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) - uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) - | isEmptyVarEnv env1 = uds2 - | isEmptyVarEnv env2 = uds1 + uds1@(UD { ud_id_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 + , ud_tyco_env = tyco_env1, ud_z_tyco = z_tyco1 }) + uds2@(UD { ud_id_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 + , ud_tyco_env = tyco_env2, ud_z_tyco = z_tyco2 }) + | isEmptyDetails uds1 = uds2 + | isEmptyDetails uds2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 - , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + = UD { ud_id_env = plusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = plusVarEnv z_many1 z_many2 + , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = plusVarEnv z_tail1 z_tail2 + , ud_tyco_env = plusTyCoOccEnv tyco_env1 tyco_env2 + , ud_z_tyco = plusVarEnv z_tyco1 z_tyco2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3884,21 +3899,24 @@ lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- we are about to re-generate it and it shouldn't be "sticky" lookupLetOccInfo ud id | isExportedId id = noOccInfo - | otherwise = lookupOccByUnique ud (idUnique id) + | otherwise = lookupIdOccByUnique ud (idUnique id) + +lookupIdOccInfo :: UsageDetails -> Id -> OccInfo +lookupIdOccInfo ud id = lookupIdOccByUnique ud (idUnique id) -lookupOccInfo :: UsageDetails -> Id -> OccInfo -lookupOccInfo ud id = lookupOccByUnique ud (idUnique id) +lookupTyCoOcc :: UsageDetails -> TyCoVar -> TyCoOccInfo +lookupTyCoOcc uds tcv = lookupTyCoOccByUnique uds (varUnique tcv) -lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOcc -lookupTyCoByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq +lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOccInfo +lookupTyCoOccByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq = case lookupVarEnv_Directly env uniq of - Nothing -> Nothing - Just ManyOccTyCo -> Just ManyOccTyCo - Just OneOccTyCo | uniq `elemVarEnvByKey` z_tyco = Just ManyOccTyCo - | otherwise = Just OneOccTyCo + Nothing -> TyCoDead + Just TyCoOne | uniq `elemVarEnvByKey` z_tyco -> TyCoMany + | otherwise -> TyCoOne + Just occ -> occ -lookupOccByUnique :: UsageDetails -> Unique -> OccInfo -lookupOccByUnique (UD { ud_env = env +lookupIdOccByUnique :: UsageDetails -> Unique -> OccInfo +lookupIdOccByUnique (UD { ud_id_env = env , ud_z_many = z_many , ud_z_in_lam = z_in_lam , ud_z_tail = z_tail }) @@ -3925,6 +3943,12 @@ lookupOccByUnique (UD { ud_env = env | otherwise = ti +tyCoOccToIdOcc :: TyCoOccInfo -> OccInfo +-- Used for CoVars +tyCoOccToIdOcc TyCoDead = IAmDead +tyCoOccToIdOcc TyCoOne = OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 + , occ_int_cxt = NotInteresting, occ_tail = NoTailCallInfo } +tyCoOccToIdOcc TyCoMany = noOccInfo ------------------- -- See Note [Adjusting right-hand sides] @@ -3958,34 +3982,42 @@ adjustTailArity mb_rhs_ja (TUD ja usage) type IdWithOccInfo = Id tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders + -> [CoreBndr] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders = map (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope - -> Id -- Binder + -> CoreBndr -- Binder -> IdWithOccInfo -- Tagged binders -- Used for lambda and case binders --- No-op on TyVars +-- No-op on TyVars; we could tag them but not much point -- A lambda binder never has an unfolding, so no need to look for that tagLamBinder usage bndr - = setBinderOcc (markNonTail occ) bndr + | isTyCoVar bndr + = bndr + | otherwise + = setIdBinderOcc (markNonTail occ) bndr -- markNonTail: don't try to make an argument into a join point where - occ = lookupOccInfo usage bndr + occ = lookupIdOccInfo usage bndr + +tagTyCoBinder :: TyCoOccInfo -> TyCoVar -> TyCoVar +tagTyCoBinder occ bndr + | isId bndr = setIdOccInfo bndr (tyCoOccToIdOcc occ) + | otherwise = setTyVarOccInfo bndr occ tagNonRecBinder :: TopLevelFlag -- At top level? -> OccInfo -- Of scope - -> CoreBndr -- Binder + -> Id -- Binder -> (IdWithOccInfo, JoinPointHood) -- Tagged binder -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr | okForJoinPoint lvl bndr tail_call_info , AlwaysTailCalled ar <- tail_call_info - = (setBinderOcc occ bndr, JoinPoint ar) + = (setIdBinderOcc occ bndr, JoinPoint ar) | otherwise - = (setBinderOcc zapped_occ bndr, NotJoinPoint) + = (setIdBinderOcc zapped_occ bndr, NotJoinPoint) where tail_call_info = tailCallInfo occ zapped_occ = markNonTail occ @@ -4035,18 +4067,17 @@ tagRecBinders lvl body_uds details_s adj_uds = foldr andUDs body_uds rhs_udss' -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr + bndrs' = [ setIdBinderOcc (lookupLetOccInfo adj_uds bndr) bndr | bndr <- bndrs ] in WUD adj_uds bndrs' -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = if (occ_info == tyVarOccInfo bndr) then bndr - else setTyVarOccInfo bndr occ_info - | otherwise = if (occ_info == idOccInfo bndr) then bndr - else setIdOccInfo bndr occ_info +setIdBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setIdBinderOcc occ_info bndr + = assertPpr (isNonCoVarId bndr) (ppr bndr) $ + if (occ_info == idOccInfo bndr) then bndr + else setIdOccInfo bndr occ_info -- | Decide whether some bindings should be made into join points or not, based -- on its occurrences. This is ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -441,8 +441,8 @@ type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = glomValBinds binds' -- for this no_need_to_flatten stuff where ind_env = makeIndEnv binds -- These exported Ids are the subjects of the indirection-elimination ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -930,22 +930,19 @@ mkRecFloats :: SimplFloats -> SimplFloats -- If any are type bindings they must be non-recursive, so -- do not need to be joined into a letrec; indeed they must not -- since Rec{} is not allowed to have type binders -mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff +mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats val_bs ff , sfJoinFloats = join_bs , sfInScope = in_scope }) - = assertPpr (isNilOL bs || isNilOL join_bs) (ppr floats) $ - SimplFloats { sfLetFloats = LetFloats (type_bs `appOL` val_b) ff + = assertPpr (isNilOL val_bs || isNilOL join_bs) (ppr floats) $ + SimplFloats { sfLetFloats = LetFloats val_b ff , sfJoinFloats = join_b , sfInScope = in_scope } where - type_bs, val_bs :: OrdList OutBind - (type_bs, val_bs) = partitionOL isTypeBind bs - -- See Note [Bangs in the Simplifier] !val_b | isNilOL val_bs = nilOL - | otherwise = unitOL (Rec (flattenBinds (fromOL val_bs))) + | otherwise = toOL (glomValBinds (fromOL val_bs)) !join_b | isNilOL join_bs = nilOL - | otherwise = unitOL (Rec (flattenBinds (fromOL join_bs))) + | otherwise = toOL (glomValBinds (fromOL join_bs)) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -204,6 +204,9 @@ simplTopBinds env0 binds0 -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- + -- But the type of that top-level binder might mention a let-bound + -- type variable, so we put all those let-bindings at the front -- See Note [Bangs in the Simplifier] ; (ty_floats, env1) <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplTopTyVarBinds env0 binds0 @@ -291,10 +294,12 @@ simplTyVarBind :: SimplEnv -> InTyVar -> InType -- Returned SimplFloats is empty, or singleton type binding simplTyVarBind env tv ty | Just env' <- preInlineTypeUnconditionally env tv ty - = return (emptyFloats env', env') + = -- pprTrace "Pre-inline-tv" (ppr tv <+> equals <+> ppr ty) $ + return (emptyFloats env', env') | otherwise = do { ty' <- simplType env ty - ; completeTyVarBindX env (zapTyVarUnfolding tv) ty' } + ; -- pprTrace "Don't pre-inline-tv" (ppr tv <+> equals <+> ppr ty') $ + completeTyVarBindX env (zapTyVarUnfolding tv) ty' } -- Zap any unfolding because competeTyVarBindX will add -- the new unfolding and we don't wnat to waste work -- substituting the old one @@ -303,7 +308,8 @@ completeTyVarBindX :: SimplEnv -> InTyVar -> OutType -> SimplM (SimplFloats, SimplEnv) completeTyVarBindX env in_tv out_ty | postInlineTypeUnconditionally out_ty - = return (emptyFloats env, extendTvSubst env in_tv out_ty) + = -- pprTrace "Post-inline-tv" (ppr in_tv <+> equals <+> ppr out_ty) $ + return (emptyFloats env, extendTvSubst env in_tv out_ty) | otherwise = do { (env1, out_tv) <- simplTyVarBndr env in_tv @@ -314,7 +320,9 @@ completeTyVarBindX env in_tv out_ty -- occurrence of in_tv. After all, in a beta-redex, in_tv -- had no unfolding. See (TCL2) in -- Note [Type and coercion lets] in GHC.Core - ; return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) } + ; -- pprTrace "Don't post-inline-tv" (ppr in_tv <+> equals <+> ppr out_tv_w_unf + -- <+> equals <+> ppr out_ty) $ + return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) } {- ************************************************************************ ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -1444,7 +1444,7 @@ preInlineTypeUnconditionally env tv rhs_ty -- Inline unconditionally if it occurs exactly once, inside a lambda or not. -- No work is wasted by substituting inside a lambda, although if the -- lambda is inlined a lot, we migth duplicate the type. - | OneOcc{ occ_n_br = 1 } <- tyVarOccInfo tv + | isOneTyCoOcc (tyVarOccInfo tv) = Just $! extendTvSubst env tv $! substTy env rhs_ty | otherwise ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -780,10 +780,10 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals final_binds | null spec_binds = wrapDictBinds dict_binds [] - | otherwise = [Rec $ mapFst (addRulesToId local_rule_base) $ - flattenBinds $ - wrapDictBinds dict_binds $ - spec_binds] + | otherwise = glomValBinds $ + wrapDictBinds dict_binds $ + map (mapBindBndrs (addRulesToId local_rule_base)) $ + spec_binds ; return (rules_for_imps, final_binds) } ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -472,7 +472,12 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = text "@" <> pprTyVarWithKind tyvar + = text "@" <> pp_occ <> pprTyVarWithKind tyvar + where + pp_occ = case tyVarOccInfo tyvar of + TyCoDead -> text "[dead]" + TyCoOne -> text "[one]" + TyCoMany -> empty -- pprId x prints x :: ty pprId :: Id -> SDoc ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -153,8 +153,7 @@ simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr -- created from DynFlags, but not necessarily. simpleOptExpr opts expr - = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) - simpleOptExprWith opts init_subst expr + = simpleOptExprWith opts init_subst expr where init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr))) -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr] @@ -176,9 +175,10 @@ simpleOptExprNoInline opts expr simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith opts subst expr - = simple_opt_expr init_env (occurAnalyseExpr expr) + = simple_opt_expr init_env occ_expr where init_env = (emptyEnv opts) { soe_subst = subst } + occ_expr = occurAnalyseExpr expr ---------------------- simpleOptPgm :: SimpleOpts @@ -493,7 +493,7 @@ simple_type_bind env@(SOE { soe_subst = subst }) | occurs_once || typeIsSmallEnoughToInline out_ty = (env { soe_subst = extendTvSubst subst in_tv out_ty }, Nothing) - | otherwise + | otherwise -- Make a type binding = let (subst1, tv1) = substTyVarBndr subst in_tv out_tv = tv1 `setTyVarUnfolding` out_ty in ( env { soe_subst = extendTvSubst subst1 in_tv (mkTyVarTy out_tv) } @@ -504,7 +504,7 @@ simple_type_bind env@(SOE { soe_subst = subst }) subst_for_rhs = setInScope (soe_subst rhs_env) (substInScopeSet subst) out_ty = substTyUnchecked subst_for_rhs in_ty bndr_occ = tyVarOccInfo in_tv - occurs_once {- syntactically -} = isOneOcc bndr_occ && occ_n_br bndr_occ == 1 + occurs_once {- syntactically -} = isOneTyCoOcc bndr_occ ---------------------- simple_bind_pair :: SimpleOptEnv @@ -1621,7 +1621,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) - , not (isTyVar x) && not (isCoVar x) + , isNonCoVarId x , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co , let res = Just (x',e',ts) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -73,6 +73,8 @@ module GHC.Types.Basic ( isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, isNoOccInfo, strongLoopBreaker, weakLoopBreaker, + TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc, + InsideLam(..), BranchCount, oneBranch, InterestingCxt(..), @@ -1380,8 +1382,25 @@ point can also be invoked from other join points, not just from case branches: Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`. +-} -************************************************************************ +data TyCoOccInfo = TyCoDead | TyCoOne | TyCoMany + +instance Outputable TyCoOccInfo where + ppr TyCoDead = text "dead" + ppr TyCoOne = text "one" + ppr TyCoMany = text "many" + +isOneTyCoOcc :: TyCoOccInfo -> Bool +isOneTyCoOcc TyCoOne = True +isOneTyCoOcc _ = False + +plusTyCoOccInfo :: TyCoOccInfo -> TyCoOccInfo -> TyCoOccInfo +plusTyCoOccInfo TyCoDead occ = occ +plusTyCoOccInfo occ TyCoDead = occ +plusTyCoOccInfo _ _ = TyCoMany + +{-********************************************************************** * * Default method specification * * @@ -2461,4 +2480,4 @@ convImportLevel NotLevelled = NormalLevel convImportLevelSpec :: ImportDeclLevel -> ImportLevel convImportLevelSpec ImportDeclQuote = QuoteLevel -convImportLevelSpec ImportDeclSplice = SpliceLevel \ No newline at end of file +convImportLevelSpec ImportDeclSplice = SpliceLevel ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -128,7 +128,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , nonDetCmpUnique ) -import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo ) +import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo, TyCoOccInfo(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable @@ -269,7 +269,7 @@ data Var varType :: Kind, -- ^ The type or kind of the 'Var' in question tv_unfolding :: Maybe Type, -- ^ The type to which the variable is bound to, -- if any, see Note [Type and coercion lets] in GHC.Core - tv_occ_info :: OccInfo + tv_occ_info :: TyCoOccInfo } | TcTyVar { -- Used only during type inference @@ -1032,8 +1032,8 @@ tyVarUnfolding_maybe :: TyVar -> Maybe Type tyVarUnfolding_maybe (TyVar { tv_unfolding = unf }) = unf tyVarUnfolding_maybe _ = Nothing -tyVarOccInfo :: TyVar -> OccInfo -tyVarOccInfo (TcTyVar {}) = noOccInfo +tyVarOccInfo :: TyVar -> TyCoOccInfo +tyVarOccInfo (TcTyVar {}) = TyCoMany tyVarOccInfo tv = assertPpr (isTyVar tv) (ppr tv) $ tv_occ_info tv setTyVarUnique :: TyVar -> Unique -> TyVar @@ -1059,7 +1059,7 @@ zapTyVarUnfolding tv@(TcTyVar {}) = tv -- Why: because zapTyVarUnfolding is called by substTyBndr during typechecking zapTyVarUnfolding v = pprPanic "zapTyVarUnfolding" (ppr v) -setTyVarOccInfo :: HasDebugCallStack => TyVar -> OccInfo -> TyVar +setTyVarOccInfo :: HasDebugCallStack => TyVar -> TyCoOccInfo -> TyVar setTyVarOccInfo tv@(TyVar {}) occ_info = tv {tv_occ_info = occ_info} setTyVarOccInfo tv occ_info @@ -1101,7 +1101,7 @@ mkTyVar name kind = TyVar { varName = name , realUnique = nameUnique name , varType = kind , tv_unfolding = Nothing - , tv_occ_info = noOccInfo + , tv_occ_info = TyCoMany } mkTyVarWithUnfolding :: Name -> Kind -> Type -> TyVar @@ -1109,7 +1109,7 @@ mkTyVarWithUnfolding name kind unf = TyVar { varName = name , realUnique = nameUnique name , varType = kind , tv_unfolding = Just unf - , tv_occ_info = noOccInfo + , tv_occ_info = TyCoMany } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e69b3f51045360e53260aec1734f23f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e69b3f51045360e53260aec1734f23f… You're receiving this email because of your account on gitlab.haskell.org.

1 0