- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/andreask/hadrian_race] ghc-pkg: Rework locking to make it more stable under concurrent accesses.
by Andreas Klebinger (＠AndreasK) 06 Feb '26

06 Feb '26

Andreas Klebinger pushed to branch wip/andreask/hadrian_race at Glasgow Haskell Compiler / GHC Commits: 1b7bcd0d by Andreas Klebinger at 2026-02-06T21:01:35+01:00 ghc-pkg: Rework locking to make it more stable under concurrent accesses. ghc-pkg will now keep a database locked while reading it. See Note [ghc-pkg database locking] for details. I also killed of the remaining workarounds for single file package databases. This should fix #22870. - - - - - 3 changed files: - docs/users_guide/9.16.1-notes.rst - libraries/ghc-boot/GHC/Unit/Database.hs - utils/ghc-pkg/Main.hs Changes: ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -160,6 +160,13 @@ Cmm the recompilation checker will look at to determine if a module needs to be recompiled. +``ghc-pkg`` utility +~~~~~~~~~~~~~~~~~~~ + +- A slight rework how package databases are being locked should make ghc-pkg more + reliable when multiple invocations try to read/modify a package database at the + same time. + Included libraries ~~~~~~~~~~~~~~~~~~ ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -58,6 +58,9 @@ module GHC.Unit.Database , DbMode(..) , DbOpenMode(..) , isDbOpenReadMode + , dbMode + , modeWithLock + , readPackageDbForGhc , readPackageDbForGhcPkg , writePackageDb @@ -65,6 +68,7 @@ module GHC.Unit.Database , PackageDbLock , lockPackageDb , unlockPackageDb + , withLockedPackageDb -- * Misc , mkMungePathUrl , mungeUnitInfoPaths @@ -313,6 +317,22 @@ data DbInstUnitId -- | Represents a lock of a package db. newtype PackageDbLock = PackageDbLock Handle +-- | Run the action under a lock, then return the result. +-- If the mode is R/W the *caller* needs to either free the lock or pass it +-- on to code that will. +-- +-- If an exception is raised the lock is released. +withLockedPackageDb :: DbOpenMode m t -> FilePath -> (PackageDbLock -> IO a) -> IO a +withLockedPackageDb mode file act = do + lock <- lockPackageDbWith (lock_mode mode) file + r <- act lock `onException` unlockPackageDb lock + when (isDbOpenReadMode mode ) $ unlockPackageDb lock + pure r + where + lock_mode :: DbOpenMode m t -> LockMode + lock_mode DbOpenReadOnly = SharedLock + lock_mode DbOpenReadWrite{} = ExclusiveLock + -- | Acquire an exclusive lock related to package DB under given location. lockPackageDb :: FilePath -> IO PackageDbLock @@ -362,12 +382,13 @@ lockPackageDbWith mode file = do return $ PackageDbLock hnd lockPackageDb = lockPackageDbWith ExclusiveLock + unlockPackageDb (PackageDbLock hnd) = do hUnlock hnd hClose hnd -- | Mode to open a package db in. -data DbMode = DbReadOnly | DbReadWrite +data DbMode = DbReadOnly | DbReadWrite deriving Eq -- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So -- it is like 'Maybe' but with a type argument for the mode to enforce that the @@ -380,6 +401,14 @@ deriving instance Functor (DbOpenMode mode) deriving instance F.Foldable (DbOpenMode mode) deriving instance F.Traversable (DbOpenMode mode) +dbMode :: DbOpenMode m t -> DbMode +dbMode DbOpenReadOnly = DbReadOnly +dbMode DbOpenReadWrite{} = DbReadWrite + +modeWithLock :: PackageDbLock -> DbOpenMode m t -> DbOpenMode m PackageDbLock +modeWithLock _ DbOpenReadOnly = DbOpenReadOnly +modeWithLock l DbOpenReadWrite{} = DbOpenReadWrite l + isDbOpenReadMode :: DbOpenMode mode t -> Bool isDbOpenReadMode = \case DbOpenReadOnly -> True @@ -388,9 +417,11 @@ isDbOpenReadMode = \case -- | Read the part of the package DB that GHC is interested in. -- readPackageDbForGhc :: FilePath -> IO [DbUnitInfo] -readPackageDbForGhc file = - decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case - (pkgs, DbOpenReadOnly) -> return pkgs +readPackageDbForGhc file = do + hPutStrLn stderr $ "readPackageDbForGhc:" ++ show file + withLockedPackageDb DbOpenReadOnly file $ \_ -> do + decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case + (pkgs, DbOpenReadOnly) -> return pkgs where getDbForGhc = do _version <- getHeader @@ -405,11 +436,13 @@ readPackageDbForGhc file = -- is not defined in this package. This is because ghc-pkg uses Cabal types -- (and Binary instances for these) which this package does not depend on. -- +-- The incoming mode carries the exclusive lock if we are in R/W mode. +-- -- If we open the package db in read only mode, we get its contents. Otherwise -- we additionally receive a PackageDbLock that represents a lock on the -- database, so that we can safely update it later. -- -readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t -> +readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode PackageDbLock -> IO (pkgs, DbOpenMode mode PackageDbLock) readPackageDbForGhcPkg file mode = decodeFromFile file mode getDbForGhcPkg @@ -496,26 +529,19 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0" -- | Feed a 'Get' decoder with data chunks from a file. -- -decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs -> +-- The file is already locked when we call this. We only need to pass it on +-- if we are in R/W mode. +decodeFromFile :: FilePath -> DbOpenMode mode PackageDbLock -> Get pkgs -> IO (pkgs, DbOpenMode mode PackageDbLock) decodeFromFile file mode decoder = case mode of DbOpenReadOnly -> do - -- Note [Locking package database on Windows] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- When we open the package db in read only mode, there is no need to acquire - -- shared lock on non-Windows platform because we update the database with an - -- atomic rename, so readers will always see the database in a consistent - -- state. -#if defined(mingw32_HOST_OS) - bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do -#endif (, DbOpenReadOnly) <$> decodeFileContents DbOpenReadWrite{} -> do - -- When we open the package db in read/write mode, acquire an exclusive lock - -- on the database and return it so we can keep it for the duration of the + -- When we open the package db in read/write mode, we receive an exclusive lock + -- on the database via the mode and return it so we can keep it for the duration of the -- update. - bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do - (, DbOpenReadWrite lock) <$> decodeFileContents + -- If an exception is raised the caller releases the lock. + (, mode) <$> decodeFileContents where decodeFileContents = withBinaryFile file ReadMode $ \hnd -> feed hnd (runGetIncremental decoder) ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -Wno-orphans -Wno-x-partial #-} -- Fine if this comes from make/Hadrian or the pre-built base. @@ -872,6 +873,23 @@ lookForPackageDBIn dir = do exists_file <- doesFileExist path_file if exists_file then return (Just path_file) else return Nothing +{- Note [ghc-pkg database locking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We differentiate the read only (RO) and read write (R/W) cases. + +The general idea is we use `withLockedPackageDb` to lock an already existing +database in both modes. In RO mode we simply unlock the DB once we read it. +The unlocking is also handled by withLockedPackageDb. + +For the R/W case withLockedPackageDb will *lock* the database, and handle unlocking +in the case of exceptions. But rather than unlocking it once the argument has been +executed without error we simply pass along the lock inside either a `DbOpenMode` or `PackageDB` +so we can keep holding while doing one or more modifications. + +The alternative would be to rewrite much of this in a CPS/bracket style and I couldn't +quite bring myself to do so. + +-} readParseDatabase :: forall mode t. Verbosity -> Maybe (FilePath,Bool) -> GhcPkg.DbOpenMode mode t @@ -889,83 +907,79 @@ readParseDatabase verbosity mb_user_conf mode use_cache path = do e <- tryIO $ getDirectoryContents path case e of Left err - | ioeGetErrorType err == InappropriateType -> do - -- We provide a limited degree of backwards compatibility for - -- old single-file style db: - mdb <- tryReadParseOldFileStyleDatabase verbosity - mb_user_conf mode use_cache path - case mdb of - Just db -> return db - Nothing -> - die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" - ++ "to create the database with the correct format." - + | ioeGetErrorType err == InappropriateType -> dieOnSingleFileDb path | otherwise -> ioError err - Right fs - | not use_cache -> ignore_cache (const $ return ()) - | otherwise -> do - e_tcache <- tryIO $ getModificationTime cache - case e_tcache of - Left ex -> do - whenReportCacheErrors $ - if isDoesNotExistError ex - then - -- It's fine if the cache is not there as long as the - -- database is empty. - when (not $ null confs) $ do - warn ("WARNING: cache does not exist: " ++ cache) - warn ("ghc will fail to read this package db. " ++ - recacheAdvice) - else do - warn ("WARNING: cache cannot be read: " ++ show ex) - warn "ghc will fail to read this package db." - ignore_cache (const $ return ()) - Right tcache -> do - when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) - -- If any of the .conf files is newer than package.cache, we - -- assume that cache is out of date. - cache_outdated <- (`anyM` confs) $ \conf -> - (tcache <) <$> getModificationTime conf - if not cache_outdated - then do - when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) - GhcPkg.readPackageDbForGhcPkg cache mode - >>= uncurry mkPackageDB - else do - whenReportCacheErrors $ do - warn ("WARNING: cache is out of date: " ++ cache) - warn ("ghc will see an old view of this " ++ - "package db. " ++ recacheAdvice) - ignore_cache $ \file -> do - when (verbosity >= Verbose) $ do - tFile <- getModificationTime file - let rel = case tcache `compare` tFile of - LT -> " (NEWER than cache)" - GT -> " (older than cache)" - EQ -> " (same as cache)" - warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) - where - confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs - - ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode) - ignore_cache checkTime = do - -- If we're opening for modification, we need to acquire a - -- lock even if we don't open the cache now, because we are - -- going to modify it later. - lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode - let doFile f = do checkTime f - parseSingletonPackageConf verbosity f - pkgs <- mapM doFile confs - mkPackageDB pkgs lock - - -- We normally report cache errors for read-only commands, - -- since modify commands will usually fix the cache. - whenReportCacheErrors = when $ verbosity > Normal - || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode + -- Take a lock to use while we read the DB + Right fs -> withLockedPackageDb mode cache $ \lock -> do + if not use_cache + then ignore_cache (lock) (const $ return ()) + else do + e_tcache <- tryIO $ getModificationTime cache + case e_tcache of + Left ex -> do + whenReportCacheErrors $ + if isDoesNotExistError ex + then + -- It's fine if the cache is not there as long as the + -- database is empty. + when (not $ null confs) $ do + warn ("WARNING: cache does not exist: " ++ cache) + warn ("ghc will fail to read this package db. " ++ + recacheAdvice) + else do + warn ("WARNING: cache cannot be read: " ++ show ex) + warn "ghc will fail to read this package db." + ignore_cache (lock) (const $ return ()) + Right tcache -> do + when (verbosity >= Verbose) $ do + warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + -- If any of the .conf files is newer than package.cache, we + -- assume that cache is out of date. + cache_outdated <- (`anyM` confs) $ \conf -> + (tcache <) <$> getModificationTime conf + if not cache_outdated + then do + when (verbosity > Normal) $ + infoLn ("using cache: " ++ cache) + GhcPkg.readPackageDbForGhcPkg cache (modeWithLock lock mode) + >>= uncurry mkPackageDB + else do + whenReportCacheErrors $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn ("ghc will see an old view of this " ++ + "package db. " ++ recacheAdvice) + ignore_cache (lock) $ \file -> do + when (verbosity >= Verbose) $ do + tFile <- getModificationTime file + let rel = case tcache `compare` tFile of + LT -> " (NEWER than cache)" + GT -> " (older than cache)" + EQ -> " (same as cache)" + warn ("Timestamp " ++ show tFile + ++ " for " ++ file ++ rel) + where + confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs + + -- Read the package db, potentially locking the .cache file for r/w mode. + ignore_cache :: PackageDbLock -> (FilePath -> IO ()) -> IO (PackageDB mode) + ignore_cache lock checkTime = do + -- If we're opening for modification, we need to acquire a + -- lock even if we don't open the cache now, because we are + -- going to modify it later. + + -- mode' <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode + + let doFile f = do checkTime f + parseSingletonPackageConf verbosity f + pkgs <- mapM doFile confs + + -- mkPackageDB pkgs mode' + mkPackageDB pkgs (modeWithLock lock mode) + + -- We normally report cache errors for read-only commands, + -- since modify commands will usually fix the cache. + whenReportCacheErrors = when $ verbosity > Normal + || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode where cache = path </> cachefilename @@ -1060,75 +1074,16 @@ mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) Just cs@(c : _) | isPathSeparator c -> Just cs _ -> Nothing --- ----------------------------------------------------------------------------- --- Workaround for old single-file style package dbs - --- Single-file style package dbs have been deprecated for some time, but --- it turns out that Cabal was using them in one place. So this code is for a --- workaround to allow older Cabal versions to use this newer ghc. - --- We check if the file db contains just "[]" and if so, we look for a new --- dir-style db in path.d/, ie in a dir next to the given file. --- We cannot just replace the file with a new dir style since Cabal still --- assumes it's a file and tries to overwrite with 'writeFile'. - --- ghc itself also cooperates in this workaround - -tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool) - -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath - -> IO (Maybe (PackageDB mode)) -tryReadParseOldFileStyleDatabase verbosity mb_user_conf - mode use_cache path = do - -- assumes we've already established that path exists and is not a dir - content <- readFile path `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - path_abs <- absolutePath path - let path_dir = adjustOldDatabasePath path - warn $ "Warning: ignoring old file-style db and trying " ++ path_dir - direxists <- doesDirectoryExist path_dir - if direxists - then do - db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir - -- but pretend it was at the original location - return $ Just db { - location = path, - locationAbsolute = path_abs - } - else do - lock <- F.forM mode $ \_ -> do - createDirectoryIfMissing True path_dir - GhcPkg.lockPackageDb $ path_dir </> cachefilename - return $ Just PackageDB { - location = path, - locationAbsolute = path_abs, - packageDbLock = lock, - packages = [] - } - - -- if the path is not a file, or is not an empty db then we fail - else return Nothing - +-- | Just preserved to give a more informative error adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode) adjustOldFileStylePackageDB db = do -- assumes we have not yet established if it's an old style or not mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing - case fmap (take 2) mcontent of + case mcontent of -- it is an old style and empty db, so look for a dir kind in location.d/ - Just "[]" -> return db { - location = adjustOldDatabasePath $ location db, - locationAbsolute = adjustOldDatabasePath $ locationAbsolute db - } - -- it is old style but not empty, we have to bail - Just _ -> die $ "ghc no longer supports single-file style package " - ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'" - ++ "to create the database with the correct format." - -- probably not old style, carry on as normal + Just _ -> dieOnSingleFileDb (location db) Nothing -> return db -adjustOldDatabasePath :: FilePath -> FilePath -adjustOldDatabasePath = (<.> "d") - -- ----------------------------------------------------------------------------- -- Creating a new package DB @@ -2289,3 +2244,9 @@ removeFileSafe fn = -- absolute path. absolutePath :: FilePath -> IO FilePath absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory + +dieOnSingleFileDb :: FilePath -> IO a +dieOnSingleFileDb path = + die $ "ghc no longer supports single-file style package " + ++ "databases (" ++ path ++ ") use 'ghc-pkg init'" + ++ "to create the database with the correct format." \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a54… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b7bcd0d7caf8e96d6b2ae5fd3b5a54… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/hadrian_race
by Andreas Klebinger (＠AndreasK) 06 Feb '26

06 Feb '26

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

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Fix subtle bug in GHC.Core.Utils.mkTick
by Marge Bot (＠marge-bot) 06 Feb '26

06 Feb '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cbe4300e by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Fix subtle bug in GHC.Core.Utils.mkTick This patch fixes a decade-old bug in `mkTick`, which could generate type-incorrect code! See the diagnosis in #26772. The new code is simpler and easier to understand. (As #26772 says, I think it could be improved further.) - - - - - a193a8da by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Modify a debug-trace in the Simplifier ...just to show a bit more information. - - - - - b579dfdc by Simon Peyton Jones at 2026-02-05T04:31:04-05:00 Fix long-standing interaction between ticks and casts The code for Note [Eliminate Identity Cases] was simply wrong when ticks and casts interacted. This patch fixes the interaction. It was shown up when validating #26772, although it's not the exactly the bug that's reported by #26772. Nor is it easy to reproduce, hence no regression test. - - - - - fac0de1e by Cheng Shao at 2026-02-05T04:31:49-05:00 libraries: bump Cabal submodule to 3.16.1.0 - - - - - 00589122 by Cheng Shao at 2026-02-05T04:31:49-05:00 libraries: bump deepseq submodule to 1.5.2.0 Also: - Get rid of usage of deprecated `NFData` function instance in the compiler - `T21391` still relies on `NFData` function instance, add `-Wno-deprecations` for the time being. - - - - - 84474c71 by Cheng Shao at 2026-02-05T04:31:50-05:00 libraries: bump directory submodule to 1.3.10.1 - - - - - 1a9f4662 by Cheng Shao at 2026-02-05T04:31:50-05:00 libraries: bump exceptions submodule to 0.10.12 - - - - - b1fa7890 by Teo Camarasu at 2026-02-06T13:43:54-05:00 ghc-internal: Delete unnecessary GHC.Internal.Data.Ix This module merely re-exports GHC.Internal.Ix. It was copied from `base` when `ghc-internal` was split, but there is no reason to have this now. So, let's delete it. Resolves #26848 - - - - - 2bfb6339 by Andreas Klebinger at 2026-02-06T13:43:55-05:00 hadrian/build-cabal: Better respect and utilize -j * We now respect -j<n> for the cabal invocation to build hadrian rather than hardcoding -j * We use the --semaphore flag to ensure cabal/ghc build the hadrian executable in parallel using the -jsem mechanism. Saves 10-15s on fresh builds for me. Fixes #26876 - - - - - 23 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Unit/Module/ModIface.hs - hadrian/build-cabal - libraries/Cabal - libraries/base/src/Data/Ix.hs - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/ghc-internal/ghc-internal.cabal.in - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs - testsuite/tests/ghci.debugger/scripts/T26042b.stdout - testsuite/tests/ghci.debugger/scripts/T26042c.stdout - testsuite/tests/ghci.debugger/scripts/T26042d2.stdout - testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - 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/simplCore/should_compile/T21391.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1713,6 +1713,7 @@ simplCast env body co0 cont0 , sc_hole_ty = coercionLKind co }) } -- NB! As the cast goes past, the -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 @@ -1838,7 +1839,7 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] not (exprIsTrivial arg) && not (isDeadOcc (idOccInfo bndr)) ) - -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.Tickish import GHC.Types.Demand import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Types.Name.Env import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -81,9 +82,9 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic -import Control.Monad ( when ) +import Control.Monad ( guard, when ) import Data.List ( sortBy ) -import GHC.Types.Name.Env +import Data.Maybe import Data.Graph {- ********************************************************************* @@ -2570,7 +2571,27 @@ Note [Eliminate Identity Case] True -> True; False -> False -and similar friends. +and similar friends. There are some tricky wrinkles: + +(EIC1) Casts. We've seen this: + case e of x { _ -> x `cast` c } + And we definitely want to eliminate this case, to give + e `cast` c +(EIC2) Ticks. Similarly + case e of x { _ -> Tick t x } + At least if the tick is 'floatable' we want to eliminate the case + to give + Tick t e + +So `check_eq` strips off enclosing casts and ticks from the RHS of the +alternative, returning a wrapper function that will rebuild them around +the scrutinee if case-elim is successful. + +(EIC3) What if there are many alternatives, all identities. If casts + are involved they must be the same cast, to make the types line up. + In principle there could be different ticks in each RHS, but we just + pick the ticks from the first alternative. (In the common case there + is only one alternative.) Note [Scrutinee Constant Folding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2764,45 +2785,47 @@ mkCase mode scrut outer_bndr alts_ty alts -- See Note [Eliminate Identity Case] -------------------------------------------------- -mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case - | all identity_alt alts +mkCase1 _mode scrut case_bndr _ (alt1 : alts) -- Identity case + | Just wrap <- identity_alt alt1 -- `wrap`: see (EIC1) and (EIC2) + , all (isJust . identity_alt) alts -- See (EIC3) in Note [Eliminate Identity Case] = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } + ; return (wrap scrut) } where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' - identity_alt (Alt con args rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False + identity_alt :: CoreAlt -> Maybe (CoreExpr -> CoreExpr) + identity_alt (Alt con args rhs) = check_eq con args rhs + + check_eq :: AltCon -> [Var] -> CoreExpr -> Maybe (CoreExpr -> CoreExpr) + -- (check_eq con args e) return True if + -- e looks like (Tick (Cast (Tick (con args)))) + -- where (con args) is the LHS of the alternative + -- In that case it returns (\e. Tick (Cast (Tick e))), + -- a wrapper function that can rebuild the tick/cast stuff + -- See (EIC1) and (EIC2) in Note [Eliminate Identity Case] + check_eq alt_con args (Cast e co) -- See (EIC1) + = do { guard (not (any (`elemVarSet` tyCoVarsOfCo co) args)) + ; wrap <- check_eq alt_con args e + ; return (flip mkCast co . wrap) } + check_eq alt_con args (Tick t e) -- See (EIC2) + = do { guard (tickishFloatable t) + ; wrap <- check_eq alt_con args e + ; return (Tick t . wrap) } + check_eq alt_con args e + | is_id alt_con args e = Just (\e -> e) + | otherwise = Nothing + + is_id :: AltCon -> [Var] -> CoreExpr -> Bool + is_id _ _ (Var v) | v == case_bndr = True + is_id (LitAlt lit') _ (Lit lit) = lit == lit' + is_id (DataAlt con) args rhs + | Var v <- rhs -- Optimisation only + , null arg_tys + , null args = v == dataConWorkId con + | otherwise = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + is_id _ _ _ = False arg_tys = tyConAppArgs (idType case_bndr) - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -252,7 +252,7 @@ applyTypeToArgs op_ty args mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co +mkCastMCo e (MCo co) = mkCast e co -- We are careful to use (MCo co) only when co is not reflexive -- Hence (Cast e co) rather than (mkCast e co) @@ -305,40 +305,41 @@ mkCast expr co -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr +mkTick t orig_expr = mkTick' id orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- mkTick' handles floating of ticks *into* the expression. - -- In this function, `top` is applied after adding the tick, and `rest` before. - -- This will result in applications that look like (top $ Tick t $ rest expr). - -- If we want to push the tick deeper, we pre-compose `top` with a function - -- adding the tick. - mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) - -> CoreExpr -- current expression + mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) + -- Always a composition of (Tick t) wrappers + -> CoreExpr -- Current expression -> CoreExpr - mkTick' top rest expr = case expr of + -- So in the call (mkTick' rest e), the expression + -- (rest e) + -- has the same type as e + -- Returns an expression equivalent to (Tick t (rest e)) + mkTick' rest expr = case expr of -- Float ticks into unsafe coerce the same way we would do with a cast. Case scrut bndr ty alts@[Alt ac abs _rhs] | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs + -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr -- Otherwise we assume that ticks of different placements float -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e -- For annotations this is where we make sure to not introduce -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e + | tickishContains t t2 -> mkTick' rest e -- Drop t2 + | tickishContains t2 t -> rest e -- Drop t + | otherwise -> mkTick' (rest . Tick t2) e -- Ticks don't care about types, so we just float all ticks -- through them. Note that it's not enough to check for these @@ -346,14 +347,14 @@ mkTick t orig_expr = mkTick' id id orig_expr -- expressions below ticks, such constructs can be the result of -- unfoldings. We therefore make an effort to put everything into -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co + Cast e co -> mkCast (mkTick' rest e) co + Coercion co -> Tick t $ rest (Coercion co) Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e + -> Lam x $ mkTick' rest e -- If it is both counting and scoped, we split the tick into its -- two components, often allowing us to keep the counting tick on @@ -362,25 +363,25 @@ mkTick t orig_expr = mkTick' id id orig_expr -- floated, and the lambda may then be in a position to be -- beta-reduced. | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e App f arg -- Always float through type applications. | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f + -> App (mkTick' rest f) arg -- We can also float through constructor applications, placement -- permitting. Again we can split. | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then rest $ tickHNFArgs t expr + else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr Var x | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr + -> Tick (mkNoScope t) $ rest expr where -- SCCs can be eliminated on variables provided the variable -- is not a function. In these cases the SCC makes no difference: @@ -392,10 +393,10 @@ mkTick t orig_expr = mkTick' id id orig_expr Lit{} | tickishPlace t == PlaceCostCentre - -> orig_expr + -> rest expr -- Drop t -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr + _any -> Tick t $ rest expr mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -49,6 +49,7 @@ import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core.Utils( mkCast ) import GHC.Core ( Expr(..), mkConApp ) import GHC.StgToCmm.Closure ( isSmallFamily ) @@ -455,7 +456,7 @@ matchWithDict [cls_ty, mty] = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ Var k `App` (evUnaryDictAppE cls dict_args meth_arg) where - meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) + meth_arg = Var sv `mkCast` mkSubCo (evExprCoercion ev_expr) ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c] mk_ev e = pprPanic "matchWithDict" (ppr e) @@ -657,7 +658,7 @@ matchDataToTag dataToTagClass [levity, dty] = do (mkReflCo Representational intPrimTy) -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $ - [methodRep `Cast` methodCo] + [methodRep `mkCast` methodCo] ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.) , cir_mk_ev = mk_ev , cir_canonical = EvCanonical ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Tc.Utils.TcType import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion +import GHC.Core.Utils( mkCast ) import GHC.Core.Ppr () -- Instance OutputableBndr TyVar import GHC.Core.Predicate import GHC.Core.Type @@ -930,7 +931,7 @@ evCastE ee co | assertPpr (coercionRole co == Representational) (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $ isReflCo co = ee - | otherwise = Cast ee co + | otherwise = mkCast ee co evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -- Dictionary instance application, including when the "dictionary function" ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -894,13 +894,7 @@ instance (NFData (IfaceAbiHashesExts phase), NFData (IfaceDeclExts phase)) => NF `seq` rnf a14 instance NFData IfaceCache where - rnf (IfaceCache a1 a2 a3 a4) - = rnf a1 - `seq` rnf a2 - `seq` rnf a3 - `seq` rnf a4 - - + rnf = rwhnf forceModIface :: ModIface -> IO () forceModIface iface = () <$ (evaluate $ force iface) ===================================== hadrian/build-cabal ===================================== @@ -23,9 +23,47 @@ fi CABVERSTR=$("$CABAL" --numeric-version) CABVER=( ${CABVERSTR//./ } ) +THREADS="-j1" +GC_THREADS="" +SEMAPHORE="" + +echo "$@" + +# Try building hadrian in parallel. We check for -j<n>. +# If threads > 1 we pass --semaphore to allow ghc to build more than one module in parallel +# If threads > 4 we pass -qn as higher parallel gc thread counts can lead to slow downs +# We only do any of thise for cabal >= 3.14, because I don't trust older versions to handle --semaphore right +if [ "${CABVER[0]}" -gt 3 ] || [ "${CABVER[0]}" -eq 3 -a "${CABVER[1]}" -ge 14 ]; +then + + for arg in "$@"; do + case "$arg" in + -j) + GC_THREADS="-qn4" + SEMAPHORE="--semaphore" + THREADS="-j" + ;; + -j[0-9]*) + threads="${arg#-j}" + if [[ "$threads" =~ ^[0-9]+$ ]] && [ "$threads" -ne 0 ]; then + THREADS="-j${threads}" + if [ $threads -ge 4 ]; then + GC_THREADS="-qn4" + fi + if [ $threads -gt 1 ]; then + SEMAPHORE="--semaphore" + fi + fi + ;; + esac + + done + +fi + if [ "${CABVER[0]}" -gt 2 -o "${CABVER[0]}" -eq 2 -a "${CABVER[1]}" -ge 2 ]; then - "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" -j exe:hadrian + "$CABAL" --project-file="$PROJ" new-build "${CABFLAGS[@]}" ${THREADS} ${SEMAPHORE} --ghc-options="+RTS ${GC_THREADS} -RTS" exe:hadrian # use new-exec instead of new-run to make sure that the build-tools (alex & happy) are in PATH "$CABAL" --project-file="$PROJ" new-exec "${CABFLAGS[@]}" hadrian -- \ --directory "$PWD" \ ===================================== libraries/Cabal ===================================== @@ -1 +1 @@ -Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422 +Subproject commit 8d1f5a33662be0db0654061fb53fb00e3f4417e0 ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/deepseq ===================================== @@ -1 +1 @@ -Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f +Subproject commit 882f52f51854544a467babd8cb075e3271f5913e ===================================== libraries/directory ===================================== @@ -1 +1 @@ -Subproject commit 6442a3cf04f74d82cdf8c9213324313d52b23d28 +Subproject commit 8c712e834f277544fc03e96dfbbb769126dc0a7c ===================================== libraries/exceptions ===================================== @@ -1 +1 @@ -Subproject commit 81bfd6e0ca631f315658201ae02e30046678f056 +Subproject commit a3da039855479e3c8542e8b45986599d0414ff68 ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries(a)haskell.org --- Stability : stable --- Portability : portable --- --- The 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== testsuite/tests/ghci.debugger/scripts/T26042b.stdout ===================================== @@ -22,30 +22,18 @@ _result :: -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, Int #) = _ Stopped in Main.foo, T26042b.hs:14:3-18 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 13 y = 4 14 n <- bar (x + y) ^^^^^^^^^^^^^^^^ 15 return n -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ Stopped in Main.main, T26042b.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ 6 print a -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 14 14 ===================================== testsuite/tests/ghci.debugger/scripts/T26042c.stdout ===================================== @@ -1,18 +1,12 @@ Breakpoint 0 activated at T26042c.hs:10:15-22 Stopped in Main.foo, T26042c.hs:10:15-22 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - Int #) = _ +_result :: IO Int = _ 9 foo :: Bool -> Int -> IO Int 10 foo True i = return i ^^^^^^^^ 11 foo False _ = do Stopped in Main.main, T26042c.hs:5:3-26 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 4 main = do 5 a <- foo False undefined ^^^^^^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042d2.stdout ===================================== @@ -1,10 +1,7 @@ Breakpoint 0 activated at T26042d2.hs:11:3-21 hello1 Stopped in Main.f, T26042d2.hs:11:3-21 -_result :: - GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld - -> (# GHC.Internal.Prim.State# GHC.Internal.Prim.RealWorld, - () #) = _ +_result :: IO () = _ 10 f = do 11 putStrLn "hello2.1" ^^^^^^^^^^^^^^^^^^^ ===================================== testsuite/tests/ghci.debugger/scripts/T26042f2.stdout ===================================== @@ -1,6 +1,6 @@ Breakpoint 0 activated at T26042f.hs:(20,7)-(21,14) Stopped in T8.t, T26042f.hs:(20,7)-(21,14) -_result :: Int = _ +_result :: Identity Int = _ x :: Int = 450 19 t :: Int -> Identity Int vv @@ -18,12 +18,12 @@ _result :: Identity Int = _ ^^^^^^^^^^^^ 15 n <- pure (a+a) Stopped in T8.f, T26042f.hs:8:3-14 -_result :: Identity Int = _ +_result :: Int = _ x :: Int = 15 7 f x = do 8 b <- g (x*x) ^^^^^^^^^^^^ 9 y <- pure (b+b) x :: Int = 15 -_result :: Identity Int = _ +_result :: Int = _ 7248 ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1286,7 +1286,7 @@ module Data.Int where data Int8 = ... module Data.Ix where - -- Safety: Safe + -- Safety: Trustworthy type Ix :: * -> Constraint class GHC.Internal.Classes.Ord a => Ix a where range :: (a, a) -> [a] ===================================== testsuite/tests/simplCore/should_compile/T21391.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module Web.Routing.SafeRouting where import Control.DeepSeq (NFData (..)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edd7ef1748fbf3fd6fa64064b88572… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/edd7ef1748fbf3fd6fa64064b88572… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26700] Apply 22 suggestion(s) to 5 file(s)
by recursion-ninja (＠recursion-ninja) 06 Feb '26

06 Feb '26

recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC Commits: be1dab4d by recursion-ninja at 2026-02-06T18:18:44+00:00 Apply 22 suggestion(s) to 5 file(s) Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com> - - - - - 5 changed files: - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/Decl.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/Types/ForeignCall.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs Changes: ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -93,14 +93,14 @@ dsCFExport fn_id co ext_name cconv target_kind = do -- If it's plain t, return (t, ForeignValue) (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, ForeignFunction) + Just (_ioTyCon, res_ty) -> (res_ty, True) -- The function returns t - Nothing -> (orig_res_ty, ForeignValue) + Nothing -> (orig_res_ty, False) dflags <- getDynFlags return $ mkFExportCBits dflags ext_name - (if target_kind == ForeignFunction then Nothing else Just fn_id) + (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv dsCImport :: Id @@ -186,7 +186,7 @@ dsCFExportDynamic id co0 cconv = do export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalMDs stable_ptr_ty - (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction + (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- The arguments to the external function which will @@ -279,7 +279,7 @@ dsFCall fn_id co fcall mDeclHeader = do | isVoidRes = cCall | otherwise = text "return" <+> cCall cCall - | targetKind == ForeignFunction = ppr cName <> parens argVals + | ForeignFunction <- targetKind = ppr cName <> parens argVals | null arg_tys = ppr cName | otherwise = panic "dsFCall: Unexpected arguments to FFI value import" raw_res_ty = case tcSplitIOType_maybe io_res_ty of ===================================== compiler/GHC/HsToCore/Foreign/Decl.hs ===================================== @@ -93,7 +93,7 @@ dsForeigns' fos = do , fd_e_ext = co , fd_fe = CExport _ (L _ (CExportStatic ext_nm cconv)) }) = do - (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv ForeignValue + (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False return (h, c, ids, bs) {- @@ -165,8 +165,7 @@ dsFExport :: Id -- Either the exported Id, -- from C, and its representation type -> CLabelString -- The name to export to C land -> CCallConv - -> ForeignKind -- If it is a function, - -- then is foreign export dynamic + -> Bool -- True => foreign export dynamic -- so invoke IO action that's hanging off -- the first argument's stable pointer -> DsM ( CHeader -- contents of Module_stub.h @@ -175,16 +174,16 @@ dsFExport :: Id -- Either the exported Id, , [Id] -- function closures to be registered as GC roots , [Binding] -- additional bindings used by desugared foreign export ) -dsFExport fn_id co ext_name cconv target_kind = do +dsFExport fn_id co ext_name cconv is_dyn = do platform <- getPlatform case (platformArch platform, cconv) of (ArchJavaScript, _) -> do - (h, c, ts) <- dsJsFExport fn_id co ext_name cconv target_kind + (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn pure (h, c, ts, [fn_id], []) (ArchWasm32, JavaScriptCallConv) -> dsWasmJSExport fn_id co ext_name _ -> do - (h, c, ts) <- dsCFExport fn_id co ext_name cconv target_kind + (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn pure (h, c, ts, [fn_id], []) ===================================== compiler/GHC/HsToCore/Foreign/JavaScript.hs ===================================== @@ -72,8 +72,7 @@ dsJsFExport -- from C, and its representation type -> CLabelString -- The name to export to C land -> CCallConv - -> ForeignKind -- If it is a function, - -- then is foreign export dynamic + -> Bool -- True => foreign export dynamic -- so invoke IO action that's hanging off -- the first argument's stable pointer -> DsM ( CHeader -- contents of Module_stub.h @@ -81,7 +80,7 @@ dsJsFExport , String -- string describing type to pass to createAdj. ) -dsJsFExport fn_id co ext_name cconv target_kind = do +dsJsFExport fn_id co ext_name cconv isDyn = do let ty = coercionRKind co (_tvs,sans_foralls) = tcSplitForAllTyVars ty @@ -103,7 +102,7 @@ dsJsFExport fn_id co ext_name cconv target_kind = do platform <- targetPlatform <$> getDynFlags return $ mkFExportJSBits platform ext_name - (if target_kind == ForeignFunction then Nothing else Just fn_id) + (if isDyn then Nothing else Just fn_id) (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv mkFExportJSBits @@ -284,7 +283,7 @@ dsJsFExportDynamic id co0 cconv = do export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalMDs stable_ptr_ty - (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction + (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- The arguments to the external function which will ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -244,19 +244,6 @@ instance NFData ForeignCall where instance forall p. IsPass p => NFData (CCallSpec (GhcPass p)) where rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s --- TODO: The orphan instance should be moved to the 'GHC.Utils.Binary' module and --- and the 'GHC.Utils.Outputable' module after the 'Language.Haskell.Syntax.Decls' --- module no longer imports 'GHC.Hs.Doc'. --- --- Instances for the following types eventually need to be relocated: --- --- * CCallConv --- * CCallTarget --- * CExportSpec --- * CType --- * Header --- * Safety --- instance Binary CCallConv where put_ bh CCallConv = putByte bh 0 @@ -280,8 +267,9 @@ instance Binary CCallConv where -- If Nothing, then it's taken to be in the current package. data StaticTargetGhc = StaticTargetGhc { staticTargetLabel :: SourceText - , staticTargetUnit :: Unit + , staticTargetUnit :: CCallStaticUnit -- ^ What package the function is in. + -- If 'CCallStaticThisUnit', then it's taken to be in the current package -- Note: This information is only used for PrimCalls on Windows. -- See CLabel.labelDynamic and CoreToStg.coreToStgApp -- for the difference in representation between PrimCalls @@ -305,7 +293,7 @@ type instance XXCCallTarget (GhcPass p) = DataConCantHappen type instance XCType (GhcPass p) = CTypeGhc type instance XXCType (GhcPass p) = DataConCantHappen -instance {-# OVERLAPPING #-} NFData (CType (GhcPass p)) where +instance NFData (CType (GhcPass p)) where rnf (CType ext mh fs) = rnf ext `seq` rnf mh `seq` rnf fs @@ -344,7 +332,7 @@ instance Binary StaticTargetGhc where , staticTargetUnit = unit } -instance {-# OVERLAPPING #-} forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where +instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where (==) = \case DynamicTarget{} -> \case DynamicTarget{} -> True ===================================== compiler/Language/Haskell/Syntax/Decls/Foreign.hs ===================================== @@ -201,12 +201,10 @@ data CCallTarget pass = StaticTarget (XStaticTarget pass) CLabelString -- C-land name of label. - -- Used when importing a label as "foreign import ccall "dynamic" ..." - ForeignKind -- True => really a function - -- False => a value; only - -- allowed in CAPI imports + ForeignKind -- only allowed in CAPI imports - -- The first argument of the import is the name of a function pointer (an Addr#). + -- | The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." | DynamicTarget (XDynamicTarget pass) | XCCallTarget !(XXCCallTarget pass) @@ -216,8 +214,8 @@ deriving instance {-# OVERLAPPABLE #-} ( Eq (XXCCallTarget pass)) => Eq (CCallTarget pass) --- foreign export ccall foo :: ty data CExportSpec + -- | foreign export ccall foo :: ty = CExportStatic CLabelString -- C Name of exported function CCallConv View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be1dab4db2cea22c4a7b8548fbc68df… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be1dab4db2cea22c4a7b8548fbc68df… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26700] 2 commits: Adding TTG extension point for 'CType'
by recursion-ninja (＠recursion-ninja) 06 Feb '26

06 Feb '26

recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC Commits: 740d2f68 by Recursion Ninja at 2026-02-06T10:56:27-05:00 Adding TTG extension point for 'CType' - - - - - 0c23fdd0 by Recursion Ninja at 2026-02-06T11:07:19-05:00 Refactoring module name; correcting test-suite dependency counting test cases - - - - - 22 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Types/ForeignCall.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs → compiler/Language/Haskell/Syntax/Decls/Foreign.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Builtin/Types.hs ===================================== @@ -189,6 +189,8 @@ import GHC.Core.Class ( Class, mkClass ) import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) ) +import GHC.Hs.Extension (GhcTc) + import GHC.Types.TyThing import GHC.Types.SourceText import GHC.Types.Var ( VarBndr (Bndr), tyVarName ) @@ -617,7 +619,7 @@ consDataCon_RDR = nameRdrName consDataConName -- This function assumes that the types it creates have all parameters at -- Representational role, and that there is no kind polymorphism. -pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon :: Name -> Maybe (CType GhcTc) -> [TyVar] -> [DataCon] -> TyCon pcTyCon name cType tyvars cons = mkAlgTyCon name (mkTyConKind bndrs res_kind) bndrs 0 res_kind (map (const Representational) tyvars) @@ -2301,14 +2303,17 @@ int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, * * ********************************************************************* -} +-- | Generic constructor for primative C Types. +mkCTypeCon :: Name -> String -> [DataCon] -> TyCon +mkCTypeCon cName str = + pcTyCon cName (Just (defaultCType str)) [] + charTy :: Type charTy = mkTyConTy charTyCon charTyCon :: TyCon -charTyCon = pcTyCon charTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsChar"))) - [] [charDataCon] +charTyCon = mkCTypeCon charTyConName "HsChar" [charDataCon] + charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon @@ -2327,9 +2332,8 @@ intTy :: Type intTy = mkTyConTy intTyCon intTyCon :: TyCon -intTyCon = pcTyCon intTyConName - (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) - [] [intDataCon] +intTyCon = mkCTypeCon intTyConName "HsInt" [intDataCon] + intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon @@ -2337,9 +2341,8 @@ wordTy :: Type wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon -wordTyCon = pcTyCon wordTyConName - (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) - [] [wordDataCon] +wordTyCon = mkCTypeCon wordTyConName "HsWord" [wordDataCon] + wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon @@ -2347,10 +2350,8 @@ word8Ty :: Type word8Ty = mkTyConTy word8TyCon word8TyCon :: TyCon -word8TyCon = pcTyCon word8TyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsWord8"))) [] - [word8DataCon] +word8TyCon = mkCTypeCon word8TyConName "HsWord8" [word8DataCon] + word8DataCon :: DataCon word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon @@ -2358,21 +2359,16 @@ floatTy :: Type floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon -floatTyCon = pcTyCon floatTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsFloat"))) [] - [floatDataCon] +floatTyCon = mkCTypeCon floatTyConName "HsFloat" [floatDataCon] + floatDataCon :: DataCon -floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon doubleTy :: Type doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon -doubleTyCon = pcTyCon doubleTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsDouble"))) [] - [doubleDataCon] +doubleTyCon = mkCTypeCon doubleTyConName "HsDouble" [doubleDataCon] doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon @@ -2565,10 +2561,7 @@ boolTy :: Type boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon -boolTyCon = pcTyCon boolTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsBool"))) - [] [falseDataCon, trueDataCon] +boolTyCon = mkCTypeCon boolTyConName "HsBool" [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon falseDataCon = pcDataCon falseDataConName [] [] boolTyCon ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -158,6 +158,8 @@ import GHC.Builtin.Uniques ( tyConRepNameUnique , dataConTyRepNameUnique ) +import GHC.Hs.Extension (GhcTc) + import GHC.Utils.Binary import GHC.Types.Var import GHC.Types.Var.Set @@ -822,7 +824,8 @@ data TyConDetails = -- Note that it does /not/ scope over the data -- constructors. - tyConCType :: Maybe CType,-- ^ The C type that should be used + tyConCType :: Maybe (CType GhcTc), + -- ^ The C type that should be used -- for this type when using the FFI -- and CAPI @@ -2066,18 +2069,18 @@ well be different from 'mkTyConKind binders res_kind'. -- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name - -> Kind -- ^ TyCon kind - -> [TyConBinder] -- ^ Binders of the 'TyCon' - -> Int -- ^ Number of binders introduced by eta expansion - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> Kind -- ^ TyCon kind + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Int -- ^ Number of binders introduced by eta expansion + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe (CType GhcTc) -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon mkAlgTyCon name kind binders nb_eta_bndrs res_kind roles cType stupid rhs parent gadt_syn = mkTyCon name kind binders nb_eta_bndrs res_kind roles $ @@ -2708,7 +2711,7 @@ isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go detail | SumTyCon {} <- rhs = True | otherwise = False -tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe :: TyCon -> Maybe (CType GhcTc) tyConCType_maybe (TyCon { tyConDetails = details }) | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype | otherwise = Nothing ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -102,7 +102,7 @@ import GHC.Prelude import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Decls -import Language.Haskell.Syntax.Decls.ForeignCall +import Language.Haskell.Syntax.Decls.Foreign import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension @@ -1483,7 +1483,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno CType = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnP type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.InlinePragma (ActivationGhc) import GHC.Data.BooleanFormula (BooleanFormula(..)) import Language.Haskell.Syntax.Decls -import Language.Haskell.Syntax.Decls.ForeignCall +import Language.Haskell.Syntax.Decls.Foreign import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) @@ -255,6 +255,11 @@ deriving instance Data (CCallTarget GhcPs) deriving instance Data (CCallTarget GhcRn) deriving instance Data (CCallTarget GhcTc) +-- deriving instance (DataIdLR p p) => Data (CImportSpec p) +deriving instance Data (CType GhcPs) +deriving instance Data (CType GhcRn) +deriving instance Data (CType GhcTc) + -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn) ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -347,7 +347,7 @@ toCType = f False -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon + , Just (CType _ mHeader cType) <- tyConCType_maybe tycon = (mHeader, ftext cType) -- If we don't know a C type for this type, then try looking -- through one layer of type synonym etc. ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -84,7 +84,7 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) -import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -196,7 +196,7 @@ data IfaceDecl ifBinders :: [IfaceTyConBinder], ifNbEtaBinders :: Int, -- ^ number of binders introduced by eta-expansion ifResKind :: IfaceType, -- Result kind of type constructor - ifCType :: Maybe CType, -- C type for CAPI FFI + ifCType :: Maybe (CType GhcTc), -- C type for CAPI FFI ifRoles :: [Role], -- Roles ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info @@ -1450,7 +1450,7 @@ pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon = hang (text "axiom" <+> ppr name <+> dcolon) 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) -pprCType :: Maybe CType -> SDoc +pprCType :: Maybe (CType (GhcPass p)) -> SDoc pprCType Nothing = Outputable.empty pprCType (Just cType) = text "C type:" <+> ppr cType ===================================== compiler/GHC/Parser.y ===================================== @@ -1680,14 +1680,14 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP CType) } +capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRINGs $3,getSTRING $3))) + {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3))) (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) + {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } | { Nothing } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP CType) + -> Maybe (LocatedP (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -250,7 +250,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdFixity = fixity, tcdDataDefn = defn })) } -mkDataDefn :: Maybe (LocatedP CType) +mkDataDefn :: Maybe (LocatedP (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -325,7 +325,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP CType) + -> Maybe (LocatedP (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2029,13 +2029,15 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = cType + ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = fmap rn_ctype <$> cType , dd_ctxt = context', dd_kindSig = m_sig' , dd_cons = condecls' , dd_derivs = derivs' } , all_fvs ) } where + rn_ctype :: CType GhcPs -> CType GhcRn + rn_ctype (CType x y z) = CType x y z h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] rn_derivs ds ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Unify +import GHC.Types.ForeignCall ( CType(..) ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Var @@ -3598,12 +3599,13 @@ tcDataDefn err_ctxt roles_info tc_name { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name - + ; let tc_ctype :: CType GhcRn -> CType GhcTc + tc_ctype (CType x y z) = CType x y z ; return (mkAlgTyCon tc_name kind bndrs nb_eta res_kind (roles_info tc_name) - (fmap unLoc cType) + (fmap (tc_ctype . unLoc) cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) gadt_syntax) ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -69,6 +69,7 @@ import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Types.ForeignCall ( CType(..) ) import GHC.Types.Id import GHC.Types.InlinePragma import GHC.Types.SourceFile @@ -826,11 +827,13 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env -- NB: Use the full ty_binders from the pats. See bullet toward -- the end of Note [Data type families] in GHC.Core.TyCon + tc_ctype :: CType GhcRn -> CType GhcTc + tc_ctype (CType x y z) = CType x y z rep_tc = mkAlgTyCon rep_tc_name user_kind ty_binders (length extra_tcbs) res_kind (map (const Nominal) ty_binders) - (fmap unLoc cType) stupid_theta + (fmap (tc_ctype . unLoc) cType) stupid_theta tc_rhs parent gadt_syntax -- We always assume that indexed types are recursive. Why? ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -39,7 +39,7 @@ import GHC.Utils.Outputable ( Outputable(..) ) import Language.Haskell.Syntax import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) -import Language.Haskell.Syntax.Decls.ForeignCall ( ForeignDecl(..) ) +import Language.Haskell.Syntax.Decls.Foreign ( ForeignDecl(..) ) import GHC.Boot.TH.Syntax qualified as TH import qualified Data.List.NonEmpty as NE ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -21,19 +21,69 @@ To be resolved at a later time, see TODO at the end of this module. -} module GHC.Types.ForeignCall ( - ForeignCall(..), - isSafeForeignCall, - Safety(..), playSafe, playInterruptible, - - CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, - CCallSpec(..), - CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvAttribute, - ForeignKind(..), - - Header(..), CType(..), - StaticTargetGhc(..), - ) where + -- * Foreign function interface declarations + -- ** Data-type + ForeignDecl(..), + -- ** Record synonym + LForeignDecl, + + -- * Foreign call + ForeignCall(..), + -- ** Queries + isSafeForeignCall, + -- ** CCallSpec + CCallSpec(..), + + -- * Foreign export types + -- ** Data-type + ForeignExport(..), + -- ** Specification + CExportSpec(..), + + -- * Foreign import types + -- ** Data-type + ForeignImport(..), + -- ** Call target + CCallTarget(..), + -- *** GHC extension point + StaticTargetGhc(..), + -- *** Queries + isDynamicTarget, + -- ** Foreign target kind + ForeignKind(..), + -- ** Safety + Safety(..), + -- *** Queries + playSafe, + playInterruptible, + -- ** Specification + CImportSpec(..), + + -- * Foreign binding type + -- ** Data-type + CType(..), + -- *** Construction + defaultCType, + mkCType, + -- *** GHC extension point + CTypeGhc(..), + + -- * General sub-types + -- ** CCallConv + CCallConv(..), + -- *** Default construction + defaultCCallConv, + -- *** Pretty-printing + ccallConvAttribute, + -- ** CLabelString + CLabelString, + -- *** Queries + isCLabelString, + -- *** Pretty-printing + pprCLabelString, + -- ** Header + Header(..), + ) where import GHC.Prelude @@ -42,17 +92,16 @@ import GHC.Hs.Extension import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.SourceText (SourceText, pprWithSourceText) +import GHC.Types.SourceText (SourceText(..), pprWithSourceText) import GHC.Unit.Types -import Language.Haskell.Syntax.Decls.ForeignCall - (CCallConv(..), CCallTarget(..), CExportSpec(..), CLabelString, - CType(..), ForeignKind(..), Header(..), Safety(..)) +import Language.Haskell.Syntax.Decls.Foreign import Language.Haskell.Syntax.Extension import Data.Char import Data.Data (Data) import Data.Functor ((<&>)) +import Data.String (fromString) import Control.DeepSeq (NFData(..)) @@ -158,6 +207,14 @@ instance forall p. IsPass p => Outputable (CCallSpec (GhcPass p)) where <> ppr label <+> (pprWithSourceText srcTxt empty) +defaultCType :: String -> CType (GhcPass p) +defaultCType = + CType (CTypeGhc NoSourceText NoSourceText) Nothing . fromString + +mkCType :: SourceText -> SourceText -> Maybe Header -> FastString -> CType (GhcPass p) +mkCType x y m = + CType (CTypeGhc x y) m + {- ************************************************************************ * * @@ -233,12 +290,42 @@ data StaticTargetGhc = StaticTargetGhc } deriving (Data, Eq) +data CTypeGhc = CTypeGhc + { cTypeSourceText :: SourceText + , cTypeOtherText :: SourceText + } + deriving (Data, Eq) + type instance XStaticTarget GhcPs = SourceText type instance XStaticTarget GhcRn = StaticTargetGhc type instance XStaticTarget GhcTc = StaticTargetGhc type instance XDynamicTarget (GhcPass p) = NoExtField type instance XXCCallTarget (GhcPass p) = DataConCantHappen +type instance XCType (GhcPass p) = CTypeGhc +type instance XXCType (GhcPass p) = DataConCantHappen + +instance {-# OVERLAPPING #-} NFData (CType (GhcPass p)) where + rnf (CType ext mh fs) = + rnf ext `seq` rnf mh `seq` rnf fs + +instance NFData CTypeGhc where + rnf st = + rnf (cTypeSourceText st) `seq` + rnf (cTypeOtherText st) + +instance Binary CTypeGhc where + put_ bh ct = do + put_ bh (cTypeSourceText ct) + put_ bh (cTypeOtherText ct) + get bh = do + str1 <- get bh + str2 <- get bh + return $ CTypeGhc + { cTypeSourceText = str1 + , cTypeOtherText = str2 + } + instance NFData StaticTargetGhc where rnf st = rnf (staticTargetLabel st) `seq` @@ -258,24 +345,24 @@ instance Binary StaticTargetGhc where } instance {-# OVERLAPPING #-} forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where - (==) = \case - DynamicTarget{} -> \case - DynamicTarget{} -> True - _ -> False - StaticTarget x1 a1 b1 -> \case - StaticTarget x2 a2 b2 -> a1 == a2 && b1 == b2 && case ghcPass @p of - GhcPs -> x1 == x2 - GhcRn -> x1 == x2 - GhcTc -> x1 == x2 - _ -> False + (==) = \case + DynamicTarget{} -> \case + DynamicTarget{} -> True + _ -> False + StaticTarget x1 a1 b1 -> \case + StaticTarget x2 a2 b2 -> a1 == a2 && b1 == b2 && case ghcPass @p of + GhcPs -> x1 == x2 + GhcRn -> x1 == x2 + GhcTc -> x1 == x2 + _ -> False instance forall p. IsPass p => NFData (CCallTarget (GhcPass p)) where - rnf = \case - DynamicTarget NoExtField -> () - StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of - GhcPs -> rnf x - GhcRn -> rnf x - GhcTc -> rnf x + rnf = \case + DynamicTarget NoExtField -> () + StaticTarget x a b -> rnf a `seq` rnf b `seq` case ghcPass @p of + GhcPs -> rnf x + GhcRn -> rnf x + GhcTc -> rnf x instance forall p. IsPass p => Binary (CCallTarget (GhcPass p)) where put_ bh = \case @@ -312,16 +399,16 @@ instance Binary CExportSpec where ab <- get bh return (CExportStatic aa ab) -instance Binary CType where - put_ bh (CType s mh fs) = do - put_ bh s - put_ bh mh - put_ bh fs +instance Binary (CType (GhcPass p)) where + put_ bh (CType ext mh fs) = do + put_ bh ext + put_ bh mh + put_ bh fs get bh = do - s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) + ext <- get bh + mh <- get bh + fs <- get bh + return (CType ext mh fs) instance Binary ForeignKind where put_ bh = putByte bh . \case @@ -352,27 +439,30 @@ instance Binary Safety where _ -> return PlayRisky instance Outputable CCallConv where - ppr StdCallConv = text "stdcall" - ppr CCallConv = text "ccall" - ppr CApiConv = text "capi" - ppr PrimCallConv = text "prim" - ppr JavaScriptCallConv = text "javascript" + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" instance Outputable CExportSpec where - ppr (CExportStatic str _) = pprCLabelString str - -instance Outputable CType where - ppr (CType stp mh (stct,ct)) - = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc - <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" - where hDoc = case mh of - Nothing -> empty - Just h -> ppr h + ppr (CExportStatic str _) = pprCLabelString str + +instance Outputable (CType (GhcPass p)) where + ppr (CType ext mh ct) = + pprWithSourceText stp (text "{-# CTYPE") <+> hDoc <+> + pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where + stp = cTypeSourceText ext + stct = cTypeOtherText ext + hDoc = case mh of + Nothing -> empty + Just h -> ppr h instance Outputable Header where ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) instance Outputable Safety where - ppr PlaySafe = text "safe" - ppr PlayInterruptible = text "interruptible" - ppr PlayRisky = text "unsafe" + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -97,9 +97,9 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr import Language.Haskell.Syntax.Basic (LexicalFixity, Role, RuleName, TopLevelFlag) import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Decls.Foreign import Language.Haskell.Syntax.Binds.InlinePragma (Activation) import Language.Haskell.Syntax.Decls.Overlap (OverlapMode) -import Language.Haskell.Syntax.Decls.ForeignCall import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Specificity (Specificity) import Language.Haskell.Syntax.Type @@ -808,7 +808,7 @@ data HsDataDefn pass -- The payload of a data type defn -- @ HsDataDefn { dd_ext :: XCHsDataDefn pass, dd_ctxt :: Maybe (LHsContext pass), -- ^ Context - dd_cType :: Maybe (XRec pass CType), + dd_cType :: Maybe (XRec pass (CType pass)), dd_kindSig:: Maybe (LHsKind pass), -- ^ Optional kind signature. -- ===================================== compiler/Language/Haskell/Syntax/Decls/ForeignCall.hs → compiler/Language/Haskell/Syntax/Decls/Foreign.hs ===================================== @@ -10,26 +10,58 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* --- | Abstract syntax of global declarations. --- --- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, --- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. -module Language.Haskell.Syntax.Decls.ForeignCall ( - -- ** Foreign function interface declarationss - ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), ForeignKind(..), - CCallConv(..), CCallTarget(..), CExportSpec(..), CImportSpec(..), CLabelString, - CType(..), Header(..), Safety(..), - - -- ** Extension - XCExport, - XCImport, - XDynamicTarget, +-- | +-- Abstract syntax of foreign function interface declarations. +module Language.Haskell.Syntax.Decls.Foreign ( + -- * Foreign function interface declarations + -- ** Data-type + ForeignDecl(..), + -- ** Record synonym + LForeignDecl, + + -- * Foreign export types + -- ** Data-type + ForeignExport(..), + -- ** Specification + CExportSpec(..), + + -- * Foreign import types + -- ** Data-type + ForeignImport(..), + -- ** Specification + CImportSpec(..), + -- ** Sub-types + CCallTarget(..), + ForeignKind(..), + Safety(..), + + -- * Foreign binding type + CType(..), + + -- * General sub-types + CLabelString, + CCallConv(..), + Header(..), + + -- * Extension points + -- ** ForeignDecl XForeignExport, XForeignImport, + XXForeignDecl, + -- ** ForeignExport + XCExport, + XXForeignExport, + -- ** ForeignImport + XCImport, + XXForeignImport, + -- ** CCallTarget XStaticTarget, + XDynamicTarget, XXCCallTarget, - XXForeignDecl, - ) where + -- ** CType + XCType, + XXCType, + ) where import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type @@ -193,18 +225,27 @@ data CExportSpec type CLabelString = FastString -- A C label, completely unencoded --- TODO: TTG - -- | A C type, used in CAPI FFI calls -data CType = CType SourceText -- To EXT point - -- ^ See Note [Pragma source text] in "GHC.Types.SourceText" - (Maybe Header) -- header to include for this type - ( SourceText -- TO EXT Point - , FastString) -- the type itself - deriving (Eq, Data) - -instance NFData CType where - rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs +data CType pass + = CType + (XCType pass) + (Maybe Header) -- header to include for this type + FastString + | XCType !(XXCType pass) + +deriving instance {-# OVERLAPPABLE #-} + ( Eq (XCType pass) + , Eq (XXCType pass) + ) => + Eq (CType pass) + +instance {-# OVERLAPPABLE #-} + ( NFData (XCType pass) + , NFData (XXCType pass) + ) => NFData (CType pass) where + rnf = \case + CType ext mh fs -> rnf ext `seq` rnf mh `seq` rnf fs + XCType ext -> rnf ext -- The filename for a C header file -- See Note [Pragma source text] in "GHC.Types.SourceText" ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -387,6 +387,11 @@ type family XStaticTarget x type family XDynamicTarget x type family XXCCallTarget x +-- ------------------------------------- +-- CType type family +type family XCType x +type family XXCType x + -- ------------------------------------- -- ForeignDecl type families type family XForeignImport x ===================================== compiler/ghc.cabal.in ===================================== @@ -1025,8 +1025,8 @@ Library Language.Haskell.Syntax.Binds.InlinePragma Language.Haskell.Syntax.BooleanFormula Language.Haskell.Syntax.Decls + Language.Haskell.Syntax.Decls.Foreign Language.Haskell.Syntax.Decls.Overlap - Language.Haskell.Syntax.Decls.ForeignCall Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension Language.Haskell.Syntax.ImpExp ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -242,6 +242,7 @@ Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Binds.InlinePragma Language.Haskell.Syntax.BooleanFormula Language.Haskell.Syntax.Decls +Language.Haskell.Syntax.Decls.Foreign Language.Haskell.Syntax.Decls.Overlap Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -271,6 +271,7 @@ Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Binds.InlinePragma Language.Haskell.Syntax.BooleanFormula Language.Haskell.Syntax.Decls +Language.Haskell.Syntax.Decls.Foreign Language.Haskell.Syntax.Decls.Overlap Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1901,10 +1901,10 @@ instance ExactPrint (ForeignExport GhcPs) where instance ExactPrint CExportSpec where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (CExportStatic st lbl cconv) = do + exact (CExportStatic lbl cconv) = do debugM $ "CExportStatic starting" cconv' <- markAnnotated cconv - return (CExportStatic st lbl cconv') + return (CExportStatic lbl cconv') -- --------------------------------------------------------------------- @@ -4445,11 +4445,13 @@ exactBang ((o,c,tk), mt) str = do -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP CType) where +instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + let stp = cTypeSourceText ext + stct = cTypeOtherText ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4457,7 +4459,7 @@ instance ExactPrint (LocatedP CType) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct))) + return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -39,6 +39,7 @@ import GHC.Core.TyCon (tyConResKind) import GHC.Driver.DynFlags (getDynFlags) import GHC.Hs.Decls.Overlap (OverlapMode(..)) import GHC.Types.Basic (TupleSort (..)) +import GHC.Types.ForeignCall import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) @@ -674,13 +675,16 @@ renameDataDefn ( HsDataDefn { dd_ext = noExtField , dd_ctxt = lcontext' - , dd_cType = cType + , dd_cType = fmap renameCType <$> cType , dd_kindSig = k' , dd_cons = cons' , dd_derivs = [] } ) +renameCType :: CType GhcRn -> CType DocNameI +renameCType (CType _ y z) = CType NoExtField y z + renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@( ConDeclH98 @@ -830,11 +834,22 @@ renameForD (ForeignExport _ lname ltype x) = do return (ForeignExport noExtField lname' ltype' (renameForE x)) renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI -renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec +renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader (renameForISpec spec) renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI renameForE (CExport _ spec) = CExport noExtField spec +renameForISpec :: CImportSpec GhcRn -> CImportSpec DocNameI +renameForISpec = \case + CLabel str -> CLabel str + CFunction cTarget -> CFunction $ renameCCallTarget cTarget + CWrapper -> CWrapper + +renameCCallTarget :: CCallTarget GhcRn -> CCallTarget DocNameI +renameCCallTarget = \case + DynamicTarget {} -> DynamicTarget NoExtField + StaticTarget _ cStr fKind -> StaticTarget NoExtField cStr fKind + renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD{cid_inst = d}) = do d' <- renameClsInstD d ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -57,6 +57,7 @@ import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt import GHC.Core.InstEnv (is_dfun_name) import GHC.Hs.Decls.Overlap (OverlapMode) +import GHC.Types.ForeignCall (CType) import GHC.Types.Name (stableNameCmp) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName (..)) @@ -831,6 +832,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnL type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = EpAnn AnnPragma type XRecCond a = ( XParTy a ~ (EpToken "(", EpToken ")") @@ -925,6 +927,13 @@ type instance XCExport DocNameI = NoExtField type instance XXForeignImport DocNameI = DataConCantHappen type instance XXForeignExport DocNameI = DataConCantHappen +type instance XStaticTarget DocNameI = NoExtField +type instance XDynamicTarget DocNameI = NoExtField +type instance XXCCallTarget DocNameI = DataConCantHappen + +type instance XCType DocNameI = NoExtField +type instance XXCType DocNameI = DataConCantHappen + type instance XConDeclGADT DocNameI = NoExtField type instance XConDeclH98 DocNameI = NoExtField type instance XXConDecl DocNameI = DataConCantHappen View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf8c77a01fbb260be04cfd3438a276… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf8c77a01fbb260be04cfd3438a276… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/bump_shake
by Andreas Klebinger (＠AndreasK) 06 Feb '26

06 Feb '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/T26878
by Simon Peyton Jones (＠simonpj) 06 Feb '26

06 Feb '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/test_via_hadrian
by Andreas Klebinger (＠AndreasK) 06 Feb '26

06 Feb '26

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

1 0

[Git][ghc/ghc][wip/sol/explicit_namespaces-docs] Edit explicit_namespaces.rst
by Simon Hengel (＠sol) 06 Feb '26

06 Feb '26

Simon Hengel pushed to branch wip/sol/explicit_namespaces-docs at Glasgow Haskell Compiler / GHC Commits: 39574f55 by Simon Hengel at 2026-02-06T06:01:56+00:00 Edit explicit_namespaces.rst - - - - - 1 changed file: - docs/users_guide/exts/explicit_namespaces.rst Changes: ===================================== docs/users_guide/exts/explicit_namespaces.rst ===================================== @@ -86,7 +86,7 @@ However, how would one import only the data constructor? There are two options: import Data.Proxy (data Proxy) -- imports the data constructor only import Data.Proxy (pattern Proxy) -- imports the data constructor only -The `data` keyword allows a data constructor to be imported or exported without its +The ``data`` keyword allows a data constructor to be imported or exported without its parent type constructor. The ``pattern`` keyword does the same, with only a few differences: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39574f55194dbf173df3295514a3121… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39574f55194dbf173df3295514a3121… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/explicit_namespaces-docs] Edit explicit_namespaces.rst
by Simon Hengel (＠sol) 06 Feb '26

06 Feb '26

Simon Hengel pushed to branch wip/sol/explicit_namespaces-docs at Glasgow Haskell Compiler / GHC Commits: 6281208a by Simon Hengel at 2026-02-06T05:59:55+00:00 Edit explicit_namespaces.rst - - - - - 1 changed file: - docs/users_guide/exts/explicit_namespaces.rst Changes: ===================================== docs/users_guide/exts/explicit_namespaces.rst ===================================== @@ -86,7 +86,6 @@ However, how would one import only the data constructor? There are two options: import Data.Proxy (data Proxy) -- imports the data constructor only import Data.Proxy (pattern Proxy) -- imports the data constructor only - The `data` keyword allows a data constructor to be imported or exported without its parent type constructor. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6281208a7bbc8a009a823628df9316c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6281208a7bbc8a009a823628df9316c… You're receiving this email because of your account on gitlab.haskell.org.

1 0