- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/teo/MR12072] Add default QuasiQuoters
by Teo Camarasu (＠teo) 07 Aug '25

07 Aug '25

Teo Camarasu pushed to branch wip/teo/MR12072 at Glasgow Haskell Compiler / GHC Commits: c1dc3b81 by David Feuer at 2025-08-07T20:11:15+01:00 Add default QuasiQuoters Add `defaultQuasiQuoter` and `namedDefaultQuasiQuoter` to make it easier to write `QuasiQuoters` that give helpful error messages when they're used in inappropriate contexts. Closes #24434. - - - - - 4 changed files: - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs ===================================== @@ -26,10 +26,10 @@ import GHC.Internal.Base hiding (Type) -- | The 'QuasiQuoter' type, a value @q@ of this type can be used -- in the syntax @[q| ... string to parse ...|]@. In fact, for -- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters --- to be used in different splice contexts; if you are only interested --- in defining a quasiquoter to be used for expressions, you would --- define a 'QuasiQuoter' with only 'quoteExp', and leave the other --- fields stubbed out with errors. +-- to be used in different splice contexts. In the usual case of a +-- @QuasiQuoter@ that is only intended to be used in certain splice +-- contexts, the unused fields should just 'fail'. This is most easily +-- accomplished using 'namedefaultQuasiQuoter' or 'defaultQuasiQuoter'. data QuasiQuoter = QuasiQuoter { -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@ quoteExp :: String -> Q Exp, ===================================== libraries/template-haskell/Language/Haskell/TH/Quote.hs ===================================== @@ -16,6 +16,8 @@ that is up to you. module Language.Haskell.TH.Quote ( QuasiQuoter(..) , quoteFile + , namedDefaultQuasiQuoter + , defaultQuasiQuoter -- * For backwards compatibility ,dataToQa, dataToExpQ, dataToPatQ ) where @@ -39,3 +41,54 @@ quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec get old_quoter file_name = do { file_cts <- runIO (readFile file_name) ; addDependentFile file_name ; old_quoter file_cts } + +-- | A 'QuasiQuoter' that fails with a helpful error message in every +-- context. It is intended to be modified to create a 'QuasiQuoter' that +-- fails in all inappropriate contexts. +-- +-- For example, you could write +-- +-- @ +-- myPatQQ = (namedDefaultQuasiQuoter "myPatQQ") +-- { quotePat = ... } +-- @ +-- +-- If 'myPatQQ' is used in an expression context, the compiler will report +-- that, naming 'myPatQQ'. +-- +-- See also 'defaultQuasiQuoter', which does not name the 'QuasiQuoter' in +-- the error message, and might therefore be more appropriate when +-- the users of a particular 'QuasiQuoter' tend to define local \"synonyms\" +-- for it. +namedDefaultQuasiQuoter :: String -> QuasiQuoter +namedDefaultQuasiQuoter name = QuasiQuoter + { quoteExp = f "use in expression contexts." + , quotePat = f "use in pattern contexts." + , quoteType = f "use in types." + , quoteDec = f "creating declarations." + } + where + f m _ = fail $ "The " ++ name ++ " quasiquoter is not for " ++ m + +-- | A 'QuasiQuoter' that fails with a helpful error message in every +-- context. It is intended to be modified to create a 'QuasiQuoter' that +-- fails in all inappropriate contexts. +-- +-- For example, you could write +-- +-- @ +-- myExpressionQQ = defaultQuasiQuoter +-- { quoteExp = ... } +-- @ +-- +-- See also 'namedDefaultQuasiQuoter', which names the 'QuasiQuoter' in the +-- error messages. +defaultQuasiQuoter :: QuasiQuoter +defaultQuasiQuoter = QuasiQuoter + { quoteExp = f "use in expression contexts." + , quotePat = f "use in pattern contexts." + , quoteType = f "use in types." + , quoteDec = f "creating declarations." + } + where + f m _ = fail $ "This quasiquoter is not for " ++ m ===================================== libraries/template-haskell/changelog.md ===================================== @@ -1,5 +1,8 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.25.0.0 + * Introduce `namedDefaultQuasiQuoter` and `defaultQuasiQuoter`, which fail with a helpful error when used in an inappropriate context. + ## 2.24.0.0 * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively. ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1370,6 +1370,8 @@ module Language.Haskell.TH.Quote where dataToExpQ :: forall (m :: * -> *) a. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m GHC.Internal.TH.Syntax.Exp)) -> a -> m GHC.Internal.TH.Syntax.Exp dataToPatQ :: forall (m :: * -> *) a. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m GHC.Internal.TH.Syntax.Pat)) -> a -> m GHC.Internal.TH.Syntax.Pat dataToQa :: forall (m :: * -> *) a k q. (GHC.Internal.TH.Syntax.Quote m, GHC.Internal.Data.Data.Data a) => (GHC.Internal.TH.Syntax.Name -> k) -> (GHC.Internal.TH.Syntax.Lit -> m q) -> (k -> [m q] -> m q) -> (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m q)) -> a -> m q + defaultQuasiQuoter :: QuasiQuoter + namedDefaultQuasiQuoter :: GHC.Internal.Base.String -> QuasiQuoter quoteFile :: QuasiQuoter -> QuasiQuoter module Language.Haskell.TH.Syntax where @@ -1720,8 +1722,8 @@ module Language.Haskell.TH.Syntax where qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () qAddModFinalizer :: Q () -> m () qAddCorePlugin :: GHC.Internal.Base.String -> m () - qGetQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) - qPutQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () + qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) + qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () @@ -1802,7 +1804,7 @@ module Language.Haskell.TH.Syntax where falseName :: Name getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) getPackageRoot :: Q GHC.Internal.IO.FilePath - getQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) + getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) get_cons_names :: Con -> [Name] hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool @@ -1849,7 +1851,7 @@ module Language.Haskell.TH.Syntax where oneName :: Name pkgString :: PkgName -> GHC.Internal.Base.String putDoc :: DocLoc -> GHC.Internal.Base.String -> Q () - putQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () + putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () recover :: forall a. Q a -> Q a -> Q a reify :: Name -> Q Info reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1dc3b81815d903969ee6d8129f93a6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1dc3b81815d903969ee6d8129f93a6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/teo/MR12072
by Teo Camarasu (＠teo) 07 Aug '25

07 Aug '25

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

1 0

[Git][ghc/ghc][wip/fix-26109] 5 commits: README: Add note on ghc.nix
by recursion-ninja (＠recursion-ninja) 07 Aug '25

07 Aug '25

recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC Commits: 69cc16ca by Marc Scholten at 2025-08-06T15:51:28-04:00 README: Add note on ghc.nix - - - - - 93a2f450 by Daniel Díaz at 2025-08-06T15:52:14-04:00 Link to the "Strict Bindings" docs from the linear types docs Strict Bidings are relevant for the kinds of multiplicity annotations linear lets support. - - - - - 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 71f622b5 by Recursion Ninja at 2025-08-07T13:14:29-04:00 Resolving issues #20645 and #26109 Correctly sign extending and casting smaller bit width types for LLVM operations: - bitReverse8# - bitReverse16# - bitReverse32# - byteSwap16# - byteSwap32# - pdep8# - pdep16# - pext8# - pext16# - - - - - 26 changed files: - .gitlab/darwin/toolchain.nix - README.md - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Name/Reader.hs - docs/users_guide/exts/linear_types.rst - docs/users_guide/exts/strict.rst - + testsuite/tests/llvm/should_run/T20645.hs - + testsuite/tests/llvm/should_run/T20645.stdout - testsuite/tests/llvm/should_run/all.T - testsuite/tests/numeric/should_run/foundation.hs - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T Changes: ===================================== .gitlab/darwin/toolchain.nix ===================================== @@ -16,18 +16,17 @@ let ghcBindists = let version = ghc.version; in { aarch64-darwin = hostPkgs.fetchurl { url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-aarch64-apple-d…"; - sha256 = "sha256-c1GTMJf3/yiW/t4QL532EswD5JVlgA4getkfsxj4TaA="; + sha256 = "sha256-/6+DtdeossBJIMbjkJwL4h3eJ7rzgNCV+ifoQKOi6AQ="; }; x86_64-darwin = hostPkgs.fetchurl { url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-x86_64-apple-da…"; - sha256 = "sha256-LrYniMG0phsvyW6dhQC+3ompvzcxnwAe6GezEqqzoTQ="; + sha256 = "sha256-jPIhiJMOENesUnDUJeIaPatgavc6ZVSTY5NFIAxlC+k="; }; }; ghc = pkgs.stdenv.mkDerivation rec { - # Using 9.6.2 because of #24050 - version = "9.6.2"; + version = "9.10.1"; name = "ghc"; src = ghcBindists.${pkgs.stdenv.hostPlatform.system}; configureFlags = [ ===================================== README.md ===================================== @@ -81,6 +81,10 @@ These steps give you the default build, which includes everything optimised and built in various ways (eg. profiling libs are built). It can take a long time. To customise the build, see the file `HACKING.md`. +## Nix + +If you are looking to use nix to develop on GHC, [check out the wiki for instructions](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparati…. + Filing bugs and feature requests ================================ ===================================== compiler/GHC/CmmToLlvm/CodeGen.hs ===================================== @@ -230,23 +230,25 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args - -genCall t@(PrimTarget (MO_Pdep w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Pext w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BRev w)) dsts args = - genCallSimpleCast w t dsts args +-- Handle PopCnt, Clz, Ctz, BRev, and BSwap that need to only convert arg and return types +genCall (PrimTarget op@(MO_PopCnt w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Clz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Ctz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BRev w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BSwap w)) [dst] args = + genCallSimpleCast w op dst args + +-- Handle Pdep and Pext that (may) require using a type with a larger bit-width +-- than the specified but width. This register width-extension is particualarly +-- necessary for W8 and W16. +genCall (PrimTarget op@(MO_Pdep w)) [dst] args = + genCallCastWithMinWidthOf W32 w op dst args +genCall (PrimTarget op@(MO_Pext w)) [dst] args = + genCallCastWithMinWidthOf W32 w op dst args genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -640,63 +642,35 @@ genCallExtract _ _ _ _ = -- since GHC only really has i32 and i64 types and things like Word8 are backed -- by an i32 and just present a logical i8 range. So we must handle conversions -- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] - - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV Nothing [] - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 +genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w = genCallCastWithMinWidthOf w w + +-- Handle extension case that the element should be extend to a larger bit-width +-- for the operation and subsequently truncated, of the form: +-- extend arg >>= \a -> call(a) >>= truncate +genCallCastWithMinWidthOf :: Width -> Width -> CallishMachOp -> CmmFormal + -> [CmmActual] -> LlvmM StmtData +genCallCastWithMinWidthOf minW specW op dst args = do + let width = widthToLlvmInt $ max minW specW + argsW = const width <$> args + dstType = cmmToLlvmType $ localRegType dst + signage = cmmPrimOpRetValSignage op + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width argsW + (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) + let (_, arg_hints) = foreignTargetHints $ PrimTarget op + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars signage $ zip argsV argsW + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retV', stmts5) <- castVar signage retV dstType + let s2 = Store retV' dstV Nothing [] + + let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `snocOL` + stmts5 `snocOL` s2 return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") - --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - - (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV Nothing [] - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast2 _ _ dsts _ = - panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget @@ -811,11 +785,42 @@ castVar signage v t | getVarType v == t Signed -> LM_Sext Unsigned -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of + -- If the result of a Bit-Reverse is treated as signed, + -- an positive input can result in an negative output, i.e.: + -- + -- identity(0x03) = 0x03 = 00000011 + -- breverse(0x03) = 0xC0 = 11000000 + -- + -- Now if an extension is performed after the operation to + -- promote a smaller bit-width value into a larger bit-width + -- type, it is expected that the /bit-wise/ operations will + -- not be treated /numerically/ as signed. + -- + -- To illustrate the difference, consider how a signed extension + -- for the type i16 to i32 differs for out values above: + -- ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000 + -- ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000 + -- + -- Here we can see that the former output is the expected result + -- of a bit-wise operation which needs to be promoted to a larger + -- bit-width type. The latter output is not desirable when we must + -- constraining a value into a range of i16 within an i32 type. + -- + -- Hence we always treat the "signage" as unsigned for Bit-Reverse! + MO_BRev _ -> Unsigned + + -- The same reasoning applied to Bit-Reverse above applies to ther other + -- bit-wise operations; do not sign extend a possibly negated number! + MO_BSwap _ -> Unsigned + MO_Clz _ -> Unsigned + MO_Ctz _ -> Unsigned MO_Pdep _ -> Unsigned MO_Pext _ -> Unsigned + MO_PopCnt _ -> Unsigned + + -- All other cases, default to preserving the numeric sign when extending. _ -> Signed -- | Decide what C function to use to implement a CallishMachOp @@ -954,8 +959,25 @@ cmmPrimOpFunctions mop = do W256 -> fsLit "llvm.x86.bmi.pdep.256" W512 -> fsLit "llvm.x86.bmi.pdep.512" | otherwise -> case w of - W8 -> fsLit "hs_pdep8" - W16 -> fsLit "hs_pdep16" + -- Due to the down-casting and up-casting of the operand before and + -- after the Pdep operation, respectively, LLVM will provide a an + -- incorrect result after the entire operation is complete. + -- This is caused by the definition of hs_pdep64 in "cbits/pdep.c". + -- The defined C operation takes a (64-bit) 'StgWord64' as input/output. + -- The result will incorrectly consider upper bits when it should not + -- because those upper bits are outside the value's "logical range," + -- despite being present in the "actual range." + -- The function "hs_pdep32" works correctly for the type 'StgWord' + -- as input/output for the logical range of "i32." Attempting to use a + -- smaller logical range of "i16" or "i8" will produce incorrect results. + -- Hence, the call is made to "hs_pdep32" and truncated afterwards. + -- + -- TODO: Determine if the definition(s) of "hs_pdep8" and "hs_pdep16" + -- can be specialized to return the correct results when cast using + -- a call to 'genCallSimpleCast', removing the need for the function + -- 'genCallCastWithMinWidthOf'. + W8 -> fsLit "hs_pdep32" + W16 -> fsLit "hs_pdep32" W32 -> fsLit "hs_pdep32" W64 -> fsLit "hs_pdep64" W128 -> fsLit "hs_pdep128" @@ -971,8 +993,11 @@ cmmPrimOpFunctions mop = do W256 -> fsLit "llvm.x86.bmi.pext.256" W512 -> fsLit "llvm.x86.bmi.pext.512" | otherwise -> case w of - W8 -> fsLit "hs_pext8" - W16 -> fsLit "hs_pext16" + -- Same issue for "i16" and "i8" values as the Pdep operation above, + -- see that commentary for more details as to why "hs_pext32" is called + -- for bit-widths of 'W8' and 'W16'. + W8 -> fsLit "hs_pext32" + W16 -> fsLit "hs_pext32" W32 -> fsLit "hs_pext32" W64 -> fsLit "hs_pext64" W128 -> fsLit "hs_pext128" ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Module.Warnings @@ -312,7 +313,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod ; addDiagnostic (TcRnMissingExportList $ moduleName _this_mod) ; let avails = - map fix_faminst . gresToAvailInfo + map fix_faminst . gresToAvailInfo . mapMaybe pickLevelZeroGRE . filter isLocalGRE . globalRdrEnvElts $ rdr_env ; return (Nothing, emptyDefaultEnv, avails, []) } where @@ -384,6 +385,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do { let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + -- NB: this filters out non level 0 exports ; new_gres = [ gre' | (gre, _) <- gre_prs , gre' <- expand_tyty_gre gre ] @@ -451,6 +453,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod let avail = availFromGRE gre name = greName gre + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie [gre] (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -499,6 +502,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs occs ie [gre] return (Just avail, occs', exp_dflts) + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans dont_warn_export @@ -526,6 +530,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -563,6 +568,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -589,17 +595,19 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt -> RnM [GlobalRdrElt] - lookup_ie_kids_all ie (L _ rdr) gre = + lookup_ie_kids_all ie (L _loc rdr) gre = do { let name = greName gre gres = findChildren kids_env name - ; addUsedKids (ieWrappedName rdr) gres - ; when (null gres) $ + -- We only choose level 0 exports when filling in part of an export list implicitly. + ; let kids_0 = mapMaybe pickLevelZeroGRE gres + ; addUsedKids (ieWrappedName rdr) kids_0 + ; when (null kids_0) $ if isTyConName name then addTcRnDiagnostic (TcRnDodgyExports gre) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (TcRnExportHiddenComponents ie) - ; return gres } + ; return kids_0 } ------------- @@ -696,6 +704,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod addUsedKids parent_rdr kid_gres = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) + +ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn +ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l + -- | In what namespaces should we go looking for an import/export item -- that is out of scope, for suggestions in error messages? ieWrappedNameWhatLooking :: IEWrappedName GhcPs -> WhatLooking @@ -800,6 +812,7 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) ; return (replaceLWrappedName n child_nm, child) } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -69,7 +69,7 @@ module GHC.Types.Name.Reader ( lookupGRE_Name, lookupGRE_FieldLabel, getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, + transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE, -- * GlobalRdrElts availFromGRE, @@ -144,7 +144,7 @@ import GHC.Utils.Panic import GHC.Utils.Binary import Control.DeepSeq -import Control.Monad ( guard ) +import Control.Monad ( guard , (>=>) ) import Data.Data import Data.List ( sort ) import qualified Data.List.NonEmpty as NE @@ -641,7 +641,7 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -greLevels :: GlobalRdrElt -> Set.Set ImportLevel +greLevels :: GlobalRdrEltX info -> Set.Set ImportLevel greLevels g = if gre_lcl g then Set.singleton NormalLevel else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g))) @@ -1604,7 +1604,14 @@ pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,Glo -- -- Used only for the 'module M' item in export list; -- see 'GHC.Tc.Gen.Export.exports_from_avail' -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- This function also only chooses GREs which are at level zero. +pickGREsModExp mod gres = mapMaybe (pickLevelZeroGRE >=> pickBothGRE mod) gres + +pickLevelZeroGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickLevelZeroGRE gre = + if NormalLevel `Set.member` greLevels gre + then Just gre + else Nothing -- | isBuiltInSyntax filter out names for built-in syntax They -- just clutter up the environment (esp tuples), and the ===================================== docs/users_guide/exts/linear_types.rst ===================================== @@ -213,6 +213,8 @@ With ``-XStrict``:: -- inferred unrestricted let ~(x, y) = u in … +(See :ref:`strict-bindings`). + Data types ---------- By default, all fields in algebraic data types are linear (even if ===================================== docs/users_guide/exts/strict.rst ===================================== @@ -103,6 +103,9 @@ Note the following points: See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-w…>`__ for the precise rules. + +.. _strict-bindings: + Strict bindings ~~~~~~~~~~~~~~~ ===================================== testsuite/tests/llvm/should_run/T20645.hs ===================================== @@ -0,0 +1,17 @@ +-- Minimal reproducer for https://gitlab.haskell.org/ghc/ghc/-/issues/20645 +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ExtendedLiterals #-} +import GHC.Exts +import GHC.Word +import Numeric (showHex) + +opaqueInt8# :: Int8# -> Int8# +opaqueInt8# x = x +{-# OPAQUE opaqueInt8# #-} + +main :: IO () +main = let !x = opaqueInt8# 109#Int8 + !y = opaqueInt8# 1#Int8 + in putStrLn . flip showHex "" . W# $ pext8# + (word8ToWord# (int8ToWord8# (0#Int8 `subInt8#` x ))) + (word8ToWord# (int8ToWord8# (y `subInt8#` 4#Int8))) ===================================== testsuite/tests/llvm/should_run/T20645.stdout ===================================== @@ -0,0 +1 @@ +49 ===================================== testsuite/tests/llvm/should_run/all.T ===================================== @@ -17,3 +17,4 @@ test('T22487', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_a test('T22033', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['']) test('T25730', [req_c, unless(arch('x86_64'), skip), normalise_errmsg_fun(ignore_llvm_and_vortex)], compile_and_run, ['T25730C.c']) # T25730C.c contains Intel instrinsics, so only run this test on x86 +test('T20645', [normal, normalise_errmsg_fun(ignore_llvm_and_vortex), when(have_llvm(), extra_ways(["optllvm"]))], compile_and_run, ['']) ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -24,6 +24,7 @@ module Main ( main ) where +import Data.Bits (Bits((.&.), bit)) import Data.Word import Data.Int import GHC.Natural @@ -655,8 +656,8 @@ testPrimops = Group "primop" , testPrimop "ctz32#" Primop.ctz32# Wrapper.ctz32# , testPrimop "ctz64#" Primop.ctz64# Wrapper.ctz64# , testPrimop "ctz#" Primop.ctz# Wrapper.ctz# - , testPrimop "byteSwap16#" Primop.byteSwap16# Wrapper.byteSwap16# - , testPrimop "byteSwap32#" Primop.byteSwap32# Wrapper.byteSwap32# + , testPrimop "byteSwap16#" (16 `LowerBitsAreDefined` Primop.byteSwap16#) (16 `LowerBitsAreDefined` Wrapper.byteSwap16#) + , testPrimop "byteSwap32#" (32 `LowerBitsAreDefined` Primop.byteSwap32#) (32 `LowerBitsAreDefined` Wrapper.byteSwap32#) , testPrimop "byteSwap64#" Primop.byteSwap64# Wrapper.byteSwap64# , testPrimop "byteSwap#" Primop.byteSwap# Wrapper.byteSwap# , testPrimop "bitReverse8#" Primop.bitReverse8# Wrapper.bitReverse8# @@ -672,6 +673,34 @@ testPrimops = Group "primop" , testPrimop "narrow32Word#" Primop.narrow32Word# Wrapper.narrow32Word# ] +-- | A special data-type for representing functions where, +-- since only some number of the lower bits are defined, +-- testing for strict equality in the undefined upper bits is not appropriate! +-- Without using this data-type, false-positive failures will be reported +-- when the undefined bit regions do not match, even though the equality of bits +-- in this undefined region has no bearing on correctness. +data LowerBitsAreDefined = + LowerBitsAreDefined + { definedLowerWidth :: Word + -- ^ The (strictly-non-negative) number of least-significant bits + -- for which the attached function is defined. + , undefinedBehavior :: (Word# -> Word#) + -- ^ Function with undefined behavior for some of its most significant bits. + } + +instance TestPrimop LowerBitsAreDefined where + testPrimop s l r = Property s $ \ (uWord#-> x0) -> + let -- Create a mask to unset all bits in the undefined area, + -- leaving set bits only in the area of defined behavior. + -- Since the upper bits are undefined, + -- if the function defines behavior for the lower N bits, + -- then /only/ the lower N bits are preserved, + -- and the upper WORDSIZE - N bits are discarded. + mask = bit (fromEnum (definedLowerWidth r)) - 1 + valL = wWord# (undefinedBehavior l x0) .&. mask + valR = wWord# (undefinedBehavior r x0) .&. mask + in valL === valR + instance TestPrimop (Char# -> Char# -> Int#) where testPrimop s l r = Property s $ \ (uChar#-> x0) (uChar#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) ===================================== testsuite/tests/splice-imports/DodgyLevelExport.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module DodgyLevelExport ( T(..) ) where + +import quote DodgyLevelExportA +import DodgyLevelExportA (T) ===================================== testsuite/tests/splice-imports/DodgyLevelExport.stderr ===================================== @@ -0,0 +1,4 @@ +DodgyLevelExport.hs:2:27: warning: [GHC-75356] [-Wdodgy-exports (in -Wextra)] + The export item ‘T(..)’ suggests that + ‘T’ has (in-scope) constructors or record fields, but it has none + ===================================== testsuite/tests/splice-imports/DodgyLevelExportA.hs ===================================== @@ -0,0 +1,3 @@ +module DodgyLevelExportA where + +data T = T { a :: Int } ===================================== testsuite/tests/splice-imports/LevelImportExports.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module LevelImportExports ( module LevelImportExportsA, T(..) ) where + +import quote LevelImportExportsA +import splice LevelImportExportsA +import LevelImportExportsA(a, T) ===================================== testsuite/tests/splice-imports/LevelImportExports.stdout ===================================== @@ -0,0 +1,6 @@ +[1 of 2] Compiling LevelImportExportsA ( LevelImportExportsA.hs, LevelImportExportsA.o ) +[2 of 2] Compiling LevelImportExports ( LevelImportExports.hs, LevelImportExports.o ) +exports: + LevelImportExportsA.a + LevelImportExportsA.T +defaults: ===================================== testsuite/tests/splice-imports/LevelImportExportsA.hs ===================================== @@ -0,0 +1,6 @@ +module LevelImportExportsA where + +a = 100 +b = 100 + +data T = T { c :: Int } ===================================== testsuite/tests/splice-imports/Makefile ===================================== @@ -24,5 +24,9 @@ SI10_oneshot: "$(TEST_HC)" $(TEST_HC_OPTS) -c InstanceA.hs "$(TEST_HC)" $(TEST_HC_OPTS) -c SI10.hs +LevelImportExports: + "$(TEST_HC)" $(TEST_HC_OPTS) -haddock LevelImportExports.hs + "$(TEST_HC)" --show-iface LevelImportExports.hi | grep -A3 "^exports:" + clean: rm -f *.o *.hi ===================================== testsuite/tests/splice-imports/ModuleExport.hs ===================================== @@ -0,0 +1,4 @@ +module ModuleExport where + +-- Should fail +import ModuleExportA (a) ===================================== testsuite/tests/splice-imports/ModuleExport.stderr ===================================== @@ -0,0 +1,3 @@ +ModuleExport.hs:4:23: error: [GHC-61689] + Module ‘ModuleExportA’ does not export ‘a’. + ===================================== testsuite/tests/splice-imports/ModuleExportA.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitLevelImports #-} +-- Module export only exports level 0 things (b) +module ModuleExportA (module ModuleExportB) where + +-- Everything at level 1 +import quote ModuleExportB +-- Only b at level 0 +import ModuleExportB (b) ===================================== testsuite/tests/splice-imports/ModuleExportB.hs ===================================== @@ -0,0 +1,6 @@ +module ModuleExportB where + +a = () +b = () + + ===================================== testsuite/tests/splice-imports/T26090.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26090 ( a --varaible + , T(..) -- WithAll + , S(s) -- With + , R -- Abs + ) where + +import quote T26090A +import T26090A (T(T), S) + ===================================== testsuite/tests/splice-imports/T26090.stderr ===================================== @@ -0,0 +1,16 @@ +T26090.hs:2:17: error: [GHC-28914] + • Level error: ‘a’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + +T26090.hs:4:17: error: [GHC-28914] + • Level error: ‘s’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + • In the export: S(s) + +T26090.hs:5:17: error: [GHC-28914] + • Level error: ‘R’ is bound at level 1 but used at level 0 + • Available from the imports: + • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20 + ===================================== testsuite/tests/splice-imports/T26090A.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26090A where + +import Language.Haskell.TH + +a :: Q Exp +a = [| True |] + +data T = T { t :: () } + +data S = S { s :: () } + +data R = R { r :: () } + ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -48,3 +48,7 @@ test('SI35', test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0']) test('T26087', [], multimod_compile_fail, ['T26087A', '']) test('T26088', [], multimod_compile_fail, ['T26088A', '-v0']) +test('T26090', [], multimod_compile_fail, ['T26090', '-v0']) +test('ModuleExport', [], multimod_compile_fail, ['ModuleExport', '-v0']) +test('LevelImportExports', [], makefile_test, []) +test('DodgyLevelExport', [], multimod_compile, ['DodgyLevelExport', '-v0 -Wdodgy-exports']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9fbadea8fb900c08c812a29716c3c4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9fbadea8fb900c08c812a29716c3c4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: level imports: Check the level of exported identifiers
by Marge Bot (＠marge-bot) 07 Aug '25

07 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 1903ae35 by Matthew Pickering at 2025-08-07T12:21:10+01:00 ipe: Place strings and metadata into specific .ipe section By placing the .ipe metadata into a specific section it can be stripped from the final binary if desired. ``` objcopy --remove-section .ipe <binary> upx <binary> ``` Towards #21766 - - - - - c80dd91c by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Place magic word at the start of entries in the .ipe section The magic word "IPE\nIPE\n" is placed at the start of .ipe sections, then if the section is stripped, we can check whether the section starts with the magic word or not to determine whether there is metadata present or not. Towards #21766 - - - - - cab42666 by Matthew Pickering at 2025-08-07T12:22:42+01:00 ipe: Use stable IDs for IPE entries IPEs have historically been indexed and reported by their address. This makes it impossible to compare profiles between runs, since the addresses may change (due to ASLR) and also makes it tricky to separate out the IPE map from the binary. This small patch adds a stable identifier for each IPE entry. The stable identifier is a single 64 bit word. The high-bits are a per-module identifier and the low bits identify which entry in each module. 1. When a node is added into the IPE buffer it is assigned a unique identifier from an incrementing global counter. 2. Each entry already has an index by it's position in the `IpeBufferListNode`. The two are combined together by the `IPE_ENTRY_KEY` macro. Info table profiling uses the stable identifier rather than the address of the info table. The benefits of this change are: * Profiles from different runs can be easily compared * The metadata can be extracted from the binary (via the eventlog for example) and then stripped from the executable. Fixes #21766 - - - - - c7cf0aa9 by Simon Peyton Jones at 2025-08-07T13:08:08-04:00 In TcSShortCut, typechecker plugins should get empty Givens Solving in TcShortCut mode means /ignoring the Givens/. So we should not pass them to typechecker plugins! Fixes #26258. This is a fixup to the earlier MR: commit 1bd12371feacc52394a0e660ef9349f9e8ee1c06 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jul 21 10:04:49 2025 +0100 Improve treatment of SPECIALISE pragmas -- again! - - - - - 33 changed files: - .gitlab/darwin/toolchain.nix - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Types/Name/Reader.hs - docs/users_guide/debug-info.rst - rts/IPE.c - rts/ProfHeap.c - rts/eventlog/EventLog.c - rts/include/rts/IPE.h - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9988a24115d302ebaa29e6e9a75ab3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9988a24115d302ebaa29e6e9a75ab3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] Wibbles to fundeps [skip ci]
by Simon Peyton Jones (＠simonpj) 07 Aug '25

07 Aug '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: a381c3c4 by Simon Peyton Jones at 2025-08-07T17:32:31+01:00 Wibbles to fundeps [skip ci] - - - - - 5 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - testsuite/tests/typecheck/should_fail/tcfail143.stderr Changes: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -648,69 +648,6 @@ on whether we apply this optimization when IncoherentInstances is in effect: The output of `main` if we avoid the optimization under the effect of IncoherentInstances is `1`. If we were to do the optimization, the output of `main` would be `2`. - - -Note [No Given/Given fundeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not create constraints from: -* Given/Given interactions via functional dependencies or type family - injectivity annotations. -* Given/instance fundep interactions via functional dependencies or - type family injectivity annotations. - -In this Note, all these interactions are called just "fundeps". - -We ingore such fundeps for several reasons: - -1. These fundeps will never serve a purpose in accepting more - programs: Given constraints do not contain metavariables that could - be unified via exploring fundeps. They *could* be useful in - discovering inaccessible code. However, the constraints will be - Wanteds, and as such will cause errors (not just warnings) if they - go unsolved. Maybe there is a clever way to get the right - inaccessible code warnings, but the path forward is far from - clear. #12466 has further commentary. - -2. Furthermore, here is a case where a Given/instance interaction is actively - harmful (from dependent/should_compile/RaeJobTalk): - - type family a == b :: Bool - type family Not a = r | r -> a where - Not False = True - Not True = False - - [G] Not (a == b) ~ True - - Reacting this Given with the equations for Not produces - - [W] a == b ~ False - - This is indeed a true consequence, and would make sense as a fresh Given. - But we don't have a way to produce evidence for fundeps, as a Wanted it - is /harmful/: we can't prove it, and so we'll report an error and reject - the program. (Previously fundeps gave rise to Deriveds, which - carried no evidence, so it didn't matter that they could not be proved.) - -3. #20922 showed a subtle different problem with Given/instance fundeps. - type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where - ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss - ... - - tclevel = 4 - [G] ZipCons is1 iss ~ (i : is2) : jss - - (The tclevel=4 means that this Given is at level 4.) The fundep tells us that - 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification - variable; we don't know what type it stands for. So we would emit - [W] iss ~ is2 : beta - - Again we can't prove that equality; and worse we'll rewrite iss to - (is2:beta) in deeply nested constraints inside this implication, - where beta is untouchable (under other equality constraints), leading - to other insoluble constraints. - -The bottom line: since we have no evidence for them, we should ignore Given/Given -and Given/instance fundeps entirely. -} tryInertDicts :: DictCt -> SolverStage () ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -313,7 +313,13 @@ doDictFunDepImprovement dict_ct doDictFunDepImprovementLocal :: DictCt -> SolverStage () -- Using functional dependencies, interact the DictCt with the -- inert Givens and Wanteds, to produce new equalities -doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev }) +doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) + | isGiven work_ev + = -- If work_ev is Given, there could in principle be some inert Wanteds + -- but in practice there never are because we solve Givens first + nopStage () + + | otherwise = Stage $ do { inerts <- getInertCans @@ -324,35 +330,44 @@ doDictFunDepImprovementLocal dict_ct@(DictCt { di_cls = cls, di_ev = wanted_ev } ; if imp then startAgainWith (CDictCan dict_ct) else continueWith () } where - wanted_pred = ctEvPred wanted_ev - wanted_loc = ctEvLoc wanted_ev + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + work_is_given = isGiven work_ev do_interaction :: Cts -> DictCt -> TcS Cts - do_interaction new_eqs1 (DictCt { di_ev = all_ev }) -- This can be Given or Wanted + do_interaction new_eqs1 (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted + | work_is_given && isGiven inert_ev + -- Do not create FDs from Given/Given interactions + -- See Note [No Given/Given fundeps] + -- It is possible for work_ev to be Given when inert_ev is Wanted: + -- this can happen if a Given is kicked out by a unification + = return new_eqs1 + + | otherwise = do { traceTcS "doLocalFunDepImprovement" $ - vcat [ ppr wanted_ev - , pprCtLoc wanted_loc, ppr (isGivenLoc wanted_loc) - , pprCtLoc all_loc, ppr (isGivenLoc all_loc) + vcat [ ppr work_ev + , pprCtLoc work_loc, ppr (isGivenLoc work_loc) + , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) , pprCtLoc deriv_loc, ppr (isGivenLoc deriv_loc) ] - ; new_eqs2 <- unifyFunDepWanteds_new wanted_ev $ - improveFromAnother (deriv_loc, all_rewriters) - all_pred wanted_pred + ; new_eqs2 <- unifyFunDepWanteds_new work_ev $ + improveFromAnother (deriv_loc, inert_rewriters) + inert_pred work_pred ; return (new_eqs1 `unionBags` new_eqs2) } where - all_pred = ctEvPred all_ev - all_loc = ctEvLoc all_ev - all_rewriters = ctEvRewriters all_ev - deriv_loc = wanted_loc { ctl_depth = deriv_depth + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + deriv_loc = work_loc { ctl_depth = deriv_depth , ctl_origin = deriv_origin } - deriv_depth = ctl_depth wanted_loc `maxSubGoalDepth` - ctl_depth all_loc - deriv_origin = FunDepOrigin1 wanted_pred - (ctLocOrigin wanted_loc) - (ctLocSpan wanted_loc) - all_pred - (ctLocOrigin all_loc) - (ctLocSpan all_loc) + deriv_depth = ctl_depth work_loc `maxSubGoalDepth` + ctl_depth inert_loc + deriv_origin = FunDepOrigin1 work_pred + (ctLocOrigin work_loc) + (ctLocSpan work_loc) + inert_pred + (ctLocOrigin inert_loc) + (ctLocSpan inert_loc) doDictFunDepImprovementTop :: DictCt -> SolverStage () doDictFunDepImprovementTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) @@ -389,6 +404,69 @@ solveFunDeps generate_eqs do { eqs <- generate_eqs ; solveSimpleWanteds eqs } +{- Note [No Given/Given fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not create constraints from: +* Given/Given interactions via functional dependencies or type family + injectivity annotations. +* Given/instance fundep interactions via functional dependencies or + type family injectivity annotations. + +In this Note, all these interactions are called just "fundeps". + +We ingore such fundeps for several reasons: + +1. These fundeps will never serve a purpose in accepting more + programs: Given constraints do not contain metavariables that could + be unified via exploring fundeps. They *could* be useful in + discovering inaccessible code. However, the constraints will be + Wanteds, and as such will cause errors (not just warnings) if they + go unsolved. Maybe there is a clever way to get the right + inaccessible code warnings, but the path forward is far from + clear. #12466 has further commentary. + +2. Furthermore, here is a case where a Given/instance interaction is actively + harmful (from dependent/should_compile/RaeJobTalk): + + type family a == b :: Bool + type family Not a = r | r -> a where + Not False = True + Not True = False + + [G] Not (a == b) ~ True + + Reacting this Given with the equations for Not produces + + [W] a == b ~ False + + This is indeed a true consequence, and would make sense as a fresh Given. + But we don't have a way to produce evidence for fundeps, as a Wanted it + is /harmful/: we can't prove it, and so we'll report an error and reject + the program. (Previously fundeps gave rise to Deriveds, which + carried no evidence, so it didn't matter that they could not be proved.) + +3. #20922 showed a subtle different problem with Given/instance fundeps. + type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + ... + + tclevel = 4 + [G] ZipCons is1 iss ~ (i : is2) : jss + + (The tclevel=4 means that this Given is at level 4.) The fundep tells us that + 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification + variable; we don't know what type it stands for. So we would emit + [W] iss ~ is2 : beta + + Again we can't prove that equality; and worse we'll rewrite iss to + (is2:beta) in deeply nested constraints inside this implication, + where beta is untouchable (under other equality constraints), leading + to other insoluble constraints. + +The bottom line: since we have no evidence for them, we should ignore Given/Given +and Given/instance fundeps entirely. +-} + {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1298,21 +1298,25 @@ nestFunDepsTcS (TcS thing_inside) , tcs_worklist = new_wl_var , tcs_unif_lvl = new_unif_lvl_var } + ; TcM.traceTc "nestFunDepsTcS {" empty ; (inner_lvl, _res) <- TcM.pushTcLevelM $ thing_inside nest_env + -- Increase the level so that unification variables allocated by + -- the fundep-creation itself don't count as useful unifications + ; TcM.traceTc "nestFunDepsTcS }" empty -- Figure out whether the fundeps did any useful unifications, -- and if so update the tcs_unif_lvl ; mb_new_lvl <- TcM.readTcRef new_unif_lvl_var ; case mb_new_lvl of - Just new_lvl - | inner_lvl `deeperThanOrSame` new_lvl + Just unif_lvl + | inner_lvl `deeperThanOrSame` unif_lvl -> -- Some useful unifications took place do { mb_old_lvl <- TcM.readTcRef unif_lvl_var ; case mb_old_lvl of - Just old_lvl | new_lvl `deeperThanOrSame` old_lvl + Just old_lvl | unif_lvl `deeperThanOrSame` old_lvl -> return () - _ -> TcM.writeTcRef unif_lvl_var (Just new_lvl) + _ -> TcM.writeTcRef unif_lvl_var (Just unif_lvl) ; return True } _ -> return False -- No unifications (except of vars ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -126,7 +126,7 @@ simplify_loop n limit definitely_redo_implications -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet ; wc2 <- if not definitely_redo_implications -- See Note [Superclass iteration] - && n_unifs1 == 0 -- for this conditional + && n_unifs1 == 0 -- for this conditional then return (wc { wc_simple = simples1 }) -- Short cut else do { implics1 <- solveNestedImplications implics ; return (wc { wc_simple = simples1 ===================================== testsuite/tests/typecheck/should_fail/tcfail143.stderr ===================================== @@ -1,8 +1,6 @@ - -tcfail143.hs:30:9: error: [GHC-18872] - • Couldn't match type ‘S Z’ with ‘Z’ - arising from a functional dependency between: - constraint ‘MinMax (S Z) Z Z Z’ arising from a use of ‘extend’ - instance ‘MinMax a Z Z a’ at tcfail143.hs:12:10-23 +tcfail143.hs:30:9: error: [GHC-39999] + • No instance for ‘MinMax (S Z) Z Z Z’ + arising from a use of ‘extend’ • In the expression: n1 `extend` n0 In an equation for ‘t2’: t2 = n1 `extend` n0 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a381c3c47e7b7784f66b6cc82a12a5c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a381c3c47e7b7784f66b6cc82a12a5c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/9.10.3-backports] Revert "configure: Drop probing of ld.gold"
by Zubin (＠wz1000) 07 Aug '25

07 Aug '25

Zubin pushed to branch wip/9.10.3-backports at Glasgow Haskell Compiler / GHC Commits: d7d323b0 by Zubin Duggal at 2025-08-07T21:21:46+05:30 Revert "configure: Drop probing of ld.gold" This reverts commit cf1f18c33397167769397d7d478c6ba3bd78f69a. - - - - - 2 changed files: - m4/find_ld.m4 - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs Changes: ===================================== m4/find_ld.m4 ===================================== @@ -21,7 +21,14 @@ AC_DEFUN([FIND_LD],[ return fi - linkers="ld.lld ld" + case $CPU in + i386) + # We refuse to use ld.gold on i386 due to #23579, which we don't + # have a good autoconf check for. + linkers="ld.lld ld" ;; + *) + linkers="ld.lld ld.gold ld" ;; + esac # Manually iterate over possible names since we want to ensure that, e.g., # if ld.lld is installed but gcc doesn't support -fuse-ld=lld, that we ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -91,7 +91,7 @@ findLinkFlags enableOverride cc ccLink -- executable exists before trying cc. do _ <- findProgram (linker ++ " linker") emptyProgOpt ["ld."++linker] prog <$ checkLinkWorks cc prog - | linker <- ["lld", "bfd"] + | linker <- ["lld", "gold"] , let prog = over _prgFlags (++["-fuse-ld="++linker]) ccLink ] <|> (ccLink <$ checkLinkWorks cc ccLink) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7d323b0fb0805f3ebc10c91a9d858d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d7d323b0fb0805f3ebc10c91a9d858d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ccs-index-table] Implement IndexTable as a HashTable
by Hannes Siebenhandl (＠fendor) 07 Aug '25

07 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/ccs-index-table at Glasgow Haskell Compiler / GHC Commits: ea1fcd3e by fendor at 2025-08-07T16:04:27+02:00 Implement IndexTable as a HashTable Instead of using a linked list, which is very expensive to search, we use the hashtable implementation. We extract a proper interface for the `IndexTable` to make the internal implementation opaque to the rest of the rts. For convenient traversal, we implement iterators for the hash table and the IndexTable respectively. The iterators provide the following interface: * next: modifies the internal state of the iterator to contain the next element. Returns 1 if no more elements can be found, and 0 otherwise Adds a performance regression test. TODO: * [ ]: Sorting of CCS * [ ]: Pruning of CCS * [ ]: ghc-heap decoder - - - - - 17 changed files: - libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc - rts/FileLock.c - rts/Hash.c - rts/Hash.h - + rts/IndexTable.c - rts/ProfilerReport.c - rts/ProfilerReportJson.c - rts/Profiling.c - rts/Profiling.h - rts/StaticPtrTable.c - rts/include/Rts.h - rts/include/rts/prof/CCS.h - + rts/include/rts/prof/IndexTable.h - rts/rts.cabal - testsuite/tests/perf/should_run/T26147.stdout - testsuite/tests/perf/should_run/all.T - testsuite/tests/perf/should_run/genT26147 Changes: ===================================== libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc ===================================== @@ -138,21 +138,21 @@ peekCostCentre costCenterCacheRef ptr = do peekIndexTable :: AddressSet -> IORef (AddressMap CostCentre) -> Ptr indexTable -> IO (Maybe IndexTable) peekIndexTable _ _ ptr | ptr == nullPtr = return Nothing -peekIndexTable loopBreakers costCenterCacheRef ptr = do - it_cc_ptr <- (#peek struct IndexTable_, cc) ptr - it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr - it_ccs_ptr <- (#peek struct IndexTable_, ccs) ptr - it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr - it_next_ptr <- (#peek struct IndexTable_, next) ptr - it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr - it_back_edge' <- (#peek struct IndexTable_, back_edge) ptr - - return $ Just IndexTable { - it_cc = it_cc', - it_ccs = it_ccs', - it_next = it_next', - it_back_edge = it_back_edge' - } +peekIndexTable _ _ _ = pure Nothing + -- it_cc_ptr <- (#peek struct IndexTable_, cc) ptr + -- it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr + -- it_ccs_ptr <- (#peek struct IndexTable_, ccs) ptr + -- it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr + -- it_next_ptr <- (#peek struct IndexTable_, next) ptr + -- it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr + -- it_back_edge' <- (#peek struct IndexTable_, back_edge) ptr + + -- return $ Just IndexTable { + -- it_cc = it_cc', + -- it_ccs = it_ccs', + -- it_next = it_next', + -- it_back_edge = it_back_edge' + -- } -- | casts a @Ptr@ to an @Int@ ptrToInt :: Ptr a -> Int ===================================== rts/FileLock.c ===================================== @@ -46,7 +46,7 @@ STATIC_INLINE int hashLock(const HashTable *table, StgWord w) Lock *l = (Lock *)w; StgWord key = l->inode ^ (l->inode >> 32) ^ l->device ^ (l->device >> 32); // Just xor all 32-bit words of inode and device, hope this is good enough. - return hashWord(table, key); + return hashAddress(table, key); } void ===================================== rts/Hash.c ===================================== @@ -36,7 +36,7 @@ /* Also the minimum size of a hash table */ #define HDIRSIZE 1024 /* Size of the segment directory */ /* Maximum hash table size is HSEGSIZE * HDIRSIZE */ -#define HLOAD 5 /* Maximum average load of a single hash bucket */ +#define HLOAD 1 /* Maximum average load of a single hash bucket */ #define HCHUNK (1024 * sizeof(W_) / sizeof(HashList)) /* Number of HashList cells to allocate in one go */ @@ -76,12 +76,27 @@ struct strhashtable { struct hashtable table; }; * next bucket to be split, re-hash using the larger table. * -------------------------------------------------------------------------- */ int -hashWord(const HashTable *table, StgWord key) +hashAddress(const HashTable *table, StgWord key) { int bucket; /* Strip the boring zero bits */ - key >>= sizeof(StgWord); + key /= sizeof(StgWord); + + /* Mod the size of the hash table (a power of 2) */ + bucket = key & table->mask1; + + if (bucket < table->split) { + /* Mod the size of the expanded hash table (also a power of 2) */ + bucket = key & table->mask2; + } + return bucket; +} + +int +hashWord(const HashTable *table, StgWord key) +{ + int bucket; /* Mod the size of the hash table (a power of 2) */ bucket = key & table->mask1; @@ -169,14 +184,14 @@ expand(HashTable *table, HashFunction f) return; /* Calculate indices of bucket to split */ - oldsegment = table->split / HSEGSIZE; - oldindex = table->split % HSEGSIZE; + oldsegment = table->split / HSEGSIZE; // 0 + oldindex = table->split % HSEGSIZE; // 0 - newbucket = table->max + table->split; + newbucket = table->max + table->split; // 1024 /* And the indices of the new bucket */ - newsegment = newbucket / HSEGSIZE; - newindex = newbucket % HSEGSIZE; + newsegment = newbucket / HSEGSIZE; // 1 + newindex = newbucket % HSEGSIZE; // 0 if (newindex == 0) allocSegment(table, newsegment); @@ -238,10 +253,17 @@ lookupHashTable_(const HashTable *table, StgWord key, return lookupHashTable_inlined(table, key, f, cmp); } +void * +lookupHashTable_indexTable_(const HashTable *table, StgWord key, + HashFunction f) +{ + return lookupHashTable_inlined(table, key, f, compareWord); +} + void * lookupHashTable(const HashTable *table, StgWord key) { - return lookupHashTable_inlined(table, key, hashWord, compareWord); + return lookupHashTable_inlined(table, key, hashAddress, compareWord); } void * @@ -371,7 +393,7 @@ insertHashTable_(HashTable *table, StgWord key, void insertHashTable(HashTable *table, StgWord key, const void *data) { - insertHashTable_inlined(table, key, data, hashWord); + insertHashTable_inlined(table, key, data, hashAddress); } void @@ -422,7 +444,7 @@ removeHashTable_(HashTable *table, StgWord key, const void *data, void * removeHashTable(HashTable *table, StgWord key, const void *data) { - return removeHashTable_inlined(table, key, data, hashWord, compareWord); + return removeHashTable_inlined(table, key, data, hashAddress, compareWord); } void * @@ -515,6 +537,52 @@ mapHashTableKeys(HashTable *table, void *data, MapHashFnKeys fn) } } +void initHashIterator(HashTable *table, struct HashIterator_* iter) { + /* The last bucket with something in it is table->max + table->split - 1 */ + long segment = (table->max + table->split - 1) / HSEGSIZE; + long index = (table->max + table->split - 1) % HSEGSIZE; + iter->table = table; + iter->segment = segment; + iter->index = index; + iter->data = NULL; +} + +struct HashIterator_* hashTableIterator(HashTable *table) { + struct HashIterator_* iter; + iter = stgMallocBytes(sizeof(HashIterator),"hashTableIterator"); + initHashIterator(table, iter); + return iter; +} + +const void *hashIteratorItem(struct HashIterator_* iter) { + return iter->data; +} + +int hashIteratorNext(struct HashIterator_* iter) { + long segment = iter->segment; + long index = iter->index; + + while (segment >= 0) { + while (index >= 0) { + for (HashList *hl = iter->table->dir[segment][index]; hl != NULL; hl = hl->next) { + iter->segment = segment; + /* make sure we advance the index */ + iter->index = index - 1; + iter->data = hl->data; + return 1; + } + index--; + } + segment--; + index = HSEGSIZE - 1; + } + return 0; +} + +void freeHashIterator(struct HashIterator_* iter) { + stgFree(iter); +} + void iterHashTable(HashTable *table, void *data, IterHashFn fn) { @@ -536,6 +604,7 @@ iterHashTable(HashTable *table, void *data, IterHashFn fn) } } + /* ----------------------------------------------------------------------------- * When we initialize a hash table, we set up the first segment as well, * initializing all of the first segment's hash buckets to NULL. ===================================== rts/Hash.h ===================================== @@ -42,6 +42,21 @@ void mapHashTable(HashTable *table, void *data, MapHashFn fn); void mapHashTableKeys(HashTable *table, void *data, MapHashFnKeys fn); void iterHashTable(HashTable *table, void *data, IterHashFn); +struct HashIterator_ { + HashTable *table; + long segment; + long index; + const void* data; +}; +typedef struct HashIterator_ HashIterator; + +void initHashIterator(HashTable *, struct HashIterator_*); +struct HashIterator_* hashTableIterator(HashTable *table); +const void *hashIteratorItem(struct HashIterator_* iter); +int hashIteratorNext(struct HashIterator_* iter); +void freeHashIterator(struct HashIterator_* iter); + + /* Hash table access where the keys are C strings (the strings are * assumed to be allocated by the caller, and mustn't be deallocated * until the corresponding hash table entry has been removed). @@ -73,6 +88,7 @@ typedef int CompareFunction(StgWord key1, StgWord key2); // Helper for implementing hash functions int hashBuffer(const HashTable *table, const void *buf, size_t len); +int hashAddress(const HashTable *table, StgWord key); int hashWord(const HashTable *table, StgWord key); int hashStr(const HashTable *table, StgWord w); void insertHashTable_ ( HashTable *table, StgWord key, ===================================== rts/IndexTable.c ===================================== @@ -0,0 +1,119 @@ +#if defined(PROFILING) + +#include "Rts.h" +#include "rts/prof/IndexTable.h" +#include "RtsFlags.h" +#include "RtsUtils.h" +#include "rts/PosixSource.h" +#include "rts/prof/CCS.h" +#include "Hash.h" +#include "assert.h" + +#include "Profiling.h" +#include "Arena.h" + +#include <fs_rts.h> +#include <string.h> + +#if defined(DEBUG) || defined(PROFILING) +#include "Trace.h" +#endif + + +typedef struct IndexTable_ IndexTable; + +void +freeIndexTable(IndexTable * it) { + assert(it != EMPTY_TABLE); + if (it != EMPTY_TABLE) { + freeHashTable(it->children, NULL); + it->children = NULL; + } +} + +STATIC_INLINE int +compareWord(StgWord key1, StgWord key2) +{ + return (key1 == key2); +} + +CostCentreStack * +isInIndexTable(IndexTable *it, CostCentre *cc) { + if (EMPTY_TABLE == it) { + return EMPTY_TABLE; + } + // IF_DEBUG(prof, + // traceBegin("isInIndexTable %s ", cc->label); + // debugBelch("<%d>", keyCountHashTable(it->children)); + // traceEnd();); + + IndexTableNode * node; + node = (IndexTableNode *) lookupHashTable_(it->children, (StgWord) cc->ccID, hashWord, compareWord); + if (node == NULL) { + /* Not found */ + return EMPTY_TABLE; + } + return node->ccs; +} + + +IndexTable * +addToIndexTable(IndexTable *it, CostCentreStack *new_ccs, + CostCentre *cc, bool back_edge) { + if (it == EMPTY_TABLE) { + it = arenaAlloc(prof_arena, sizeof(IndexTable)); + it->children = allocHashTable(); + } + assert(it != EMPTY_TABLE); + + IndexTableNode *node; + node = arenaAlloc(prof_arena, sizeof(IndexTableNode)); + + node->cc = cc; + node->ccs = new_ccs; + node->back_edge = back_edge; + + insertHashTable_(it->children, (StgWord) node->cc->ccID, (const void *) node, hashWord); + + return it; +} + +struct IndexTableIter_ { + struct HashIterator_ *iterator; +}; + +IndexTableIter* +indexTableIterator(IndexTable *it) { + IndexTableIter *iter; + HashIterator *hashIter = NULL; + iter = arenaAlloc(prof_arena, sizeof(IndexTableIter)); + + if (it != EMPTY_TABLE) { + hashIter = arenaAlloc(prof_arena, sizeof(struct HashIterator_)); + initHashIterator(it->children, hashIter); + } + + iter->iterator = hashIter; + return iter; +} + +int +indexTableIterNext (IndexTableIter *iter) { + assert(iter != NULL); + if (iter->iterator == NULL) { + return 0; + } + return hashIteratorNext(iter->iterator); +}; + + +IndexTableNode* +indexTableIterItem(IndexTableIter *it) { + assert(it != NULL); + if (it->iterator == NULL) { + return EMPTY_TABLE; + } + return (IndexTableNode *) hashIteratorItem(it->iterator); +} + +#endif /* PROFILING */ ===================================== rts/ProfilerReport.c ===================================== @@ -14,6 +14,7 @@ #include "RtsUtils.h" #include "ProfilerReport.h" #include "Profiling.h" +#include "rts/prof/IndexTable.h" static uint32_t numDigits ( StgInt i ); static void findCCSMaxLens ( CostCentreStack const *ccs, @@ -189,7 +190,7 @@ static void findCCSMaxLens(CostCentreStack const *ccs, uint32_t indent, uint32_t *max_label_len, uint32_t *max_module_len, uint32_t *max_src_len, uint32_t *max_id_len) { CostCentre *cc; - IndexTable *i; + IndexTableIter *i; cc = ccs->cc; @@ -198,14 +199,17 @@ findCCSMaxLens(CostCentreStack const *ccs, uint32_t indent, uint32_t *max_label_ *max_src_len = stg_max(*max_src_len, strlen_utf8(cc->srcloc)); *max_id_len = stg_max(*max_id_len, numDigits(ccs->ccsID)); - for (i = ccs->indexTable; i != 0; i = i->next) { - if (!i->back_edge) { - findCCSMaxLens(i->ccs, indent+1, + for ( i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (!indexTableIterItem(i)->back_edge) { + findCCSMaxLens(indexTableIterItem(i)->ccs, indent+1, max_label_len, max_module_len, max_src_len, max_id_len); } } } + static void logCCS(FILE *prof_file, CostCentreStack const *ccs, ProfilerTotals totals, uint32_t indent, @@ -213,7 +217,7 @@ logCCS(FILE *prof_file, CostCentreStack const *ccs, ProfilerTotals totals, uint32_t max_src_len, uint32_t max_id_len) { CostCentre *cc; - IndexTable *i; + IndexTableIter *i; cc = ccs->cc; @@ -248,9 +252,11 @@ logCCS(FILE *prof_file, CostCentreStack const *ccs, ProfilerTotals totals, fprintf(prof_file, "\n"); } - for (i = ccs->indexTable; i != 0; i = i->next) { - if (!i->back_edge) { - logCCS(prof_file, i->ccs, totals, indent+1, + for ( i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (!indexTableIterItem(i)->back_edge) { + logCCS(prof_file, indexTableIterItem(i)->ccs, totals, indent+1, max_label_len, max_module_len, max_src_len, max_id_len); } } ===================================== rts/ProfilerReportJson.c ===================================== @@ -6,6 +6,7 @@ * * ---------------------------------------------------------------------------*/ +#include <stdio.h> #if defined(PROFILING) #include "rts/PosixSource.h" @@ -14,6 +15,7 @@ #include "RtsUtils.h" #include "ProfilerReportJson.h" #include "Profiling.h" +#include "rts/prof/IndexTable.h" #include <string.h> @@ -232,12 +234,14 @@ logCostCentreStack(FILE *prof_file, CostCentreStack const *ccs) bool need_comma = false; fprintf(prof_file, "\"children\": ["); - for (IndexTable *i = ccs->indexTable; i != 0; i = i->next) { - if (!i->back_edge) { + for ( IndexTableIter *i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (!indexTableIterItem(i)->back_edge) { if (need_comma) { fprintf(prof_file, ","); } - logCostCentreStack(prof_file, i->ccs); + logCostCentreStack(prof_file, indexTableIterItem(i)->ccs); need_comma = true; } } ===================================== rts/Profiling.c ===================================== @@ -22,6 +22,7 @@ #include "ProfilerReportJson.h" #include "Printer.h" #include "Capability.h" +#include "rts/prof/IndexTable.h" #include <fs_rts.h> #include <string.h> @@ -33,11 +34,11 @@ /* * Profiling allocation arena. */ -#if defined(DEBUG) +// #if defined(DEBUG) Arena *prof_arena; -#else -static Arena *prof_arena; -#endif +// #else +// static Arena *prof_arena; +// #endif /* * Global variables used to assign unique IDs to cc's, ccs's, and @@ -119,9 +120,6 @@ static CostCentreStack * checkLoop ( CostCentreStack *ccs, static void sortCCSTree ( CostCentreStack *ccs ); static CostCentreStack * pruneCCSTree ( CostCentreStack *ccs ); static CostCentreStack * actualPush ( CostCentreStack *, CostCentre * ); -static CostCentreStack * isInIndexTable ( IndexTable *, CostCentre * ); -static IndexTable * addToIndexTable ( IndexTable *, CostCentreStack *, - CostCentre *, bool ); static void ccsSetSelected ( CostCentreStack *ccs ); static void aggregateCCCosts( CostCentreStack *ccs ); static void registerCC ( CostCentre *cc ); @@ -552,6 +550,7 @@ pushCostCentre (CostCentreStack *ccs, CostCentre *cc) // not in the IndexTable, now we take the lock: ACQUIRE_LOCK(&ccs_mutex); + // TODO @fendor: this check can never succeed if (ccs->indexTable != ixtable) { // someone modified ccs->indexTable while @@ -595,6 +594,7 @@ pushCostCentre (CostCentreStack *ccs, CostCentre *cc) return ret; } +// ALSO LINEAR static CostCentreStack * checkLoop (CostCentreStack *ccs, CostCentre *cc) { @@ -621,13 +621,13 @@ static CostCentreStack * actualPush_ (CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs) { /* assign values to each member of the structure */ + new_ccs->indexTable = 0; new_ccs->ccsID = CCS_ID++; new_ccs->cc = cc; new_ccs->prevStack = ccs; new_ccs->root = ccs->root; new_ccs->depth = ccs->depth + 1; - new_ccs->indexTable = EMPTY_TABLE; /* Initialise the various _scc_ counters to zero */ @@ -652,38 +652,6 @@ actualPush_ (CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs) return new_ccs; } - -static CostCentreStack * -isInIndexTable(IndexTable *it, CostCentre *cc) -{ - while (it!=EMPTY_TABLE) - { - if (it->cc == cc) - return it->ccs; - else - it = it->next; - } - - /* otherwise we never found it so return EMPTY_TABLE */ - return EMPTY_TABLE; -} - - -static IndexTable * -addToIndexTable (IndexTable *it, CostCentreStack *new_ccs, - CostCentre *cc, bool back_edge) -{ - IndexTable *new_it; - - new_it = arenaAlloc(prof_arena, sizeof(IndexTable)); - - new_it->cc = cc; - new_it->ccs = new_ccs; - new_it->next = it; - new_it->back_edge = back_edge; - return new_it; -} - /* ----------------------------------------------------------------------------- Generating a time & allocation profiling report. -------------------------------------------------------------------------- */ @@ -744,9 +712,11 @@ countTickss_(CostCentreStack const *ccs, ProfilerTotals *totals) totals->total_alloc += ccs->mem_alloc; totals->total_prof_ticks += ccs->time_ticks; } - for (IndexTable *i = ccs->indexTable; i != NULL; i = i->next) { - if (!i->back_edge) { - countTickss_(i->ccs, totals); + for ( IndexTableIter *i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (!indexTableIterItem(i)->back_edge) { + countTickss_(indexTableIterItem(i)->ccs, totals); } } } @@ -767,18 +737,19 @@ countTickss(CostCentreStack const *ccs) static void inheritCosts(CostCentreStack *ccs) { - IndexTable *i; if (ignoreCCS(ccs)) { return; } ccs->inherited_ticks += ccs->time_ticks; ccs->inherited_alloc += ccs->mem_alloc; - for (i = ccs->indexTable; i != NULL; i = i->next) - if (!i->back_edge) { - inheritCosts(i->ccs); - ccs->inherited_ticks += i->ccs->inherited_ticks; - ccs->inherited_alloc += i->ccs->inherited_alloc; + for ( IndexTableIter *i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) + if (!indexTableIterItem(i)->back_edge) { + inheritCosts(indexTableIterItem(i)->ccs); + ccs->inherited_ticks += indexTableIterItem(i)->ccs->inherited_ticks; + ccs->inherited_alloc += indexTableIterItem(i)->ccs->inherited_alloc; } return; @@ -787,14 +758,14 @@ inheritCosts(CostCentreStack *ccs) static void aggregateCCCosts( CostCentreStack *ccs ) { - IndexTable *i; - ccs->cc->mem_alloc += ccs->mem_alloc; ccs->cc->time_ticks += ccs->time_ticks; - for (i = ccs->indexTable; i != 0; i = i->next) { - if (!i->back_edge) { - aggregateCCCosts(i->ccs); + for ( IndexTableIter *i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (!indexTableIterItem(i)->back_edge) { + aggregateCCCosts(indexTableIterItem(i)->ccs); } } } @@ -806,19 +777,22 @@ aggregateCCCosts( CostCentreStack *ccs ) static CostCentreStack * pruneCCSTree (CostCentreStack *ccs) { - CostCentreStack *ccs1; - IndexTable *i, **prev; + // CostCentreStack *ccs1; + // IndexTable *i, **prev; - prev = &ccs->indexTable; - for (i = ccs->indexTable; i != 0; i = i->next) { - if (i->back_edge) { continue; } + // prev = &ccs->indexTable; + for ( IndexTableIter *i = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(i) != 0 + ; ) { + if (indexTableIterItem(i)->back_edge) { continue; } - ccs1 = pruneCCSTree(i->ccs); - if (ccs1 == NULL) { - *prev = i->next; - } else { - prev = &(i->next); - } + // TODO: @fendor implement pruning + // ccs1 = pruneCCSTree(indexTableIterItem(i)->ccs); + // if (ccs1 == NULL) { + // *prev = i->next; + // } else { + // prev = &(i->next); + // } } if ( (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL @@ -833,59 +807,62 @@ pruneCCSTree (CostCentreStack *ccs) } } -static IndexTable* -insertIndexTableInSortedList(IndexTable* tbl, IndexTable* sortedList) -{ - StgWord tbl_ticks = tbl->ccs->scc_count; - char* tbl_label = tbl->ccs->cc->label; - - IndexTable *prev = NULL; - IndexTable *cursor = sortedList; - - while (cursor != NULL) { - StgWord cursor_ticks = cursor->ccs->scc_count; - char* cursor_label = cursor->ccs->cc->label; - - if (tbl_ticks > cursor_ticks || - (tbl_ticks == cursor_ticks && strcmp(tbl_label, cursor_label) < 0)) { - if (prev == NULL) { - tbl->next = sortedList; - return tbl; - } else { - prev->next = tbl; - tbl->next = cursor; - return sortedList; - } - } else { - prev = cursor; - cursor = cursor->next; - } - } - - prev->next = tbl; - return sortedList; -} +// static IndexTable* +// insertIndexTableInSortedList(IndexTable* tbl, IndexTable* sortedList) +// { +// StgWord tbl_ticks = tbl->ccs->scc_count; +// char* tbl_label = tbl->ccs->cc->label; + +// IndexTable *prev = NULL; +// IndexTable *cursor = sortedList; + +// while (cursor != NULL) { +// StgWord cursor_ticks = cursor->ccs->scc_count; +// char* cursor_label = cursor->ccs->cc->label; + +// if (tbl_ticks > cursor_ticks || +// (tbl_ticks == cursor_ticks && strcmp(tbl_label, cursor_label) < 0)) { +// if (prev == NULL) { +// tbl->next = sortedList; +// return tbl; +// } else { +// prev->next = tbl; +// tbl->next = cursor; +// return sortedList; +// } +// } else { +// prev = cursor; +// cursor = cursor->next; +// } +// } + +// prev->next = tbl; +// return sortedList; +// } static void sortCCSTree(CostCentreStack *ccs) { if (ccs->indexTable == NULL) return; - for (IndexTable *tbl = ccs->indexTable; tbl != NULL; tbl = tbl->next) - if (!tbl->back_edge) - sortCCSTree(tbl->ccs); + for ( IndexTableIter *iter = indexTableIterator(ccs->indexTable) + ; indexTableIterNext(iter) != 0 + ; ) + if (!indexTableIterItem(iter)->back_edge) + sortCCSTree(indexTableIterItem(iter)->ccs); IndexTable *sortedList = ccs->indexTable; - IndexTable *nonSortedList = sortedList->next; - sortedList->next = NULL; - - while (nonSortedList != NULL) - { - IndexTable *nonSortedTail = nonSortedList->next; - nonSortedList->next = NULL; - sortedList = insertIndexTableInSortedList(nonSortedList, sortedList); - nonSortedList = nonSortedTail; - } + // TODO @fendor: reimplement sorting + // IndexTable *nonSortedList = sortedList->next; + // sortedList->next = NULL; + + // while (nonSortedList != NULL) + // { + // IndexTable *nonSortedTail = nonSortedList->next; + // nonSortedList->next = NULL; + // sortedList = insertIndexTableInSortedList(nonSortedList, sortedList); + // nonSortedList = nonSortedTail; + // } ccs->indexTable = sortedList; } ===================================== rts/Profiling.h ===================================== @@ -11,9 +11,9 @@ #include <stdio.h> #include "Rts.h" -#if defined(DEBUG) +// #if defined(DEBUG) #include "Arena.h" -#endif +// #endif #include "BeginPrivate.h" @@ -49,9 +49,9 @@ void fprintCCS_stderr (CostCentreStack *ccs, StgClosure *exception, StgTSO *tso) bool ignoreCCS (CostCentreStack const *ccs); bool ignoreCC (CostCentre const *cc); -#if defined(DEBUG) extern Arena *prof_arena; +#if defined(DEBUG) void debugCCS( CostCentreStack *ccs ); #endif ===================================== rts/StaticPtrTable.c ===================================== @@ -24,7 +24,7 @@ static Mutex spt_lock; STATIC_INLINE int hashFingerprint(const HashTable *table, StgWord key) { const StgWord64* ptr = (StgWord64*) key; // Take half of the key to compute the hash. - return hashWord(table, *(ptr + 1)); + return hashAddress(table, *(ptr + 1)); } /// Comparison function for the SPT. ===================================== rts/include/Rts.h ===================================== @@ -231,6 +231,7 @@ void _warnFail(const char *filename, unsigned int linenum); /* Profiling information */ #include "rts/prof/CCS.h" +#include "rts/prof/IndexTable.h" #include "rts/prof/Heap.h" #include "rts/prof/LDV.h" ===================================== rts/include/rts/prof/CCS.h ===================================== @@ -99,27 +99,6 @@ void startProfTimer ( void ); /* Constants used to set is_caf flag on CostCentres */ #define CC_IS_CAF true #define CC_NOT_CAF false -/* ----------------------------------------------------------------------------- - * Data Structures - * ---------------------------------------------------------------------------*/ - -// IndexTable is the list of children of a CCS. (Alternatively it is a -// cache of the results of pushing onto a CCS, so that the second and -// subsequent times we push a certain CC on a CCS we get the same -// result). - -typedef struct IndexTable_ { - // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of - // pushing `cc` to the owner of the index table (another CostCentreStack). - CostCentre *cc; - CostCentreStack *ccs; - struct IndexTable_ *next; - // back_edge is true when `cc` is already in the stack, so pushing it - // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in - // Profiling.c). - bool back_edge; -} IndexTable; - /* ----------------------------------------------------------------------------- Pre-defined cost centres and cost centre stacks ===================================== rts/include/rts/prof/IndexTable.h ===================================== @@ -0,0 +1,51 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + * Data Structures + * ---------------------------------------------------------------------------*/ + +// IndexTable is the list of children of a CCS. (Alternatively it is a +// cache of the results of pushing onto a CCS, so that the second and +// subsequent times we push a certain CC on a CCS we get the same +// result). + +typedef struct IndexTableNode_ { + // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of + // pushing `cc` to the owner of the index table (another CostCentreStack). + CostCentre *cc; + CostCentreStack *ccs; + // back_edge is true when `cc` is already in the stack, so pushing it + // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in + // Profiling.c). + bool back_edge; +} IndexTableNode; + +typedef struct IndexTableNode_ IndexTableNode; + +typedef struct IndexTable_ { + // IndexTableNode *node; + // // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of + // // pushing `cc` to the owner of the index table (another CostCentreStack). + // CostCentre *cc; + // CostCentreStack *ccs; + // // back_edge is true when `cc` is already in the stack, so pushing it + // // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in + // // Profiling.c). + // bool back_edge; + struct hashtable *children; +} IndexTable; + +typedef struct IndexTable_ IndexTable; + +IndexTable * allocateIndexTable( void ); +void freeIndexTable( IndexTable * ); +CostCentreStack * isInIndexTable ( IndexTable *, CostCentre * ); +IndexTable * addToIndexTable ( IndexTable *, CostCentreStack *, + CostCentre *, bool ); + +typedef struct IndexTableIter_ IndexTableIter; + + +IndexTableIter* indexTableIterator ( IndexTable * ); +int indexTableIterNext ( IndexTableIter * ); +IndexTableNode* indexTableIterItem ( IndexTableIter * ); ===================================== rts/rts.cabal ===================================== @@ -322,6 +322,7 @@ library rts/Utils.h rts/prof/CCS.h rts/prof/Heap.h + rts/prof/IndexTable.h rts/prof/LDV.h rts/storage/Block.h rts/storage/ClosureMacros.h @@ -436,6 +437,7 @@ library ProfilerReport.c ProfilerReportJson.c Profiling.c + IndexTable.c IPE.c Proftimer.c RaiseAsync.c ===================================== testsuite/tests/perf/should_run/T26147.stdout ===================================== @@ -1,1001 +1 @@ -Test value: 0 -Test value: 1 -Test value: 2 -Test value: 3 -Test value: 4 -Test value: 5 -Test value: 6 -Test value: 7 -Test value: 8 -Test value: 9 -Test value: 10 -Test value: 11 -Test value: 12 -Test value: 13 -Test value: 14 -Test value: 15 -Test value: 16 -Test value: 17 -Test value: 18 -Test value: 19 -Test value: 20 -Test value: 21 -Test value: 22 -Test value: 23 -Test value: 24 -Test value: 25 -Test value: 26 -Test value: 27 -Test value: 28 -Test value: 29 -Test value: 30 -Test value: 31 -Test value: 32 -Test value: 33 -Test value: 34 -Test value: 35 -Test value: 36 -Test value: 37 -Test value: 38 -Test value: 39 -Test value: 40 -Test value: 41 -Test value: 42 -Test value: 43 -Test value: 44 -Test value: 45 -Test value: 46 -Test value: 47 -Test value: 48 -Test value: 49 -Test value: 50 -Test value: 51 -Test value: 52 -Test value: 53 -Test value: 54 -Test value: 55 -Test value: 56 -Test value: 57 -Test value: 58 -Test value: 59 -Test value: 60 -Test value: 61 -Test value: 62 -Test value: 63 -Test value: 64 -Test value: 65 -Test value: 66 -Test value: 67 -Test value: 68 -Test value: 69 -Test value: 70 -Test value: 71 -Test value: 72 -Test value: 73 -Test value: 74 -Test value: 75 -Test value: 76 -Test value: 77 -Test value: 78 -Test value: 79 -Test value: 80 -Test value: 81 -Test value: 82 -Test value: 83 -Test value: 84 -Test value: 85 -Test value: 86 -Test value: 87 -Test value: 88 -Test value: 89 -Test value: 90 -Test value: 91 -Test value: 92 -Test value: 93 -Test value: 94 -Test value: 95 -Test value: 96 -Test value: 97 -Test value: 98 -Test value: 99 -Test value: 100 -Test value: 101 -Test value: 102 -Test value: 103 -Test value: 104 -Test value: 105 -Test value: 106 -Test value: 107 -Test value: 108 -Test value: 109 -Test value: 110 -Test value: 111 -Test value: 112 -Test value: 113 -Test value: 114 -Test value: 115 -Test value: 116 -Test value: 117 -Test value: 118 -Test value: 119 -Test value: 120 -Test value: 121 -Test value: 122 -Test value: 123 -Test value: 124 -Test value: 125 -Test value: 126 -Test value: 127 -Test value: 128 -Test value: 129 -Test value: 130 -Test value: 131 -Test value: 132 -Test value: 133 -Test value: 134 -Test value: 135 -Test value: 136 -Test value: 137 -Test value: 138 -Test value: 139 -Test value: 140 -Test value: 141 -Test value: 142 -Test value: 143 -Test value: 144 -Test value: 145 -Test value: 146 -Test value: 147 -Test value: 148 -Test value: 149 -Test value: 150 -Test value: 151 -Test value: 152 -Test value: 153 -Test value: 154 -Test value: 155 -Test value: 156 -Test value: 157 -Test value: 158 -Test value: 159 -Test value: 160 -Test value: 161 -Test value: 162 -Test value: 163 -Test value: 164 -Test value: 165 -Test value: 166 -Test value: 167 -Test value: 168 -Test value: 169 -Test value: 170 -Test value: 171 -Test value: 172 -Test value: 173 -Test value: 174 -Test value: 175 -Test value: 176 -Test value: 177 -Test value: 178 -Test value: 179 -Test value: 180 -Test value: 181 -Test value: 182 -Test value: 183 -Test value: 184 -Test value: 185 -Test value: 186 -Test value: 187 -Test value: 188 -Test value: 189 -Test value: 190 -Test value: 191 -Test value: 192 -Test value: 193 -Test value: 194 -Test value: 195 -Test value: 196 -Test value: 197 -Test value: 198 -Test value: 199 -Test value: 200 -Test value: 201 -Test value: 202 -Test value: 203 -Test value: 204 -Test value: 205 -Test value: 206 -Test value: 207 -Test value: 208 -Test value: 209 -Test value: 210 -Test value: 211 -Test value: 212 -Test value: 213 -Test value: 214 -Test value: 215 -Test value: 216 -Test value: 217 -Test value: 218 -Test value: 219 -Test value: 220 -Test value: 221 -Test value: 222 -Test value: 223 -Test value: 224 -Test value: 225 -Test value: 226 -Test value: 227 -Test value: 228 -Test value: 229 -Test value: 230 -Test value: 231 -Test value: 232 -Test value: 233 -Test value: 234 -Test value: 235 -Test value: 236 -Test value: 237 -Test value: 238 -Test value: 239 -Test value: 240 -Test value: 241 -Test value: 242 -Test value: 243 -Test value: 244 -Test value: 245 -Test value: 246 -Test value: 247 -Test value: 248 -Test value: 249 -Test value: 250 -Test value: 251 -Test value: 252 -Test value: 253 -Test value: 254 -Test value: 255 -Test value: 256 -Test value: 257 -Test value: 258 -Test value: 259 -Test value: 260 -Test value: 261 -Test value: 262 -Test value: 263 -Test value: 264 -Test value: 265 -Test value: 266 -Test value: 267 -Test value: 268 -Test value: 269 -Test value: 270 -Test value: 271 -Test value: 272 -Test value: 273 -Test value: 274 -Test value: 275 -Test value: 276 -Test value: 277 -Test value: 278 -Test value: 279 -Test value: 280 -Test value: 281 -Test value: 282 -Test value: 283 -Test value: 284 -Test value: 285 -Test value: 286 -Test value: 287 -Test value: 288 -Test value: 289 -Test value: 290 -Test value: 291 -Test value: 292 -Test value: 293 -Test value: 294 -Test value: 295 -Test value: 296 -Test value: 297 -Test value: 298 -Test value: 299 -Test value: 300 -Test value: 301 -Test value: 302 -Test value: 303 -Test value: 304 -Test value: 305 -Test value: 306 -Test value: 307 -Test value: 308 -Test value: 309 -Test value: 310 -Test value: 311 -Test value: 312 -Test value: 313 -Test value: 314 -Test value: 315 -Test value: 316 -Test value: 317 -Test value: 318 -Test value: 319 -Test value: 320 -Test value: 321 -Test value: 322 -Test value: 323 -Test value: 324 -Test value: 325 -Test value: 326 -Test value: 327 -Test value: 328 -Test value: 329 -Test value: 330 -Test value: 331 -Test value: 332 -Test value: 333 -Test value: 334 -Test value: 335 -Test value: 336 -Test value: 337 -Test value: 338 -Test value: 339 -Test value: 340 -Test value: 341 -Test value: 342 -Test value: 343 -Test value: 344 -Test value: 345 -Test value: 346 -Test value: 347 -Test value: 348 -Test value: 349 -Test value: 350 -Test value: 351 -Test value: 352 -Test value: 353 -Test value: 354 -Test value: 355 -Test value: 356 -Test value: 357 -Test value: 358 -Test value: 359 -Test value: 360 -Test value: 361 -Test value: 362 -Test value: 363 -Test value: 364 -Test value: 365 -Test value: 366 -Test value: 367 -Test value: 368 -Test value: 369 -Test value: 370 -Test value: 371 -Test value: 372 -Test value: 373 -Test value: 374 -Test value: 375 -Test value: 376 -Test value: 377 -Test value: 378 -Test value: 379 -Test value: 380 -Test value: 381 -Test value: 382 -Test value: 383 -Test value: 384 -Test value: 385 -Test value: 386 -Test value: 387 -Test value: 388 -Test value: 389 -Test value: 390 -Test value: 391 -Test value: 392 -Test value: 393 -Test value: 394 -Test value: 395 -Test value: 396 -Test value: 397 -Test value: 398 -Test value: 399 -Test value: 400 -Test value: 401 -Test value: 402 -Test value: 403 -Test value: 404 -Test value: 405 -Test value: 406 -Test value: 407 -Test value: 408 -Test value: 409 -Test value: 410 -Test value: 411 -Test value: 412 -Test value: 413 -Test value: 414 -Test value: 415 -Test value: 416 -Test value: 417 -Test value: 418 -Test value: 419 -Test value: 420 -Test value: 421 -Test value: 422 -Test value: 423 -Test value: 424 -Test value: 425 -Test value: 426 -Test value: 427 -Test value: 428 -Test value: 429 -Test value: 430 -Test value: 431 -Test value: 432 -Test value: 433 -Test value: 434 -Test value: 435 -Test value: 436 -Test value: 437 -Test value: 438 -Test value: 439 -Test value: 440 -Test value: 441 -Test value: 442 -Test value: 443 -Test value: 444 -Test value: 445 -Test value: 446 -Test value: 447 -Test value: 448 -Test value: 449 -Test value: 450 -Test value: 451 -Test value: 452 -Test value: 453 -Test value: 454 -Test value: 455 -Test value: 456 -Test value: 457 -Test value: 458 -Test value: 459 -Test value: 460 -Test value: 461 -Test value: 462 -Test value: 463 -Test value: 464 -Test value: 465 -Test value: 466 -Test value: 467 -Test value: 468 -Test value: 469 -Test value: 470 -Test value: 471 -Test value: 472 -Test value: 473 -Test value: 474 -Test value: 475 -Test value: 476 -Test value: 477 -Test value: 478 -Test value: 479 -Test value: 480 -Test value: 481 -Test value: 482 -Test value: 483 -Test value: 484 -Test value: 485 -Test value: 486 -Test value: 487 -Test value: 488 -Test value: 489 -Test value: 490 -Test value: 491 -Test value: 492 -Test value: 493 -Test value: 494 -Test value: 495 -Test value: 496 -Test value: 497 -Test value: 498 -Test value: 499 -Test value: 500 -Test value: 501 -Test value: 502 -Test value: 503 -Test value: 504 -Test value: 505 -Test value: 506 -Test value: 507 -Test value: 508 -Test value: 509 -Test value: 510 -Test value: 511 -Test value: 512 -Test value: 513 -Test value: 514 -Test value: 515 -Test value: 516 -Test value: 517 -Test value: 518 -Test value: 519 -Test value: 520 -Test value: 521 -Test value: 522 -Test value: 523 -Test value: 524 -Test value: 525 -Test value: 526 -Test value: 527 -Test value: 528 -Test value: 529 -Test value: 530 -Test value: 531 -Test value: 532 -Test value: 533 -Test value: 534 -Test value: 535 -Test value: 536 -Test value: 537 -Test value: 538 -Test value: 539 -Test value: 540 -Test value: 541 -Test value: 542 -Test value: 543 -Test value: 544 -Test value: 545 -Test value: 546 -Test value: 547 -Test value: 548 -Test value: 549 -Test value: 550 -Test value: 551 -Test value: 552 -Test value: 553 -Test value: 554 -Test value: 555 -Test value: 556 -Test value: 557 -Test value: 558 -Test value: 559 -Test value: 560 -Test value: 561 -Test value: 562 -Test value: 563 -Test value: 564 -Test value: 565 -Test value: 566 -Test value: 567 -Test value: 568 -Test value: 569 -Test value: 570 -Test value: 571 -Test value: 572 -Test value: 573 -Test value: 574 -Test value: 575 -Test value: 576 -Test value: 577 -Test value: 578 -Test value: 579 -Test value: 580 -Test value: 581 -Test value: 582 -Test value: 583 -Test value: 584 -Test value: 585 -Test value: 586 -Test value: 587 -Test value: 588 -Test value: 589 -Test value: 590 -Test value: 591 -Test value: 592 -Test value: 593 -Test value: 594 -Test value: 595 -Test value: 596 -Test value: 597 -Test value: 598 -Test value: 599 -Test value: 600 -Test value: 601 -Test value: 602 -Test value: 603 -Test value: 604 -Test value: 605 -Test value: 606 -Test value: 607 -Test value: 608 -Test value: 609 -Test value: 610 -Test value: 611 -Test value: 612 -Test value: 613 -Test value: 614 -Test value: 615 -Test value: 616 -Test value: 617 -Test value: 618 -Test value: 619 -Test value: 620 -Test value: 621 -Test value: 622 -Test value: 623 -Test value: 624 -Test value: 625 -Test value: 626 -Test value: 627 -Test value: 628 -Test value: 629 -Test value: 630 -Test value: 631 -Test value: 632 -Test value: 633 -Test value: 634 -Test value: 635 -Test value: 636 -Test value: 637 -Test value: 638 -Test value: 639 -Test value: 640 -Test value: 641 -Test value: 642 -Test value: 643 -Test value: 644 -Test value: 645 -Test value: 646 -Test value: 647 -Test value: 648 -Test value: 649 -Test value: 650 -Test value: 651 -Test value: 652 -Test value: 653 -Test value: 654 -Test value: 655 -Test value: 656 -Test value: 657 -Test value: 658 -Test value: 659 -Test value: 660 -Test value: 661 -Test value: 662 -Test value: 663 -Test value: 664 -Test value: 665 -Test value: 666 -Test value: 667 -Test value: 668 -Test value: 669 -Test value: 670 -Test value: 671 -Test value: 672 -Test value: 673 -Test value: 674 -Test value: 675 -Test value: 676 -Test value: 677 -Test value: 678 -Test value: 679 -Test value: 680 -Test value: 681 -Test value: 682 -Test value: 683 -Test value: 684 -Test value: 685 -Test value: 686 -Test value: 687 -Test value: 688 -Test value: 689 -Test value: 690 -Test value: 691 -Test value: 692 -Test value: 693 -Test value: 694 -Test value: 695 -Test value: 696 -Test value: 697 -Test value: 698 -Test value: 699 -Test value: 700 -Test value: 701 -Test value: 702 -Test value: 703 -Test value: 704 -Test value: 705 -Test value: 706 -Test value: 707 -Test value: 708 -Test value: 709 -Test value: 710 -Test value: 711 -Test value: 712 -Test value: 713 -Test value: 714 -Test value: 715 -Test value: 716 -Test value: 717 -Test value: 718 -Test value: 719 -Test value: 720 -Test value: 721 -Test value: 722 -Test value: 723 -Test value: 724 -Test value: 725 -Test value: 726 -Test value: 727 -Test value: 728 -Test value: 729 -Test value: 730 -Test value: 731 -Test value: 732 -Test value: 733 -Test value: 734 -Test value: 735 -Test value: 736 -Test value: 737 -Test value: 738 -Test value: 739 -Test value: 740 -Test value: 741 -Test value: 742 -Test value: 743 -Test value: 744 -Test value: 745 -Test value: 746 -Test value: 747 -Test value: 748 -Test value: 749 -Test value: 750 -Test value: 751 -Test value: 752 -Test value: 753 -Test value: 754 -Test value: 755 -Test value: 756 -Test value: 757 -Test value: 758 -Test value: 759 -Test value: 760 -Test value: 761 -Test value: 762 -Test value: 763 -Test value: 764 -Test value: 765 -Test value: 766 -Test value: 767 -Test value: 768 -Test value: 769 -Test value: 770 -Test value: 771 -Test value: 772 -Test value: 773 -Test value: 774 -Test value: 775 -Test value: 776 -Test value: 777 -Test value: 778 -Test value: 779 -Test value: 780 -Test value: 781 -Test value: 782 -Test value: 783 -Test value: 784 -Test value: 785 -Test value: 786 -Test value: 787 -Test value: 788 -Test value: 789 -Test value: 790 -Test value: 791 -Test value: 792 -Test value: 793 -Test value: 794 -Test value: 795 -Test value: 796 -Test value: 797 -Test value: 798 -Test value: 799 -Test value: 800 -Test value: 801 -Test value: 802 -Test value: 803 -Test value: 804 -Test value: 805 -Test value: 806 -Test value: 807 -Test value: 808 -Test value: 809 -Test value: 810 -Test value: 811 -Test value: 812 -Test value: 813 -Test value: 814 -Test value: 815 -Test value: 816 -Test value: 817 -Test value: 818 -Test value: 819 -Test value: 820 -Test value: 821 -Test value: 822 -Test value: 823 -Test value: 824 -Test value: 825 -Test value: 826 -Test value: 827 -Test value: 828 -Test value: 829 -Test value: 830 -Test value: 831 -Test value: 832 -Test value: 833 -Test value: 834 -Test value: 835 -Test value: 836 -Test value: 837 -Test value: 838 -Test value: 839 -Test value: 840 -Test value: 841 -Test value: 842 -Test value: 843 -Test value: 844 -Test value: 845 -Test value: 846 -Test value: 847 -Test value: 848 -Test value: 849 -Test value: 850 -Test value: 851 -Test value: 852 -Test value: 853 -Test value: 854 -Test value: 855 -Test value: 856 -Test value: 857 -Test value: 858 -Test value: 859 -Test value: 860 -Test value: 861 -Test value: 862 -Test value: 863 -Test value: 864 -Test value: 865 -Test value: 866 -Test value: 867 -Test value: 868 -Test value: 869 -Test value: 870 -Test value: 871 -Test value: 872 -Test value: 873 -Test value: 874 -Test value: 875 -Test value: 876 -Test value: 877 -Test value: 878 -Test value: 879 -Test value: 880 -Test value: 881 -Test value: 882 -Test value: 883 -Test value: 884 -Test value: 885 -Test value: 886 -Test value: 887 -Test value: 888 -Test value: 889 -Test value: 890 -Test value: 891 -Test value: 892 -Test value: 893 -Test value: 894 -Test value: 895 -Test value: 896 -Test value: 897 -Test value: 898 -Test value: 899 -Test value: 900 -Test value: 901 -Test value: 902 -Test value: 903 -Test value: 904 -Test value: 905 -Test value: 906 -Test value: 907 -Test value: 908 -Test value: 909 -Test value: 910 -Test value: 911 -Test value: 912 -Test value: 913 -Test value: 914 -Test value: 915 -Test value: 916 -Test value: 917 -Test value: 918 -Test value: 919 -Test value: 920 -Test value: 921 -Test value: 922 -Test value: 923 -Test value: 924 -Test value: 925 -Test value: 926 -Test value: 927 -Test value: 928 -Test value: 929 -Test value: 930 -Test value: 931 -Test value: 932 -Test value: 933 -Test value: 934 -Test value: 935 -Test value: 936 -Test value: 937 -Test value: 938 -Test value: 939 -Test value: 940 -Test value: 941 -Test value: 942 -Test value: 943 -Test value: 944 -Test value: 945 -Test value: 946 -Test value: 947 -Test value: 948 -Test value: 949 -Test value: 950 -Test value: 951 -Test value: 952 -Test value: 953 -Test value: 954 -Test value: 955 -Test value: 956 -Test value: 957 -Test value: 958 -Test value: 959 -Test value: 960 -Test value: 961 -Test value: 962 -Test value: 963 -Test value: 964 -Test value: 965 -Test value: 966 -Test value: 967 -Test value: 968 -Test value: 969 -Test value: 970 -Test value: 971 -Test value: 972 -Test value: 973 -Test value: 974 -Test value: 975 -Test value: 976 -Test value: 977 -Test value: 978 -Test value: 979 -Test value: 980 -Test value: 981 -Test value: 982 -Test value: 983 -Test value: 984 -Test value: 985 -Test value: 986 -Test value: 987 -Test value: 988 -Test value: 989 -Test value: 990 -Test value: 991 -Test value: 992 -Test value: 993 -Test value: 994 -Test value: 995 -Test value: 996 -Test value: 997 -Test value: 998 -Test value: 999 -Test value: 1000 +Test value: 30000 ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -446,7 +446,6 @@ test('T26147', [ collect_stats('all', 5), pre_cmd('./genT26147'), extra_files(['genT26147']), - extra_run_opts('+RTS -p'), test_opts_dot_prof, ], compile_and_run, ===================================== testsuite/tests/perf/should_run/genT26147 ===================================== @@ -16,7 +16,6 @@ for i in $(seq $NUMFUN); do costCenter${i} :: Int -> IO () costCenter${i} n = do - putStrLn $ "Test value: " ++ show n costCenter$((i + 1)) (n+1) EOF done @@ -25,5 +24,7 @@ cat >> T26147.hs << EOF costCenter$((i + 1)) :: Int -> IO () costCenter$((i + 1)) n = do - putStrLn $ "Test value: " ++ show n + if n < $NUMFUN * 30 + then costCenter1 n + else putStrLn $ "Test value: " ++ show n EOF View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea1fcd3ec7360577d5f0ba9584283a9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea1fcd3ec7360577d5f0ba9584283a9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/backtraces-decoders] 5 commits: level imports: Check the level of exported identifiers
by Hannes Siebenhandl (＠fendor) 07 Aug '25

07 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: 246b7853 by Matthew Pickering at 2025-08-07T06:58:30-04:00 level imports: Check the level of exported identifiers The level imports specification states that exported identifiers have to be at level 0. This patch adds the requird level checks that all explicitly mentioned identifiers occur at level 0. For implicit export specifications (T(..) and module B), only level 0 identifiers are selected for re-export. ghc-proposal: https://github.com/ghc-proposals/ghc-proposals/pull/705 Fixes #26090 - - - - - 358bc4fc by fendor at 2025-08-07T06:59:12-04:00 Bump GHC on darwin CI to 9.10.1 - - - - - 506bfdbb by fendor at 2025-08-07T15:10:25+02:00 Store `StackTrace` and `StackSnapshot` in `Backtraces` Instead of decoding the stack traces when collecting the `Backtraces`, defer this decoding until actually showing the `Backtraces`. This allows users to customise how `Backtraces` are displayed by using a custom implementation of `displayExceptionWithInfo`, overwriting the default implementation for `Backtraces` (`displayBacktraces`). - - - - - 303af8e9 by fendor at 2025-08-07T15:44:32+02:00 Allow users to customise the collection of exception annotations Add a global `CollectExceptionAnnotationMechanism` which determines how `ExceptionAnnotation`s are collected upon throwing an `Exception`. This API is exposed via `ghc-experimental`. By overriding how we collect `Backtraces`, we can control how the `Backtraces` are displayed to the user by newtyping `Backtraces` and giving a different instance for `ExceptionAnnotation`. A concrete use-case for this feature is allowing us to experiment with alternative stack decoders, without having to modify `base`, which take additional information from the stack frames. This commit does not modify how `Backtraces` are currently collected or displayed. - - - - - 3e446ba3 by fendor at 2025-08-07T15:44:32+02:00 Expose Backtraces internals from ghc-experimental Additionally, expose the same API `base:Control.Exception.Backtrace` to make it easier to use as a drop-in replacement. - - - - - 50 changed files: - .gitlab/darwin/toolchain.nix - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Name/Reader.hs - + libraries/ghc-experimental/src/GHC/Exception/Backtrace/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - + libraries/ghc-internal/tests/Makefile - + libraries/ghc-internal/tests/all.T - + libraries/ghc-internal/tests/backtraces/Makefile - + libraries/ghc-internal/tests/backtraces/T14532a.hs - + libraries/ghc-internal/tests/backtraces/T14532a.stdout - + libraries/ghc-internal/tests/backtraces/T14532b.hs - + libraries/ghc-internal/tests/backtraces/T14532b.stdout - + libraries/ghc-internal/tests/backtraces/all.T - testsuite/tests/arrows/should_compile/T21301.stderr - testsuite/tests/deSugar/should_fail/DsStrictFail.stderr - testsuite/tests/deSugar/should_run/T20024.stderr - testsuite/tests/deSugar/should_run/dsrun005.stderr - testsuite/tests/deSugar/should_run/dsrun007.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - testsuite/tests/deriving/should_run/T9576.stderr - testsuite/tests/ghci/scripts/Defer02.stderr - testsuite/tests/ghci/scripts/T15325.stderr - testsuite/tests/patsyn/should_run/ghci.stderr - testsuite/tests/quotes/LiftErrMsgDefer.stderr - testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr - + testsuite/tests/splice-imports/DodgyLevelExport.hs - + testsuite/tests/splice-imports/DodgyLevelExport.stderr - + testsuite/tests/splice-imports/DodgyLevelExportA.hs - + testsuite/tests/splice-imports/LevelImportExports.hs - + testsuite/tests/splice-imports/LevelImportExports.stdout - + testsuite/tests/splice-imports/LevelImportExportsA.hs - testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/ModuleExport.hs - + testsuite/tests/splice-imports/ModuleExport.stderr - + testsuite/tests/splice-imports/ModuleExportA.hs - + testsuite/tests/splice-imports/ModuleExportB.hs - + testsuite/tests/splice-imports/T26090.hs - + testsuite/tests/splice-imports/T26090.stderr - + testsuite/tests/splice-imports/T26090A.hs - testsuite/tests/splice-imports/all.T - testsuite/tests/type-data/should_run/T22332a.stderr - testsuite/tests/typecheck/should_run/T10284.stderr - testsuite/tests/typecheck/should_run/T13838.stderr - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - testsuite/tests/unsatisfiable/T23816.stderr - testsuite/tests/unsatisfiable/UnsatDefer.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/348b6114e17413cffba5be424acf24… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/348b6114e17413cffba5be424acf24… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sol/lint-messages] Refactoring: Don't misuse `MCDiagnostic` for lint messages
by Simon Hengel (＠sol) 07 Aug '25

07 Aug '25

Simon Hengel pushed to branch wip/sol/lint-messages at Glasgow Haskell Compiler / GHC Commits: df98922c by Simon Hengel at 2025-08-07T17:32:17+07:00 Refactoring: Don't misuse `MCDiagnostic` for lint messages `MCDiagnostic` is meant to be used for compiler diagnostics. Any code that creates `MCDiagnostic` directly, without going through `GHC.Driver.Errors.printMessage`, side steps `-fdiagnostics-as-json` (see e.g. !14475, !14492 !14548). To avoid this in the future I want to control more narrowly who creates `MCDiagnostic` (see #24113). Some parts of the compiler use `MCDiagnostic` purely for formatting purposes, without creating any real compiler diagnostics. This change introduces a helper function, `formatDiagnostic`, that can be used in such cases instead of constructing `MCDiagnostic`. - - - - - 4 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Error.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -3418,7 +3418,7 @@ addMsg show_context env msgs msg [] -> noSrcSpan (s:_) -> s !diag_opts = le_diagOpts env - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span + mk_msg msg = mkLintWarning diag_opts msg_span (msg $$ context) addLoc :: LintLocInfo -> LintM a -> LintM a ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -107,7 +107,6 @@ import GHC.Core.Type import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) -import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) @@ -116,7 +115,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Logger import GHC.Utils.Outputable -import GHC.Utils.Error ( mkLocMessage, DiagOpts ) +import GHC.Utils.Error ( DiagOpts ) import qualified GHC.Utils.Error as Err import GHC.Unit.Module ( Module ) @@ -540,7 +539,7 @@ addErr diag_opts errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) + in Err.mkLintWarning diag_opts l (hdr $$ msg) mk_msg [] = msg ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -72,6 +72,7 @@ module GHC.Types.Error , pprMessageBag , mkLocMessage , mkLocMessageWarningGroups + , formatDiagnostic , getCaretDiagnostic , jsonDiagnostic @@ -495,11 +496,11 @@ data MessageClass -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, - -- users are encouraged to use the 'mkMCDiagnostic' smart constructor + -- users are encouraged to use higher level primitives -- instead. Use this constructor directly only if you need to construct -- and manipulate diagnostic messages directly, for example inside -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when - -- emitting compiler diagnostics, use the smart constructor. + -- emitting compiler diagnostics, use higher level primitives. -- -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for -- this diagnostic. If you are creating a message not tied to any @@ -656,32 +657,51 @@ mkLocMessageWarningGroups -> SrcSpan -- ^ location -> SDoc -- ^ message -> SDoc - -- Always print the location, even if it is unhelpful. Error messages - -- are supposed to be in a standard format, and one without a location - -- would look strange. Better to say explicitly "<no location info>". mkLocMessageWarningGroups show_warn_groups msg_class locn msg - = sdocOption sdocColScheme $ \col_scheme -> - let locn' = sdocOption sdocErrorSpans $ \case - True -> ppr locn - False -> ppr (srcSpanStart locn) - + = case msg_class of + MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg + _ -> sdocOption sdocColScheme $ \col_scheme -> + let msg_colour = getMessageClassColour msg_class col_scheme - col = coloured msg_colour . text msg_title = coloured msg_colour $ case msg_class of - MCDiagnostic SevError _ _ -> text "error" - MCDiagnostic SevWarning _ _ -> text "warning" MCFatal -> text "fatal" _ -> empty + in formatLocMessageWarningGroups locn msg_title empty empty msg + +formatDiagnostic + :: Bool -- ^ Print warning groups? + -> SrcSpan -- ^ location + -> Severity + -> ResolvedDiagnosticReason + -> Maybe DiagnosticCode + -> SDoc -- ^ message + -> SDoc +formatDiagnostic show_warn_groups locn severity reason code msg + = sdocOption sdocColScheme $ \col_scheme -> + let + msg_colour :: Col.PprColour + msg_colour = getSeverityColour severity col_scheme + + col :: String -> SDoc + col = coloured msg_colour . text + + msg_title :: SDoc + msg_title = coloured msg_colour $ + case severity of + SevError -> text "error" + SevWarning -> text "warning" + SevIgnore -> empty + + warning_flag_doc :: SDoc warning_flag_doc = - case msg_class of - MCDiagnostic sev reason _code - | Just msg <- flag_msg sev (resolvedDiagnosticReason reason) - -> brackets msg - _ -> empty + case flag_msg severity (resolvedDiagnosticReason reason) of + Nothing -> empty + Just msg -> brackets msg + ppr_with_hyperlink :: DiagnosticCode -> SDoc ppr_with_hyperlink code = -- this is a bit hacky, but we assume that if the terminal supports colors -- then it should also support links @@ -691,10 +711,11 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg then ppr $ LinkedDiagCode code else ppr code + code_doc :: SDoc code_doc = - case msg_class of - MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code) - _ -> empty + case code of + Just code -> brackets (ppr_with_hyperlink code) + Nothing -> empty flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc flag_msg SevIgnore _ = Nothing @@ -725,13 +746,35 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg vcat [ text "locn:" <+> ppr locn , text "msg:" <+> ppr msg ] + warn_flag_grp :: [WarningGroup] -> SDoc warn_flag_grp groups | show_warn_groups, not (null groups) = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")" | otherwise = empty + in formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg + +formatLocMessageWarningGroups + :: SrcSpan -- ^ location + -> SDoc -- ^ title + -> SDoc -- ^ diagnostic code + -> SDoc -- ^ warning groups + -> SDoc -- ^ message + -> SDoc +formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg + = sdocOption sdocColScheme $ \col_scheme -> + let + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "<no location info>". + locn' :: SDoc + locn' = sdocOption sdocErrorSpans $ \case + True -> ppr locn + False -> ppr (srcSpanStart locn) + -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> + header :: SDoc header = locn' <> colon <+> msg_title <> colon <+> code_doc <+> warning_flag_doc @@ -741,11 +784,16 @@ mkLocMessageWarningGroups show_warn_groups msg_class locn msg msg) getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError -getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning +getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity getMessageClassColour MCFatal = Col.sFatal getMessageClassColour _ = const mempty +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour +getSeverityColour severity = case severity of + SevError -> Col.sError + SevWarning -> Col.sWarning + SevIgnore -> const mempty + getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic msg_class (RealSrcSpan span _) = ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Utils.Error ( emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, - mkMCDiagnostic, diagReasonSeverity, + mkLintWarning, diagReasonSeverity, mkPlainError, mkPlainDiagnostic, @@ -160,12 +160,10 @@ diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason o ErrorWithoutFlag -> (SevError, reason) --- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the --- 'DiagOpts'. -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass -mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code +mkLintWarning :: DiagOpts -> SrcSpan -> SDoc -> SDoc +mkLintWarning opts span = formatDiagnostic True span severity reason Nothing where - (sev, reason') = diag_reason_severity opts reason + (severity, reason) = diag_reason_severity opts WarningWithoutFlag -- -- Creating MsgEnvelope(s) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df98922cb9e8a4590c6c979916cb436… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/df98922cb9e8a4590c6c979916cb436… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] Add primop to annotate the call stack with arbitrary data
by Hannes Siebenhandl (＠fendor) 07 Aug '25

07 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: 9e44bd39 by Ben Gamari at 2025-08-07T14:43:26+02:00 Add primop to annotate the call stack with arbitrary data We introduce a new primop `annotateStack#` which allows us to push arbitrary data onto the call-stack. This allows us to extract the data later when decoding the stack, for example when an exception is thrown, showing more information to the user without having to annotate the full call-stack with `HasCallStack` constraints. A new stack frame value is introduced `AnnFrame`, which consists of nothing but a generic payload. The primop has a small wrapper API that allows users to annotate their call-stack in programs. There is a pure API and an IO-based one. The former is a little bit dubious, as it affects the evaluation of a program, so use with care. The latter is "safe", as it doesn't change the evaluation of the program. The stack annotation mechanism is similarly implemented to the `ExceptionAnnotation` and `Exception`, there is a typeclass to indicate something can be pushed onto the call-stack and all values are wrapped in the existential `SomeStackAnnotation`, which recover the type of the annotation payload. There is currently no builtin way to show the stack annotations when `Backtraces` are displayed (i.e., when showing stack traces to the user), which we will address in a follow-up MR. ------------------------- Metric Increase: ghc_experimental_so ------------------------- We increase the size of the package, so this is not unreasonable. Co-Authored-By: fendor <fendor(a)posteo.de> Co-Authored-By: Ben Gamari <bgamari.foss(a)gmail.com> - - - - - 47 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Stack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - + libraries/ghc-heap/tests/stack-annotation/Makefile - + libraries/ghc-heap/tests/stack-annotation/TestUtils.hs - + libraries/ghc-heap/tests/stack-annotation/all.T - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs - + libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout - libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs - rts/ClosureFlags.c - rts/LdvProfile.c - rts/PrimOps.cmm - rts/Printer.c - rts/RetainerProfile.c - rts/RtsSymbols.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureTypes.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/js/profiling.js - rts/sm/Compact.c - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - 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 - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e44bd391095c899f309c3a6024f795… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e44bd391095c899f309c3a6024f795… You're receiving this email because of your account on gitlab.haskell.org.

1 0