- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fix-26109] 7 commits: ipe: Place strings and metadata into specific .ipe section
by recursion-ninja (＠recursion-ninja) 08 Aug '25

08 Aug '25

recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-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! - - - - - 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - b3c31488 by David Feuer at 2025-08-08T15:33:21-04: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. - - - - - 767d6516 by Recursion Ninja at 2025-08-08T17:38:37-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# - - - - - 32 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - docs/users_guide/debug-info.rst - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - rts/IPE.c - rts/ProfHeap.c - rts/eventlog/EventLog.c - rts/include/rts/IPE.h - testsuite/tests/interface-stability/template-haskell-exports.stdout - + 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/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - utils/genprimopcode/Lexer.x - utils/genprimopcode/Main.hs - utils/genprimopcode/Parser.y - utils/genprimopcode/ParserM.hs - utils/genprimopcode/Syntax.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a9ec9d90a4228702fe995cd989769… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3a9ec9d90a4228702fe995cd989769… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26109] 2 commits: Moving 'LowerBitsAreDefined' out of the autogenerated portion of the file
by recursion-ninja (＠recursion-ninja) 08 Aug '25

08 Aug '25

recursion-ninja pushed to branch wip/fix-26109 at Glasgow Haskell Compiler / GHC Commits: a522e725 by Recursion Ninja at 2025-08-08T13:33:17-04:00 Moving 'LowerBitsAreDefined' out of the autogenerated portion of the file - - - - - 3a9ec9d9 by Recursion Ninja at 2025-08-08T16:49:26-04:00 Partial extension of 'genprimopcode' to support 'LowerBitsAreDefined' - - - - - 7 changed files: - compiler/GHC/Builtin/primops.txt.pp - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Lexer.x - utils/genprimopcode/Main.hs - utils/genprimopcode/Parser.y - utils/genprimopcode/ParserM.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -148,6 +148,7 @@ defaults vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation div_like = False -- Second argument expected to be non zero - used for tests + defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) -- Note [When do out-of-line primops go in primops.txt.pp] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1065,8 +1066,10 @@ primop CtzOp "ctz#" GenPrimOp Word# -> Word# primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } + with defined_bits = 16 primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } + with defined_bits = 32 primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# {Swap bytes in a 64 bits of a word.} primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# @@ -1074,10 +1077,13 @@ primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 8-bit word.} + with defined_bits = 8 primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 16-bit word.} + with defined_bits = 16 primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# {Reverse the order of the bits in a 32-bit word.} + with defined_bits = 32 primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# {Reverse the order of the bits in a 64-bit word.} primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -409,6 +409,33 @@ instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2) -} +-- | 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 twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b twoNonZero f x (NonZero y) = f x y @@ -673,34 +700,6 @@ 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) ===================================== utils/genprimopcode/Lexer.x ===================================== @@ -56,6 +56,7 @@ words :- <0> "CanFail" { mkT TCanFail } <0> "ThrowsException" { mkT TThrowsException } <0> "ReadWriteEffect" { mkT TReadWriteEffect } + <0> "defined_bits" { mkT TDefinedBits } <0> "can_fail_warning" { mkT TCanFailWarnFlag } <0> "DoNotWarnCanFail" { mkT TDoNotWarnCanFail } <0> "WarnIfEffectIsCanFail" { mkT TWarnIfEffectIsCanFail } ===================================== utils/genprimopcode/Main.hs ===================================== @@ -10,6 +10,7 @@ module Main where import Parser import Syntax +import Control.Applicative (asum) import Data.Char import Data.List (union, intersperse, intercalate, nub, sort) import Data.Maybe ( catMaybes, mapMaybe ) @@ -753,7 +754,14 @@ gen_foundation_tests (Info _ entries) = let testPrimOpHow = if is_divLikeOp po then "testPrimopDivLike" else "testPrimop" - in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName] + withDefinedBits qName = case mb_defined_bits po of + Nothing -> qName + Just bs -> concat ["(", show bs, " `LowerBitsAreDefined` ", qName, ")"] + in Just $ intercalate " " + [ testPrimOpHow + , "\"" ++ poName ++ "\"" + , withDefinedBits $ wrap "Primop" poName + , withDefinedBits $ wrap "Wrapper" poName] | otherwise = Nothing @@ -771,6 +779,17 @@ gen_foundation_tests (Info _ entries) divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" ,"Int8#", "Int16#", "Int32#", "Int64#"] + + mb_defined_bits :: Entry -> Maybe Word + mb_defined_bits op@(PrimOpSpec{}) = + let opOpts = opts op + getDefBits :: Option -> Maybe Word + getDefBits (OptionDefinedBits x) = x + getDefBits _ = Nothing + in asum $ getDefBits <$> opOpts + mb_defined_bits _ = Nothing + + ------------------------------------------------------------------ -- Create PrimOpInfo text from PrimOpSpecs ----------------------- ------------------------------------------------------------------ ===================================== utils/genprimopcode/Parser.y ===================================== @@ -50,6 +50,7 @@ import AccessOps CanFail { TCanFail } ThrowsException { TThrowsException } ReadWriteEffect { TReadWriteEffect } + defined_bits { TDefinedBits } can_fail_warning { TCanFailWarnFlag } DoNotWarnCanFail { TDoNotWarnCanFail } WarnIfEffectIsCanFail { TWarnIfEffectIsCanFail } @@ -81,13 +82,14 @@ pOptions : pOption pOptions { $1 : $2 } | {- empty -} { [] } pOption :: { Option } -pOption : lowerName '=' false { OptionFalse $1 } - | lowerName '=' true { OptionTrue $1 } - | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } - | lowerName '=' integer { OptionInteger $1 $3 } - | vector '=' pVectorTemplate { OptionVector $3 } - | fixity '=' pInfix { OptionFixity $3 } - | effect '=' pEffect { OptionEffect $3 } +pOption : lowerName '=' false { OptionFalse $1 } + | lowerName '=' true { OptionTrue $1 } + | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } + | lowerName '=' integer { OptionInteger $1 $3 } + | vector '=' pVectorTemplate { OptionVector $3 } + | fixity '=' pInfix { OptionFixity $3 } + | effect '=' pEffect { OptionEffect $3 } + | defined_bits '=' pGoodBits { OptionDefinedBits $3 } | can_fail_warning '=' pPrimOpCanFailWarnFlag { OptionCanFailWarnFlag $3 } pInfix :: { Maybe Fixity } @@ -102,6 +104,10 @@ pEffect : NoEffect { NoEffect } | ThrowsException { ThrowsException } | ReadWriteEffect { ReadWriteEffect } +pGoodBits :: { Maybe Word } +pGoodBits : integer { Just $ toEnum $1 } + | nothing { Nothing } + pPrimOpCanFailWarnFlag :: { PrimOpCanFailWarnFlag } pPrimOpCanFailWarnFlag : DoNotWarnCanFail { DoNotWarnCanFail } | WarnIfEffectIsCanFail { WarnIfEffectIsCanFail } ===================================== utils/genprimopcode/ParserM.hs ===================================== @@ -116,6 +116,7 @@ data Token = TEOF | TCanFail | TThrowsException | TReadWriteEffect + | TDefinedBits | TCanFailWarnFlag | TDoNotWarnCanFail | TWarnIfEffectIsCanFail ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -76,6 +76,7 @@ data Option | OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing | OptionEffect PrimOpEffect -- effect = NoEffect | DoNotSpeculate | CanFail | ThrowsException | ReadWriteEffect | FallibleReadWriteEffect | OptionCanFailWarnFlag PrimOpCanFailWarnFlag -- can_fail_warning = DoNotWarnCanFail | WarnIfEffectIsCanFail | YesWarnCanFail + | OptionDefinedBits (Maybe Word) -- defined_bits = Just 16 | Nothing deriving Show -- categorises primops @@ -196,6 +197,7 @@ get_attrib_name (OptionVector _) = "vector" get_attrib_name (OptionFixity _) = "fixity" get_attrib_name (OptionEffect _) = "effect" get_attrib_name (OptionCanFailWarnFlag _) = "can_fail_warning" +get_attrib_name (OptionDefinedBits _) = "defined_bits" lookup_attrib :: String -> [Option] -> Maybe Option lookup_attrib _ [] = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/224fb5bd5e724226e1f9a2783cbf1c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/224fb5bd5e724226e1f9a2783cbf1c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/warning-for-last-and-init] 7 commits: ipe: Place strings and metadata into specific .ipe section
by Bodigrim (＠Bodigrim) 08 Aug '25

08 Aug '25

Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-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! - - - - - 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - b3c31488 by David Feuer at 2025-08-08T15:33:21-04: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. - - - - - 9d61b626 by Mike Pilgrem at 2025-08-08T21:32:40+01:00 Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`). In module `Settings.Warnings`, applies `-Wno-unrecognised-warning-flags` `-Wno-x-partial` to the `Cabal`, `filepath`, `hsc2hs`, `hpc`, `parsec`, `text` and `time` packages (outside GHC's repository). - - - - - 46 changed files: - compiler/GHC/Cmm.hs - compiler/GHC/CmmToAsm/PPC/Ppr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Prelude/Basic.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - docs/users_guide/debug-info.rst - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Warnings.hs - libraries/Cabal - libraries/filepath - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/template-haskell/Language/Haskell/TH/Quote.hs - libraries/template-haskell/changelog.md - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - rts/IPE.c - rts/ProfHeap.c - rts/eventlog/EventLog.c - rts/include/rts/IPE.h - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/rts/KeepCafsBase.hs - testsuite/tests/rts/ipe/ipeMap.c - testsuite/tests/rts/ipe/ipe_lib.c - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/hpc - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f477db5713add8656ae37b3ef8023a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f477db5713add8656ae37b3ef8023a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add default QuasiQuoters
by Marge Bot (＠marge-bot) 08 Aug '25

08 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b3c31488 by David Feuer at 2025-08-08T15:33:21-04: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/b3c3148806014e3c36fc91b8710c46d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3c3148806014e3c36fc91b8710c46d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] hadrian: enable terminfo if --with-curses-* flags are given
by Marge Bot (＠marge-bot) 08 Aug '25

08 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2157db2d by sterni at 2025-08-08T15:32:39-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - 2 changed files: - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs Changes: ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -80,6 +80,7 @@ stageBootPackages = return stage0Packages :: Action [Package] stage0Packages = do cross <- flag CrossCompiling + haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] return $ [ cabalSyntax , cabal , compiler @@ -116,8 +117,8 @@ stage0Packages = do -- that confused Hadrian, so we must make those a stage0 package as well. -- Once we drop `Win32`/`unix` it should be possible to drop those too. ] - ++ [ terminfo | not windowsHost, not cross ] - ++ [ timeout | windowsHost ] + ++ [ terminfo | not windowsHost, (not cross || haveCurses) ] + ++ [ timeout | windowsHost ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". stage1Packages :: Action [Package] ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -24,6 +24,7 @@ packageArgs = do -- immediately and may lead to cyclic dependencies. -- See: https://gitlab.haskell.org/ghc/ghc/issues/16809. cross = flag CrossCompiling + haveCurses = any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] -- Check if the bootstrap compiler has the same version as the one we -- are building. This is used to build cross-compilers @@ -85,7 +86,7 @@ packageArgs = do -- backends at the moment, so we might as well disable it -- for cross GHC. [ andM [expr (ghcWithInterpreter stage), notCross] `cabalFlag` "internal-interpreter" - , notM cross `cabalFlag` "terminfo" + , orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" , arg "-build-tool-depends" , flag UseLibzstd `cabalFlag` "with-libzstd" -- ROMES: While the boot compiler is not updated wrt -this-unit-id @@ -120,7 +121,7 @@ packageArgs = do -------------------------------- ghcPkg -------------------------------- , package ghcPkg ? - builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo" + builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" -------------------------------- ghcBoot ------------------------------ , package ghcBoot ? @@ -202,10 +203,10 @@ packageArgs = do , package haskeline ? builder (Cabal Flags) ? arg "-examples" -- Don't depend upon terminfo when cross-compiling to avoid unnecessary - -- dependencies. - -- TODO: Perhaps the user should rather be responsible for this? + -- dependencies unless the user provided ncurses explicitly. + -- TODO: Perhaps the user should be able to explicitly enable/disable this. , package haskeline ? - builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo" + builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" -------------------------------- terminfo ------------------------------ , package terminfo ? View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2157db2d5da391ca77eac156a6787e1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2157db2d5da391ca77eac156a6787e1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new tag ghc-9.10.3-rc3
by Zubin (＠wz1000) 08 Aug '25

08 Aug '25

Zubin pushed new tag ghc-9.10.3-rc3 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/ghc-9.10.3-rc3 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] 2 commits: Wibbles solver
by Simon Peyton Jones (＠simonpj) 08 Aug '25

08 Aug '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 5880fb11 by Simon Peyton Jones at 2025-08-08T17:05:39+01:00 Wibbles solver Iterate the simples more often than plugins - - - - - b9dbfd95 by Simon Peyton Jones at 2025-08-08T17:06:00+01:00 Improve pretty printer for HsExpr Given a very deeply-nested application, it just kept printing deeper and deeper. This small change makes it cut off. - - - - - 3 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Types/Basic.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -862,11 +862,9 @@ ppr_expr (HsOverLabel s l) = case ghcPass @p of ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsPar _ e) = parens (ppr_lexpr e) - -ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] +ppr_expr e@(HsApp {}) = pprApp e +ppr_expr e@(HsAppType {}) = pprApp e ppr_expr (OpApp _ e1 op e2) | Just pp_op <- ppr_infix_expr (unLoc op) @@ -1134,21 +1132,21 @@ ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e ppr_infix_hs_expansion _ = Nothing -ppr_apps :: (OutputableBndrId p) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] - -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args - = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) +pprApp :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc +pprApp app + = go app [] -- Collect arguments and print all at once where - pp (Left arg) = ppr arg - -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - -- = char '@' <> pprHsType arg - pp (Right arg) - = text "@" <> ppr arg + go fun args + = case fun of + HsApp _ (L _ fun') arg -> go fun' (Left arg : args) + HsAppType _ (L _ fun') arg -> go fun' (Right arg : args) + _ -> ppr_app fun args + + ppr_app fun args = hang (ppr_expr fun) + 2 (pprDeeper (fsep (map pp args))) + + pp (Left arg) = ppr arg + pp (Right arg) = text "@" <> ppr arg pprDebugParendExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Types.Id( idType ) import GHC.Types.Var( EvVar, tyVarKind ) import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Types.Basic ( IntWithInf, mulWithInf, intGtLimit ) import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet ) import GHC.Data.Bag @@ -1043,49 +1043,55 @@ solveSimpleGivens givens solveSimpleWanteds :: Cts -> TcS Cts -- The result is not necessarily zonked -solveSimpleWanteds simples +solveSimpleWanteds wc = do { mode <- getTcSMode ; dflags <- getDynFlags ; inerts <- getInertSet + ; let iteration_count_flag = solverIterations dflags ; traceTcS "solveSimpleWanteds {" $ vcat [ text "Mode:" <+> ppr mode , text "Inerts:" <+> ppr inerts - , text "Wanteds to solve:" <+> ppr simples ] + , text "Wanteds to solve:" <+> ppr wc ] - ; (n,wc) <- go 1 (solverIterations dflags) simples + ; wc1 <- iterateToFixpoint iteration_count_flag + (do_solve_and_plugins iteration_count_flag) wc ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } + vcat [ text "residual =" <+> ppr wc1 ] + ; return wc1 } where - go :: Int -> IntWithInf -> Cts -> TcS (Int, Cts) - -- See Note [The solveSimpleWanteds loop] - go n limit wc + do_solve_and_plugins :: IntWithInf -> Cts -> TcS (Bool,Cts) + do_solve_and_plugins icf wc + = do { wc1 <- iterateToFixpoint (icf `mulWithInf` 10) + do_solve wc + ; runTcPluginsWanted wc1 } + + do_solve :: Cts -> TcS (Bool,Cts) + -- Try this repeatedly, until no unifications happen + -- This is potentially quadratic, because we might solve just one + -- constraint in each iteration but that seems inevitable + do_solve wc = reportUnifications (solve_simple_wanteds wc) + + +iterateToFixpoint :: IntWithInf -> (Cts -> TcS (Bool,Cts)) -> Cts -> TcS Cts +-- See Note [The solveSimpleWanteds loop] +iterateToFixpoint limit do_it wc_orig + = go 1 wc_orig + where + go n wc | isEmptyBag wc - = return (n,wc) + = return wc | n `intGtLimit` limit = failTcS $ TcRnSimplifierTooManyIterations - simples limit (emptyWC { wc_simple = wc }) - | otherwise - = do { -- Solve - traceUnificationFlag "solveSimpleWanteds1" - ; (unif_happened, wc1) <- reportUnifications $ - solve_simple_wanteds wc - ; traceUnificationFlag "solveSimpleWanteds2" - - -- Run plugins - -- NB: runTcPluginsWanted has a fast path for empty wc1, - -- which is the common case - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - - ; if unif_happened || rerun_plugin - then do { traceTcS "solveSimple going round again:" empty - ; go (n+1) limit wc2 } -- Loop - else return (n, wc2) } -- Done + wc_orig limit (emptyWC { wc_simple = wc }) + | otherwise + = do { (something_happened, wc1) <- do_it wc + ; if something_happened + then go (n+1) wc1 + else return wc1 } solve_simple_wanteds :: Cts -> TcS Cts -- Try solving these constraints ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -109,7 +109,8 @@ module GHC.Types.Basic ( SuccessFlag(..), succeeded, failed, successIf, - IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, + intGtLimit, subWithInf, mulWithInf, TypeOrKind(..), isTypeLevel, isKindLevel, @@ -2114,8 +2115,8 @@ instance Outputable IntWithInf where ppr (Int n) = int n instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf + (+) = plusWithInf2 + (*) = mulWithInf2 abs Infinity = Infinity abs (Int n) = Int (abs n) @@ -2132,16 +2133,21 @@ intGtLimit _ Infinity = False intGtLimit n (Int m) = n > m -- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) +plusWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf2 Infinity _ = Infinity +plusWithInf2 _ Infinity = Infinity +plusWithInf2 (Int a) (Int b) = Int (a + b) -- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) +mulWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf2 Infinity _ = Infinity +mulWithInf2 _ Infinity = Infinity +mulWithInf2 (Int a) (Int b) = Int (a * b) + +-- | Multiply an 'IntWithInfo` by an 'Int' +mulWithInf :: IntWithInf -> Int -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf (Int a) b = Int (a * b) -- | Subtract an 'Int' from an 'IntWithInf' subWithInf :: IntWithInf -> Int -> IntWithInf @@ -2461,4 +2467,4 @@ convImportLevel NotLevelled = NormalLevel convImportLevelSpec :: ImportDeclLevel -> ImportLevel convImportLevelSpec ImportDeclQuote = QuoteLevel -convImportLevelSpec ImportDeclSplice = SpliceLevel \ No newline at end of file +convImportLevelSpec ImportDeclSplice = SpliceLevel View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b5b238b121b19600e5c0a88d90cea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b5b238b121b19600e5c0a88d90cea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: In TcSShortCut, typechecker plugins should get empty Givens
by Marge Bot (＠marge-bot) 08 Aug '25

08 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2860a9a5 by Simon Peyton Jones at 2025-08-07T20:29:18-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! - - - - - 2a5a3d24 by sterni at 2025-08-08T10:52:08-04:00 hadrian: enable terminfo if --with-curses-* flags are given The GHC make build system used to support WITH_TERMINFO in ghc.mk which allowed controlling whether to build GHC with terminfo or not. hadrian has replaced this with a system where this is effectively controlled by the cross-compiling setting (the default WITH_TERMINFO value was bassed on CrossCompiling, iirc). This behavior is undesireable in some cases and there is not really a good way to work around it. Especially for downstream packagers, modifying this via UserSettings is not really feasible since such a source file has to be kept in sync with Settings/Default.hs manually since it can't import Settings.Default or any predefined Flavour definitions. To avoid having to add a new setting to cfg/system.config and/or a new configure flag (though I'm happy to implement both if required), I've chosen to take --with-curses-* being set explicitly as an indication that the user wants to have terminfo enabled. This would work for Nixpkgs which sets these flags [1] as well as haskell.nix [2] (which goes to some extreme measures [3] [4] to force terminfo in all scenarios). In general, I'm an advocate for making the GHC build be the same for native and cross insofar it is possible since it makes packaging GHC and Haskell related things while still supporting cross much less compilicated. A more minimal GHC with reduced dependencies should probably be a specific flavor, not the default. Partially addresses #26288 by forcing terminfo to be built if the user explicitly passes configure flags related to it. However, it isn't built by default when cross-compiling yet nor is there an explicit way to control the package being built. [1]: https://github.com/NixOS/nixpkgs/blob/3a7266fcefcb9ce353df49ba3f292d0644376… [2]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [3]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… [4]: https://github.com/input-output-hk/haskell.nix/blob/6eaafcdf04bab7be745d1aa… - - - - - 8a29fee7 by David Feuer at 2025-08-08T10:52:09-04: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. - - - - - 9 changed files: - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - 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: ===================================== compiler/GHC/Tc/Solver/Dict.hs ===================================== @@ -496,11 +496,15 @@ We could use the Eq [a] superclass of the Ord [a], or we could use the top-level instance `Eq a => Eq [a]`. But if we did the latter we'd be stuck with an insoluble constraint (Eq a). -So the ShortCutSolving rule is this: +----------------------------------- +So the ShortCutSolving plan is this: If we could solve a constraint from a local Given, - try first to /completely/ solve the constraint using only top-level instances. + try first to /completely/ solve the constraint + using only top-level instances, + /without/ using any local Givens. - If that succeeds, use it - If not, use the local Given +----------------------------------- An example that succeeds: @@ -555,7 +559,7 @@ The moving parts are relatively simple: - `matchLocalInst`, which would otherwise consult Given quantified constraints - `GHC.Tc.Solver.Instance.Class.matchInstEnv`: when short-cut solving, don't pick overlappable top-level instances - + - `GHC.Tc.Solver.Solve.runTcPluginsWanted`: don't pass any Givens to the plugin Some wrinkles: ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -897,7 +897,9 @@ for it, so TcS carries a mutable location where the binding can be added. This is initialised from the innermost implication constraint. -} --- | See Note [TcSMode] +-- | The mode for the constraint solving monad. +-- +-- See Note [TcSMode], where each constructor is documented data TcSMode = TcSVanilla -- ^ Normal constraint solving | TcSPMCheck -- ^ Used when doing patterm match overlap checks @@ -905,6 +907,12 @@ data TcSMode | TcSShortCut -- ^ Fully solve all constraints, without using local Givens deriving (Eq) +instance Outputable TcSMode where + ppr TcSVanilla = text "TcSVanilla" + ppr TcSPMCheck = text "TcSPMCheck" + ppr TcSEarlyAbort = text "TcSEarlyAbort" + ppr TcSShortCut = text "TcSShortcut" + {- Note [TcSMode] ~~~~~~~~~~~~~~~~~ The constraint solver can operate in different modes: ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -1011,9 +1011,17 @@ solveSimpleGivens givens solveSimpleWanteds :: Cts -> TcS Cts -- The result is not necessarily zonked solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) + = do { mode <- getTcSMode ; dflags <- getDynFlags + ; inerts <- getInertSet + + ; traceTcS "solveSimpleWanteds {" $ + vcat [ text "Mode:" <+> ppr mode + , text "Inerts:" <+> ppr inerts + , text "Wanteds to solve:" <+> ppr simples ] + ; (n,wc) <- go 1 (solverIterations dflags) simples + ; traceTcS "solveSimpleWanteds end }" $ vcat [ text "iterations =" <+> ppr n , text "residual =" <+> ppr wc ] @@ -1663,19 +1671,28 @@ runTcPluginsGiven -- 'solveSimpleWanteds' should feed the updated wanteds back into the -- main solver. runTcPluginsWanted :: Cts -> TcS (Bool, Cts) -runTcPluginsWanted simples1 - | isEmptyBag simples1 - = return (False, simples1) +runTcPluginsWanted wanted + | isEmptyBag wanted + = return (False, wanted) | otherwise = do { solvers <- getTcPluginSolvers - ; if null solvers then return (False, simples1) else - - do { given <- getInertGivens - ; wanted <- TcS.zonkSimples simples1 -- Plugin requires zonked inputs - - ; traceTcS "Running plugins (" (vcat [ text "Given:" <+> ppr given - , text "Wanted:" <+> ppr wanted ]) - ; p <- runTcPluginSolvers solvers (given, bagToList wanted) + ; if null solvers then return (False, wanted) else + + do { -- Find the set of Givens to give to the plugin. + -- If TcSMode = TcSShortCut, we are solving with + -- no Givens so don't return any (#26258)! + -- See Note [Shortcut solving] in GHC.Tc.Solver.Dict + mode <- getTcSMode + ; given <- case mode of + TcSShortCut -> return [] + _ -> getInertGivens + + -- Plugin requires zonked input wanteds + ; zonked_wanted <- TcS.zonkSimples wanted + + ; traceTcS "Running plugins {" (vcat [ text "Given:" <+> ppr given + , text "Wanted:" <+> ppr zonked_wanted ]) + ; p <- runTcPluginSolvers solvers (given, bagToList zonked_wanted) ; let (_, solved_wanted) = pluginSolvedCts p (_, unsolved_wanted) = pluginInputCts p new_wanted = pluginNewCts p @@ -1684,9 +1701,6 @@ runTcPluginsWanted simples1 listToBag unsolved_wanted `andCts` listToBag insols --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens) - ; mapM_ setEv solved_wanted ; traceTcS "Finished plugins }" (ppr new_wanted) ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -80,6 +80,7 @@ stageBootPackages = return stage0Packages :: Action [Package] stage0Packages = do cross <- flag CrossCompiling + haveCurses <- any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] return $ [ cabalSyntax , cabal , compiler @@ -116,8 +117,8 @@ stage0Packages = do -- that confused Hadrian, so we must make those a stage0 package as well. -- Once we drop `Win32`/`unix` it should be possible to drop those too. ] - ++ [ terminfo | not windowsHost, not cross ] - ++ [ timeout | windowsHost ] + ++ [ terminfo | not windowsHost, (not cross || haveCurses) ] + ++ [ timeout | windowsHost ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". stage1Packages :: Action [Package] ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -24,6 +24,7 @@ packageArgs = do -- immediately and may lead to cyclic dependencies. -- See: https://gitlab.haskell.org/ghc/ghc/issues/16809. cross = flag CrossCompiling + haveCurses = any (/= "") <$> traverse setting [ CursesIncludeDir, CursesLibDir ] -- Check if the bootstrap compiler has the same version as the one we -- are building. This is used to build cross-compilers @@ -85,7 +86,7 @@ packageArgs = do -- backends at the moment, so we might as well disable it -- for cross GHC. [ andM [expr (ghcWithInterpreter stage), notCross] `cabalFlag` "internal-interpreter" - , notM cross `cabalFlag` "terminfo" + , orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" , arg "-build-tool-depends" , flag UseLibzstd `cabalFlag` "with-libzstd" -- ROMES: While the boot compiler is not updated wrt -this-unit-id @@ -120,7 +121,7 @@ packageArgs = do -------------------------------- ghcPkg -------------------------------- , package ghcPkg ? - builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo" + builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" -------------------------------- ghcBoot ------------------------------ , package ghcBoot ? @@ -202,10 +203,10 @@ packageArgs = do , package haskeline ? builder (Cabal Flags) ? arg "-examples" -- Don't depend upon terminfo when cross-compiling to avoid unnecessary - -- dependencies. - -- TODO: Perhaps the user should rather be responsible for this? + -- dependencies unless the user provided ncurses explicitly. + -- TODO: Perhaps the user should be able to explicitly enable/disable this. , package haskeline ? - builder (Cabal Flags) ? notM cross `cabalFlag` "terminfo" + builder (Cabal Flags) ? orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" -------------------------------- terminfo ------------------------------ , package terminfo ? ===================================== 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/-/compare/c7cf0aa9857b27696367e0cc3cf1b4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c7cf0aa9857b27696367e0cc3cf1b4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/linker_fix] rts: LoadArchive/LoadObj - refactor object verification.
by Andreas Klebinger (＠AndreasK) 08 Aug '25

08 Aug '25

Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC Commits: ae4264e7 by Andreas Klebinger at 2025-08-08T16:39:09+02:00 rts: LoadArchive/LoadObj - refactor object verification. If we have a potential image produced by mkOc in hand we now always call `verifyAndInitOc` to check for valid object code. This in turn calls out to the platform specific verification code. This means we no longer rely on the adhoc checking of magic numbers in loadArchive, instead using the verifyImage_* functions to recognize object code. On windows this adds loadArchive support for AArch64/32bit COFF bigobj files. - - - - - 6 changed files: - rts/Linker.c - rts/LinkerInternals.h - rts/linker/LoadArchive.c - rts/linker/MachO.c - rts/linker/MachO.h - rts/linker/PEi386.c Changes: ===================================== rts/Linker.c ===================================== @@ -1415,7 +1415,7 @@ preloadObjectFile (pathchar *path) // We calculate the correct alignment from the header before // reading the file, and then we misalign image on purpose so // that the actual sections end up aligned again. - misalignment = machoGetMisalignment(f); + machoGetMisalignment(f, &misalignment); image = stgMallocBytes(fileSize + misalignment, "loadObj(image)"); image += misalignment; @@ -1441,14 +1441,7 @@ preloadObjectFile (pathchar *path) /* FIXME (AP): =mapped= parameter unconditionally set to true */ oc = mkOc(STATIC_OBJECT, path, image, fileSize, true, NULL, misalignment); -#if defined(OBJFORMAT_MACHO) - if (ocVerifyImage_MachO( oc )) - ocInit_MachO( oc ); -#endif -#if defined(OBJFORMAT_ELF) - if(ocVerifyImage_ELF( oc )) - ocInit_ELF( oc ); -#endif + verifyAndInitOc(oc); return oc; } @@ -1505,27 +1498,44 @@ HsInt loadObj (pathchar *path) return r; } +// Call the relevant VeriffyImage_* and ocInit_* functions. +// Return 1 on success. +HsInt verifyAndInitOc (ObjectCode* oc) +{ + int r; + + IF_DEBUG(linker, ocDebugBelch(oc, "start\n")); + + /* verify the in-memory image */ +#if defined(OBJFORMAT_ELF) + r = ocVerifyImage_ELF ( oc ); + if(r) { + ocInit_ELF( oc ); + } +#elif defined(OBJFORMAT_PEi386) + r = ocVerifyImage_PEi386 ( oc ); +#elif defined(OBJFORMAT_MACHO) + r = ocVerifyImage_MachO ( oc ); + if(r) { + ocInit_MachO( oc ); + } +#else + barf("loadObj: no verify method"); +#endif + if (!r) { + IF_DEBUG(linker, ocDebugBelch(oc, "ocVerifyImage_* failed\n")); + return r; + } + return 1; +} + +// Precondition: oc already verified. HsInt loadOc (ObjectCode* oc) { int r; IF_DEBUG(linker, ocDebugBelch(oc, "start\n")); - /* verify the in-memory image */ -# if defined(OBJFORMAT_ELF) - r = ocVerifyImage_ELF ( oc ); -# elif defined(OBJFORMAT_PEi386) - r = ocVerifyImage_PEi386 ( oc ); -# elif defined(OBJFORMAT_MACHO) - r = ocVerifyImage_MachO ( oc ); -# else - barf("loadObj: no verify method"); -# endif - if (!r) { - IF_DEBUG(linker, ocDebugBelch(oc, "ocVerifyImage_* failed\n")); - return r; - } - /* Note [loadOc orderings] ~~~~~~~~~~~~~~~~~~~~~~~ The order of `ocAllocateExtras` and `ocGetNames` matters. For MachO ===================================== rts/LinkerInternals.h ===================================== @@ -485,12 +485,19 @@ HsInt loadArchive_ (pathchar *path); HsInt isAlreadyLoaded( pathchar *path ); OStatus getObjectLoadStatus_ (pathchar *path); ObjectCode *lookupObjectByPath(pathchar *path); + +/* Verify an objects is an a format that can be loaded and initialize the oc struct if required. */ +HsInt verifyAndInitOc( ObjectCode *oc ); + +//Expects the oc to be verified already. HsInt loadOc( ObjectCode* oc ); ObjectCode* mkOc( ObjectType type, pathchar *path, char *image, int imageSize, bool mapped, pathchar *archiveMemberName, int misalignment ); + + void initSegment(Segment *s, void *start, size_t size, SegmentProt prot, int n_sections); void freeSegments(ObjectCode *oc); ===================================== rts/linker/LoadArchive.c ===================================== @@ -110,56 +110,50 @@ static bool loadFatArchive(char input[static 20], FILE* f, pathchar* path) } #endif -enum ObjectFileFormat { - NotObject, - COFFAmd64, - COFFI386, - COFFAArch64, - ELF, - MachO32, - MachO64, -}; - -static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) -{ - if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { - return COFFAmd64; - } - if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { - return COFFI386; - } - if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { - return COFFAArch64; - } - if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { - return ELF; - } - if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { - return MachO32; - } - if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { - return MachO64; - } - // BigObj COFF files ... - if (sz > 8 && ((uint64_t*)buf)[0] == 0x86640002ffff0000) { - return COFFAmd64; - } - if (sz > 8 && ((uint64_t*)buf)[0] == 0x014c0002ffff0000) { - return COFFI386; - } - if (sz > 8 && ((uint64_t*)buf)[0] == 0xaa640002ffff0000) { - return COFFAArch64; - } - return NotObject; -} - -static enum ObjectFileFormat identifyObjectFile(FILE *f) -{ - char buf[32]; - ssize_t sz = fread(buf, 1, 32, f); - CHECK(fseek(f, -sz, SEEK_CUR) == 0); - return identifyObjectFile_(buf, sz); -} +// enum ObjectFileFormat { +// NotObject, +// COFFAmd64, +// COFFI386, +// COFFAArch64, +// ELF, +// MachO32, +// MachO64, +// }; + +// static enum ObjectFileFormat identifyObjectFile_(char* buf, size_t sz) +// { +// if (sz > 2 && ((uint16_t*)buf)[0] == 0x8664) { +// return COFFAmd64; +// } +// if (sz > 2 && ((uint16_t*)buf)[0] == 0x014c) { +// return COFFI386; +// } +// if (sz > 2 && ((uint16_t*)buf)[0] == 0xaa64) { +// return COFFAArch64; +// } +// if (sz > 4 && memcmp(buf, "\x7f" "ELF", 4) == 0) { +// return ELF; +// } +// if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedface) { +// return MachO32; +// } +// if (sz > 4 && ((uint32_t*)buf)[0] == 0xfeedfacf) { +// return MachO64; +// } +// // BigObj COFF files ... +// if (sz > 8 && ((uint64_t*)buf)[0] == 0x86640002ffff0000) { +// return COFFAmd64; +// } +// return NotObject; +// } + +// static enum ObjectFileFormat identifyObjectFile(FILE *f) +// { +// char buf[32]; +// ssize_t sz = fread(buf, 1, 32, f); +// CHECK(fseek(f, -sz, SEEK_CUR) == 0); +// return identifyObjectFile_(buf, sz); +// } static bool readThinArchiveMember(int n, int memberSize, pathchar* path, char* fileName, char* image) @@ -553,9 +547,11 @@ HsInt loadArchive_ (pathchar *path) } DEBUG_LOG("Found member file `%s'\n", fileName); - bool is_symbol_table = strcmp("", fileName) == 0; - enum ObjectFileFormat object_fmt = is_symbol_table ? NotObject : identifyObjectFile(f); + +///////////////////////////////////////////////// +// We found the member file. Load it into memory. +///////////////////////////////////////////////// #if defined(OBJFORMAT_PEi386) /* @@ -575,17 +571,22 @@ HsInt loadArchive_ (pathchar *path) #endif // windows DEBUG_LOG("\tthisFileNameSize = %d\n", (int)thisFileNameSize); - DEBUG_LOG("\tisObject = %d\n", object_fmt); + // DEBUG_LOG("\tisObject = %d\n", object_fmt); - if ((!is_symbol_table && isThin) || object_fmt != NotObject) { - DEBUG_LOG("Member is an object file...loading...\n"); + //if ((!is_symbol_table && isThin) || object_fmt != NotObject) + if (!is_symbol_table && !isImportLib) + { + DEBUG_LOG("Member might be an object file...loading...\n"); #if defined(darwin_HOST_OS) || defined(ios_HOST_OS) if (RTS_LINKER_USE_MMAP) image = mmapAnonForLinker(memberSize); else { /* See loadObj() */ - misalignment = machoGetMisalignment(f); + if(!machoGetMisalignment(f, &misalignment)) + DEBUG_LOG("Failed to load member as mach-o file. Skipping.\n"); + continue; + } image = stgMallocBytes(memberSize + misalignment, "loadArchive(image)"); image += misalignment; @@ -616,19 +617,23 @@ HsInt loadArchive_ (pathchar *path) pathprintf(archiveMemberName, size+1, WSTR("%" PATH_FMT "(#%d:%.*s)"), path, memberIdx, (int)thisFileNameSize, fileName); +/////////////////////////////////////////////////////////////// +// Verfiy the object file is valid, and load it if appropriate. +/////////////////////////////////////////////////////////////// + + // Prepare headers, doesn't load any data yet. ObjectCode *oc = mkOc(STATIC_OBJECT, path, image, memberSize, false, archiveMemberName, misalignment); -#if defined(OBJFORMAT_MACHO) - ASSERT(object_fmt == MachO32 || object_fmt == MachO64); - ocInit_MachO( oc ); -#endif -#if defined(OBJFORMAT_ELF) - ASSERT(object_fmt == ELF); - ocInit_ELF( oc ); -#endif - stgFree(archiveMemberName); + if(!verifyAndInitOc( oc )) + { + freeObjectCode( oc ); + IF_DEBUG(linker, ocDebugBelch(oc, "Faild to verify ... skipping.")); + continue; + }; + + if (0 == loadOc(oc)) { stgFree(fileName); fclose(f); ===================================== rts/linker/MachO.c ===================================== @@ -1725,31 +1725,41 @@ ocRunFini_MachO ( ObjectCode *oc ) /* * Figure out by how much to shift the entire Mach-O file in memory * when loading so that its single segment ends up 16-byte-aligned + * + * Returns 1 and sets misalignment_out to the detected misalignment i + * f we successfully parsed the file. + * + * If we can't parse the file we set misalignment_out to 0 and return 0 */ int -machoGetMisalignment( FILE * f ) +machoGetMisalignment( FILE * f, int* misalignment_out ) { MachOHeader header; int misalignment; + *misalignment_out = 0; { size_t n = fread(&header, sizeof(header), 1, f); if (n != 1) { - barf("machoGetMisalignment: can't read the Mach-O header"); + debugBelch("machoGetMisalignment: can't read the Mach-O header"); + return 0; } } fseek(f, -sizeof(header), SEEK_CUR); if(header.magic != MH_MAGIC_64) { - barf("Bad magic. Expected: %08x, got: %08x.", + debugBelch("Bad magic. Expected: %08x, got: %08x.", MH_MAGIC_64, header.magic); + return 0; } misalignment = (header.sizeofcmds + sizeof(header)) & 0xF; IF_DEBUG(linker, debugBelch("mach-o misalignment %d\n", misalignment)); - return misalignment ? (16 - misalignment) : 0; + misalignment ? (16 - misalignment) : 0; + *misalignment_out = misalignment + return 1; } #endif /* darwin_HOST_OS || ios_HOST_OS */ ===================================== rts/linker/MachO.h ===================================== @@ -13,7 +13,7 @@ int ocGetNames_MachO ( ObjectCode* oc ); int ocResolve_MachO ( ObjectCode* oc ); int ocRunInit_MachO ( ObjectCode* oc ); int ocRunFini_MachO ( ObjectCode* oc ); -int machoGetMisalignment ( FILE * ); +int machoGetMisalignment ( FILE *, int* ); int ocAllocateExtras_MachO ( ObjectCode* oc ); SectionKind getSectionKind_MachO ( MachOSection *macho ); ===================================== rts/linker/PEi386.c ===================================== @@ -775,6 +775,10 @@ COFF_OBJ_TYPE getObjectType ( char* image, pathchar* fileName ) *************/ COFF_HEADER_INFO* getHeaderInfo ( ObjectCode* oc ) { + if((size_t) oc->fileSize < sizeof(IMAGE_FILE_HEADER)) { + errorBelch ("Supposed COFF file smaller than minimum header size.\n"); + return NULL; + } COFF_OBJ_TYPE coff_type = getObjectType (oc->image, OC_INFORMATIVE_FILENAME(oc)); COFF_HEADER_INFO* info @@ -808,6 +812,11 @@ COFF_HEADER_INFO* getHeaderInfo ( ObjectCode* oc ) stgFree (info); info = NULL; errorBelch ("Unknown COFF %d type in getHeaderInfo.", coff_type); + if(oc->archiveMemberName) { + errorBelch ("Archive %" PATH_FMT ".\n", oc->archiveMemberName); + } + errorBelch ("In %" PATH_FMT ".\n", oc->fileName); + } break; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae4264e70a96b8503c9997f060c3044… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae4264e70a96b8503c9997f060c3044… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/update-win-bootstrap
by Zubin (＠wz1000) 08 Aug '25

08 Aug '25

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

1 0