July 2025 - ghc-commits

[Git][ghc/ghc][wip/bump-win32-tarballs] rts/LoadArchive: Handle string table entries terminated with /
by Ben Gamari (＠bgamari) 13 Jul '25

13 Jul '25

Ben Gamari pushed to branch wip/bump-win32-tarballs at Glasgow Haskell Compiler / GHC Commits: 5d8fce70 by Ben Gamari at 2025-07-13T18:26:28-04:00 rts/LoadArchive: Handle string table entries terminated with / llvm-ar appears to terminate string table entries with `/\n` [1]. This matters in the case of thin archives, since the filename is used. In the past this worked since `llvm-ar` would produce archives with "small" filenames when possible. However, now it appears to always use the string table. [1] https://github.com/llvm/llvm-project/blob/bfb686bb5ba503e9386dc899e1ebbe248… - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -275,6 +275,13 @@ lookupGNUArchiveIndex(int gnuFileIndexSize, char **fileName_, "loadArchive(fileName)"); } memcpy(fileName, gnuFileIndex + n, FileNameSize); + + + /* llvm-ar terminates string table entries with `/\n`. */ + if (fileName[FileNameSize-1] == '/') { + FileNameSize--; + } + fileName[FileNameSize] = '\0'; *thisFileNameSize = FileNameSize; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d8fce70410b784a2da1c73a82fbb8a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d8fce70410b784a2da1c73a82fbb8a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/warning-for-last-and-init] 4 commits: Fix documentation for HEAP_PROF_SAMPLE_STRING
by Bodigrim (＠Bodigrim) 12 Jul '25

12 Jul '25

Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - d842c8c5 by Mike Pilgrem at 2025-07-12T18:40:17+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). - - - - - 21 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Prelude/Basic.hs - docs/users_guide/eventlog-formats.rst - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/src/Settings/Warnings.hs - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-internal/src/GHC/Internal/Base.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/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - libraries/time - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/rts/KeepCafsBase.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -112,8 +112,7 @@ import GHC.Utils.Misc import Data.ByteString ( ByteString ) import Data.Function ( on ) -import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) -import qualified Data.List as Partial ( init, last ) +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc ) import Data.Ord ( comparing ) import Control.Monad ( guard ) import qualified Data.Set as Set @@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args PrimOpId op _ | primOpIsDiv op - , Lit divisor <- Partial.last args + , Just (initArgs, Lit divisor) <- unsnoc args -- there can be 2 args (most div primops) or 3 args -- (WordQuotRem2Op), hence the use of last/init - -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -183,7 +183,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) processSCCs [] = return () processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs - processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) cycle_err uids = @@ -195,8 +195,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) ++ [text "-" <+> ppr final] where - start = init uids - final = last uids + start = NE.init uids + final = NE.last uids -- | Check that we don't have multiple units with the same UnitId. checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () ===================================== compiler/GHC/Prelude/Basic.hs ===================================== @@ -2,8 +2,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] --- See Note [Proxies for head and tail] -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} +-- See Note [Proxies for partial list functions] +{-# OPTIONS_GHC -Wno-x-partial #-} -- | Custom minimal GHC "Prelude" -- @@ -24,7 +24,7 @@ module GHC.Prelude.Basic , bit , shiftL, shiftR , setBit, clearBit - , head, tail, unzip + , head, tail, init, last, unzip , strictGenericLength ) where @@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this: -} import qualified Prelude -import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip) import Control.Applicative (Applicative(..)) import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) import Data.Foldable1 as X hiding (head, last) @@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i clearBit :: (Num a, Bits.Bits a) => a -> Int -> a clearBit = \ x i -> x Bits..&. Bits.complement (bit i) -{- Note [Proxies for head and tail] +{- Note [Proxies for partial list functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, +Prelude.head, Prelude.tail, Prelude.init and Prelude.last +have recently acquired {-# WARNING in "x-partial" #-}, but the GHC codebase uses them fairly extensively and insists on building warning-free. Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which employs them, we define warning-less proxies and export them from GHC.Prelude. -} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] head :: HasCallStack => [a] -> a head = Prelude.head {-# INLINE head #-} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-} +-- See Note [Proxies for partial list functions] +init :: HasCallStack => [a] -> [a] +init = Prelude.init +{-# INLINE init #-} + +-- See Note [Proxies for partial list functions] +last :: HasCallStack => [a] -> a +last = Prelude.last +{-# INLINE last #-} + {- | The 'genericLength' function defined in base can't be specialised due to the NOINLINE pragma. ===================================== docs/users_guide/eventlog-formats.rst ===================================== @@ -779,9 +779,9 @@ the total time spent profiling. Cost-centre break-down ^^^^^^^^^^^^^^^^^^^^^^ -A variable-length packet encoding a heap profile sample broken down by, - * cost-centre (:rts-flag:`-hc`) - +A variable-length packet encoding a heap profile sample. +This event is only emitted when the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`. +Otherwise, a :event-type:`HEAP_PROF_SAMPLE_STRING` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_COST_CENTRE @@ -796,11 +796,19 @@ A variable-length packet encoding a heap profile sample broken down by, String break-down ^^^^^^^^^^^^^^^^^ -A variable-length event encoding a heap sample broken down by, +A variable-length event encoding a heap sample. +The content of the sample label varies depending on the heap profile type: + + * :rts-flag:`-hT` The sample label contains a closure type, e.g., ``"ghc-bignum:GHC.Num.Integer.IS"``. + * :rts-flag:`-hm` The sample label contains a module name, e.g., ``"GHC.Num.Integer"``. + * :rts-flag:`-hd` The sample label contains a closure description, e.g., ``"IS"``. + * :rts-flag:`-hy` The sample label contains a type description, e.g., ``"Integer"``. + * :rts-flag:`-he` The sample label contains a stringified era, e.g., ``"1"``. + * :rts-flag:`-hr` The sample label contains a retainer set description, e.g., ``"(184)$stoIntegralSized1"``. + * :rts-flag:`-hi` The sample label contains a stringified pointer, e.g., ``"0x1008b7588"``, + which can be matched to an info table description emitted by the :event-type:`IPE` event. - * type description (:rts-flag:`-hy`) - * closure description (:rts-flag:`-hd`) - * module (:rts-flag:`-hm`) +If the heap profile type is set to :rts-flag:`-hc` or :rts-flag:`-hb`, a :event-type:`HEAP_PROF_SAMPLE_COST_CENTRE` event is emitted instead. .. event-type:: HEAP_PROF_SAMPLE_STRING @@ -808,7 +816,7 @@ A variable-length event encoding a heap sample broken down by, :length: variable :field Word8: profile ID :field Word64: heap residency in bytes - :field String: type or closure description, or module name + :field String: sample label .. _time-profiler-events: ===================================== ghc/GHCi/UI.hs ===================================== @@ -133,7 +133,7 @@ import Data.Char import Data.Function import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) -import Data.List ( find, intercalate, intersperse, +import Data.List ( find, intercalate, intersperse, unsnoc, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE import qualified Data.Set as S @@ -2399,9 +2399,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do [] -> let graph' = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing - in case graph' of - [] -> setContextKeepingPackageModules keep_ctxt [] - xs -> load_this (last xs) + in case unsnoc graph' of + Nothing -> setContextKeepingPackageModules keep_ctxt [] + Just (_, lst) -> load_this lst (m:_) -> load_this m where ===================================== ghc/Main.hs ===================================== @@ -88,7 +88,7 @@ import System.Exit import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except (throwE, runExceptT) -import Data.List ( isPrefixOf, partition, intercalate ) +import Data.List ( isPrefixOf, partition, intercalate, unsnoc ) import Prelude import qualified Data.List.NonEmpty as NE @@ -115,8 +115,7 @@ main = do argv0 <- getArgs let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 - mbMinusB | null minusB_args = Nothing - | otherwise = Just (drop 2 (last minusB_args)) + mbMinusB = drop 2 . snd <$> unsnoc minusB_args let argv2 = map (mkGeneralLocated "on the commandline") argv1 ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -72,7 +72,10 @@ ghcWarningsArgs = do , package terminfo ? pure [ "-Wno-unused-imports", "-Wno-deriving-typeable" ] , package stm ? pure [ "-Wno-deriving-typeable" ] , package osString ? pure [ "-Wno-deriving-typeable", "-Wno-unused-imports" ] - , package parsec ? pure [ "-Wno-deriving-typeable" ] + , package parsec ? pure [ "-Wno-deriving-typeable" + , "-Wno-x-partial" + -- https://github.com/haskell/parsec/issues/194 + ] , package cabal ? pure [ "-Wno-deriving-typeable", "-Wno-incomplete-record-selectors" ] -- The -Wno-incomplete-record-selectors is due to ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib import GHC.Boot.TH.Syntax import Data.Word ( Word8 ) import Data.Char ( toLower, chr ) -import Data.List ( intersperse ) +import Data.List ( intersperse, unsnoc ) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) @@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $ pprStms [s] = ppr s pprStms ss = braces (semiSep ss) -pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' -pprExp _ (CompE ss) = +pprExp _ (CompE ss) = case unsnoc ss of + Nothing -> text "<<Empty CompExp>>" + Just (ss', s) -> if null ss' -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. @@ -225,8 +226,6 @@ pprExp _ (CompE ss) = <+> bar <+> commaSep ss' <> text "]" - where s = last ss - ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1047,7 +1047,7 @@ class Functor f where -- * sequence computations and combine their results ('<*>' and 'liftA2'). -- -- A minimal complete definition must include implementations of 'pure' --- and of either '<*>' or 'liftA2'. If it defines both, then they must behave +-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -13,6 +13,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- For init in formatRealFloatAlt +{-# OPTIONS_GHC -Wno-x-partial #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Float ===================================== libraries/ghc-internal/src/GHC/Internal/List.hs ===================================== @@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a] tail (_:xs) = xs tail [] = errorEmptyList "tail" -{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} +{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} -- | $\mathcal{O}(n)$. Extract the last element of a list, which must be -- finite and non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs lastError :: HasCallStack => a lastError = errorEmptyList "last" +{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(n)$. Return all the elements of a list except the last one. -- The list must be non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -240,6 +254,8 @@ init (x:xs) = init' x xs where init' _ [] = [] init' y (z:zs) = y : init' z zs +{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(1)$. Test whether a list is empty. -- -- >>> null [] ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -825,11 +825,12 @@ output_flags = std_flags where -- XXX bits copied from System.FilePath, since that's not available here - combine a b - | null b = a - | null a = b - | pathSeparator [last a] = a ++ b - | otherwise = a ++ [pathSeparatorChar] ++ b + combine a [] = a + combine a b = case unsnoc a of + Nothing -> b + Just (_, lastA) + | pathSeparator [lastA] -> a ++ b + | otherwise -> a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable +import GHC.Internal.List (unsnoc) import GHC.Internal.Word import GHC.Internal.Generics (Generic) import GHC.Internal.IORef @@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix import GHC.Internal.Control.Exception import GHC.Internal.Num import GHC.Internal.IO.Unsafe -import GHC.Internal.List (dropWhile, break, replicate, reverse, last) +import GHC.Internal.List (dropWhile, break, replicate, reverse) import GHC.Internal.MVar import GHC.Internal.IO.Exception import GHC.Internal.Unicode @@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type) import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions +#ifdef BOOTSTRAP_TH +#if MIN_VERSION_base(4,19,0) +import Data.List (unsnoc) +#else +import Data.Maybe (maybe) +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +#endif +#endif + ----------------------------------------------------- -- -- The Quasi class @@ -1296,7 +1307,7 @@ mkName str -- (i.e. non-empty, starts with capital, all alpha) is_rev_mod_name rev_mod_str | (compt, rest) <- break (== '.') rev_mod_str - , not (null compt), isUpper (last compt), all is_mod_char compt + , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt = case rest of [] -> True (_dot : rest') -> is_rev_mod_name rest' ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Posix import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Windows import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== libraries/time ===================================== @@ -1 +1 @@ -Subproject commit e5c5d1987011efe88a21ab6ded45aaa33a16274f +Subproject commit 989a09cd173e23d5a52e43efa06c43015f267416 ===================================== testsuite/tests/driver/j-space/jspace.hs ===================================== @@ -7,7 +7,7 @@ import System.Environment import GHC.Driver.Env.Types import GHC.Profiling import System.Mem -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, unsnoc) import Control.Monad import System.Exit import GHC.Platform @@ -41,7 +41,9 @@ initGhcM xs = do requestHeapCensus performGC [ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp" - let (n :: Int) = read (last (words ys)) + let (n :: Int) = case unsnoc (words ys) of + Nothing -> error "input is unexpectedly empty" + Just (_, lst) -> read lst -- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures): -- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH, -- and each ModDetails contains 1 (info table) + 8 word-sized fields. ===================================== testsuite/tests/rts/KeepCafsBase.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} + module KeepCafsBase (x) where x :: Int ===================================== utils/check-exact/Utils.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..)) import GHC.Parser.Lexer (allocateComments) import Data.Data hiding ( Fixity ) -import Data.List (sortBy, partition) +import Data.List (sortBy, partition, unsnoc) import qualified Data.Map.Strict as Map import Debug.Trace @@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h +glast info xs = case unsnoc xs of + Nothing -> error $ "glast " ++ info ++ " []" + Just (_, lst) -> lst gtail :: String -> [a] -> [a] gtail info [] = error $ "gtail " ++ info ++ " []" ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -755,7 +755,7 @@ ppHtmlIndex divAlphabet << unordList ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index + [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index ] ++ [merged_name] ) @@ -772,7 +772,7 @@ ppHtmlIndex writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part - index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c] + index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] index :: [(String, Map GHC.Name [(Module, Bool)])] index = sortBy cmp (Map.toAscList full_index) ===================================== utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs ===================================== @@ -30,7 +30,7 @@ import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) import Data.Functor (($>)) -import Data.List (elemIndex, intercalate, intersperse, unfoldr) +import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set @@ -870,10 +870,10 @@ codeblock = DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where - dropSpaces xs = - case splitByNl xs of - [] -> xs - ys -> case T.uncons (last ys) of + dropSpaces xs = let ys = splitByNl xs in + case unsnoc ys of + Nothing -> xs + Just (_, lastYs) -> case T.uncons lastYs of Just (' ', _) -> case mapM dropSpace ys of Nothing -> xs Just zs -> T.intercalate "\n" zs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f16552d7617e1f41b5da85b8d2ed2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f16552d7617e1f41b5da85b8d2ed2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] Fix unix submodule ref
by Sven Tennie (＠supersven) 12 Jul '25

12 Jul '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: d9b00fa2 by Sven Tennie at 2025-07-12T18:52:05+02:00 Fix unix submodule ref - - - - - 1 changed file: - libraries/unix Changes: ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit 47d5fc4a8f19207819030725e7de23c65fa61a04 +Subproject commit 1c3548c3906bb0d912eda5685968934183f4b51f View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9b00fa2044fc011609bd2fec016ef5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9b00fa2044fc011609bd2fec016ef5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 81 commits: Consider `PromotedDataCon` in `tyConStupidTheta`
by Sven Tennie (＠supersven) 12 Jul '25

12 Jul '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: 8d33d048 by Berk Özkütük at 2025-07-07T20:42:20-04:00 Consider `PromotedDataCon` in `tyConStupidTheta` Haddock checks data declarations for the stupid theta so as not to pretty-print them as empty contexts. Type data declarations end up as `PromotedDataCon`s by the time Haddock performs this check, causing a panic. This commit extends `tyConStupidTheta` so that it returns an empty list for `PromotedDataCon`s. This decision was guided by the fact that type data declarations never have data type contexts (see (R1) in Note [Type data declarations]). Fixes #25739. - - - - - a26243fd by Ryan Hendrickson at 2025-07-07T20:43:07-04:00 haddock: Document instances from other packages When attaching instances to `Interface`s, it isn't enough just to look for instances in the list of `Interface`s being processed. We also need to look in the modules on which they depend, including those outside of this package. Fixes #25147. Fixes #26079. - - - - - 0fb24420 by Rodrigo Mesquita at 2025-07-07T20:43:49-04:00 hadrian: Fallback logic for internal interpreter When determining whether to build the internal interpreter, the `make` build system had a fallback case for platforms not in the list of explicitly-supported operating systems and architectures. This fallback says we should try to build the internal interpreter if building dynamic GHC programs (if the architecture is unknown). Fixes #24098 - - - - - fe925bd4 by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Reference Wasm FFI section - - - - - 5856284b by Ben Gamari at 2025-07-07T20:44:30-04:00 users-guide: Fix too-short heading warning - - - - - a48dcdf3 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Reorganise documentation for allocate* functions Consolodate interface information into the .h file, keeping just implementation details in the .c file. Use Notes stlye in the .h file and refer to notes from the .c file. - - - - - de5b528c by Duncan Coutts at 2025-07-07T20:45:18-04:00 Introduce common utilities for allocating arrays The intention is to share code among the several places that do this already. - - - - - b321319d by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Heap.c The CMM primop can now report heap overflow. - - - - - 1d557ffb by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in ThreadLabels.c Replacing a local utility. - - - - - e59a1430 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Threads.c Replacing local open coded version. - - - - - 482df1c9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Add exitHeapOverflow helper utility This will be useful with the array alloc functions, since unlike allocate/allocateMaybeFail, they do not come in two versions. So if it's not convenient to propagate failure, then one can use this. - - - - - 4d3ec8f9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 Use new array alloc utils in Weak.c Also add a cpp macro CCS_SYSTEM_OR_NULL which does what it says. The benefit of this is that it allows us to referece CCS_SYSTEM even when we're not in PROFILING mode. That makes abstracting over profiling vs normal mode a lot easier. - - - - - 0c4f2fde by Duncan Coutts at 2025-07-07T20:45:18-04:00 Convert the array alloc primops to use the new array alloc utils - - - - - a3354ad9 by Duncan Coutts at 2025-07-07T20:45:18-04:00 While we're at it, add one missing 'likely' hint To a cmm primops that raises an exception, like the others now do. - - - - - 33b546bd by meooow25 at 2025-07-07T20:46:09-04:00 Keep scanl' strict in the head on rewrite `scanl'` forces elements to WHNF when the corresponding `(:)`s are forced. The rewrite rule for `scanl'` missed forcing the first element, which is fixed here with a `seq`. - - - - - 8a69196e by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger/rts: Allow toggling step-in per thread The RTS global flag `rts_stop_next_breakpoint` globally sets the interpreter to stop at the immediate next breakpoint. With this commit, single step mode can additionally be set per thread in the TSO flag (TSO_STOP_NEXT_BREAKPOINT). Being able to toggle "stop at next breakpoint" per thread is an important requirement for implementing "stepping out" of a function in a multi-threaded context. And, more generally, having a per-thread flag for single-stepping paves the way for multi-threaded debugging. That said, when we want to enable "single step" mode for the whole interpreted program we still want to stop at the immediate next breakpoint, whichever thread it belongs to. That's why we also keep the global `rts_stop_next_breakpoint` flag, with `rts_enableStopNextBreakpointAll` and `rts_disableStopNextBreakpointAll` helpers. Preparation for #26042 - - - - - 73d3f864 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 docs: Case continuation BCOs This commit documents a subtle interaction between frames for case BCOs and their parents frames. Namely, case continuation BCOs may refer to (non-local) variables that are part of the parent's frame. The note expanding a bit on these details is called [Case continuation BCOs] - - - - - d7aeddcf by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Implement step-out feature Implements support for stepping-out of a function (aka breaking right after returning from a function) in the interactive debugger. It also introduces a GHCi command :stepout to step-out of a function being debugged in the interpreter. The feature is described as: Stop at the first breakpoint immediately after returning from the current function scope. Known limitations: because a function tail-call does not push a stack frame, if step-out is used inside of a function that was tail-called, execution will not be returned to its caller, but rather its caller's first non-tail caller. On the other hand, it means the debugger follows the more realistic execution of the program. In the following example: .. code-block:: none f = do a b <--- (1) set breakpoint then step in here c b = do ... d <--- (2) step-into this tail call d = do ... something <--- (3) step-out here ... Stepping-out will stop execution at the `c` invokation in `f`, rather than stopping at `b`. The key idea is simple: When step-out is enabled, traverse the runtime stack until a continuation BCO is found -- and enable the breakpoint heading that BCO explicitly using its tick-index. The details are specified in `Note [Debugger: Step-out]` in `rts/Interpreter.c`. Since PUSH_ALTS BCOs (representing case continuations) were never headed by a breakpoint (unlike the case alternatives they push), we introduced the BRK_ALTS instruction to allow the debugger to set a case continuation to stop at the breakpoint heading the alternative that is taken. This is further described in `Note [Debugger: BRK_ALTS]`. Fixes #26042 - - - - - 5d9adf51 by Rodrigo Mesquita at 2025-07-08T07:39:47-04:00 debugger: Filter step-out stops by SrcSpan To implement step-out, the RTS looks for the first continuation frame on the stack and explicitly enables its entry breakpoint. However, some continuations will be contained in the function from which step-out was initiated (trivial example is a case expression). Similarly to steplocal, we will filter the breakpoints at which the RTS yields to the debugger based on the SrcSpan. When doing step-out, only stop if the breakpoint is /not/ contained in the function from which we initiated it. This is especially relevant in monadic statements such as IO which is compiled to a long chain of case expressions. See Note [Debugger: Filtering step-out stops] - - - - - 7677adcc by Cheng Shao at 2025-07-08T07:40:29-04:00 compiler: make ModBreaks serializable - - - - - 14f67c6d by Rodrigo Mesquita at 2025-07-08T07:40:29-04:00 refactor: "Inspecting the session" moved from GHC Moved utilities for inspecting the session from the GHC module to GHC.Driver.Session.Inspect Purely a clean up - - - - - 9d3f484a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Pass the HUG to readModBreaks, not HscEnv A minor cleanup. The associated history and setupBreakpoint functions are changed accordingly. - - - - - b595f713 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move readModBreaks to GHC.Runtime.Interpreter With some small docs changes - - - - - d223227a by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Move interpreterProfiled to Interp.Types Moves interpreterProfiled and interpreterDynamic to GHC.Runtime.Interpreter.Types from GHC.Runtime.Interpreter. - - - - - 7fdd0a3d by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Don't import GHC in Debugger.Breakpoints Remove the top-level import GHC from GHC.Runtime.Debugger.Breakpoints This makes the module dependencies more granular and cleans up the qualified imports from the code. - - - - - 5e4da31b by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refactor: Use BreakpointId in Core and Ifaces - - - - - 741ac3a8 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 stg2bc: Derive BcM via ReaderT StateT A small refactor that simplifies GHC.StgToByteCode by deriving-via the Monad instances for BcM. This is done along the lines of previous similar refactors like 72b54c0760bbf85be1f73c1a364d4701e5720465. - - - - - 0414fcc9 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 refact: Split InternalModBreaks out of ModBreaks There are currently two competing ways of referring to a Breakpoint: 1. Using the Tick module + Tick index 2. Using the Info module + Info index 1. The Tick index is allocated during desugaring in `mkModBreaks`. It is used to refer to a breakpoint associated to a Core Tick. For a given Tick module, there are N Ticks indexed by Tick index. 2. The Info index is allocated during code generation (in StgToByteCode) and uniquely identifies the breakpoints at runtime (and is indeed used to determine which breakpoint was hit at runtime). Why we need both is described by Note [Breakpoint identifiers]. For every info index we used to keep a `CgBreakInfo`, a datatype containing information relevant to ByteCode Generation, in `ModBreaks`. This commit splits out the `IntMap CgBreakInfo` out of `ModBreaks` into a new datatype `InternalModBreaks`. - The purpose is to separate the `ModBreaks` datatype, which stores data associated from tick-level information which is fixed after desugaring, from the unrelated `IntMap CgBreakInfo` information accumulated during bytecode generation. - We move `ModBreaks` to GHC.HsToCore.Breakpoints The new `InternalModBreaks` simply combines the `IntMap CgBreakInfo` with `ModBreaks`. After code generation we construct an `InternalModBreaks` with the `CgBreakInfo`s we accumulated and the existing `ModBreaks` and store that in the compiled BCO in `bc_breaks`. - Note that we previously only updated the `modBreaks_breakInfo` field of `ModBreaks` at this exact location, and then stored the updated `ModBreaks` in the same `bc_breaks`. - We put this new datatype in GHC.ByteCode.Breakpoints The rest of the pipeline for which CgBreakInfo is relevant is accordingly updated to also use `InternalModBreaks` - - - - - 2a097955 by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 cleanup: Use BreakpointIds in bytecode gen Small clean up to use BreakpointId and InternalBreakpointId more uniformly in bytecode generation rather than using Module + Ix pairs - - - - - 0515cc2f by Rodrigo Mesquita at 2025-07-08T07:40:30-04:00 ghci: Allocate BreakArrays at link time only Previously, a BreakArray would be allocated with a slot for every tick in a module at `mkModBreaks`, in HsToCore. However, this approach has a few downsides: - It interleaves interpreter behaviour (allocating arrays for breakpoints) within the desugarer - It is inflexible in the sense it is impossible for the bytecode generator to add "internal" breakpoints that can be triggered at runtime, because those wouldn't have a source tick. (This is relevant for our intended implementation plan of step-out in #26042) - It ties the BreakArray indices to the *tick* indexes, while at runtime we would rather just have the *info* indexes (currently we have both because BreakArrays are indexed by the *tick* one). Paving the way for #26042 and #26064, this commit moves the allocation of BreakArrays to bytecode-loading time -- akin to what is done for CCS arrays. Since a BreakArray is allocated only when bytecode is linked, if a breakpoint is set (e.g. `:break 10`) before the bytecode is linked, there will exist no BreakArray to trigger the breakpoint in. Therefore, the function to allocate break arrays (`allocateBreakArrays`) is exposed and also used in GHC.Runtime.Eval to allocate a break array when a breakpoint is set, if it doesn't exist yet (in the linker env). - - - - - 8016561f by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add a test for T26176 - - - - - 454cd682 by Simon Peyton Jones at 2025-07-08T07:41:13-04:00 Add test for #14010 This test started to work in GHC 9.6 and has worked since. This MR just adds a regression test - - - - - ea2c6673 by Teo Camarasu at 2025-07-08T13:24:43-04:00 Implement user-defined allocation limit handlers Allocation Limits allow killing a thread if they allocate more than a user-specified limit. We extend this feature to allow more versatile behaviour. - We allow not killing the thread if the limit is exceeded. - We allow setting a custom handler to be called when the limit is exceeded. User-specified allocation limit handlers run in a fresh thread and are passed the ThreadId of the thread that exceeded its limit. We introduce utility functions for getting and setting the allocation limits of other threads, so that users can reset the limit of a thread from a handler. Both of these are somewhat coarse-grained as we are unaware of the allocations in the current nursery chunk. We provide several examples of usages in testsuite/tests/rts/T22859.hs Resolves #22859 - - - - - 03e047f9 by Simon Hengel at 2025-07-08T13:25:25-04:00 Fix typo in using.rst - - - - - 67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00 compiler: Import AnnotationWrapper from ghc-internal Since `GHC.Desugar` exported from `base` has been deprecated. - - - - - 813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-compact: Eliminate dependency on ghc-prim - - - - - 0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Eliminate dependency on ghc-prim - - - - - 480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Drop redundant import - - - - - 03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00 ghc-prim: Bump version to 0.13.1 There are no interface changes from 0.13.0 but the implementation now lives in `ghc-internal`. - - - - - d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00 template-haskell: Bump version number to 2.24.0.0 Bumps exceptions submodule. - - - - - 004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump GHC version number to 9.14 - - - - - eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump parsec to 3.1.18.0 Bumps parsec submodule. - - - - - 86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00 unix: Bump to 2.8.7.0 Bumps unix submodule. - - - - - 89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00 binary: Bump to 0.8.9.3 Bumps binary submodule. - - - - - 55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00 Win32: Bump to 2.14.2.0 Bumps Win32 submodule. - - - - - 7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00 base: Bump version to 4.22.0 Bumps various submodules. - - - - - ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00 base: Export displayExceptionWithInfo This function should be exposed from base following CLC#285 Approved change in CLC#344 Fixes #26058 - - - - - 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - c82449af by Sven Tennie at 2025-07-12T17:31:52+02:00 Implement CPU vector support (RVV) detection for RISC-V - - - - - a8ed9cb6 by Sven Tennie at 2025-07-12T17:31:52+02:00 Introduce -mriscv-vlen driver argument with runtime check Ensure that the configured vlen fits to the detected one. - - - - - 3f518c78 by Sven Tennie at 2025-07-12T17:31:52+02:00 Compile AutoApply_V*.cmm and Jumps_V*.cmm with vector support If the running CPU does not support RVV, this code will not be executed. However, at build time, we have to emit (prepare) it. - - - - - 05254c62 by Sven Tennie at 2025-07-12T17:31:52+02:00 Emit code for RVV This includes adding the vector registers to the register allocator and adding support for the related MachOps to the cod generator. - - - - - d61d190c by Sven Tennie at 2025-07-12T17:31:52+02:00 Detect RVV CPU features and make them configurable for CROSS_EMULATOR Unfortunately, the cpuinfo Python package is abandonned. Thus, we just add RVV detection here (and not upstream.) cpuinfo is not executed on the CROSS_EMULATOR. So, we make supported features configurable. - - - - - 22eee14b by Sven Tennie at 2025-07-12T17:31:52+02:00 Adjust SIMD test to support/use RISC-V - - - - - ea40c726 by Sven Tennie at 2025-07-12T17:31:52+02:00 WIP: Test for the RVV c calling convention - - - - - 675ebd0f by Sven Tennie at 2025-07-12T17:31:52+02:00 Fix CheckVectorSupport - - - - - 602b69c9 by Sven Tennie at 2025-07-12T17:31:52+02:00 Always configure -march=rv64gcv - - - - - 1576ebcf by Sven Tennie at 2025-07-12T17:31:52+02:00 Adjust vector check in all.T - - - - - 520f7d8b by Sven Tennie at 2025-07-12T17:31:52+02:00 Print vectors to show that the stack is intact - - - - - 8500c505 by Sven Tennie at 2025-07-12T17:31:52+02:00 Check for GCC >= 14 in autoconf - - - - - 223377d6 by Sven Tennie at 2025-07-12T17:31:52+02:00 VectorCCallConv test: Test doubles as well - - - - - 50e19387 by Sven Tennie at 2025-07-12T17:31:52+02:00 Formatting - - - - - 380c23a1 by Sven Tennie at 2025-07-12T17:31:52+02:00 Add haddock - - - - - db2288c9 by Sven Tennie at 2025-07-12T17:31:52+02:00 Haddock - - - - - 9e4c2dd5 by Sven Tennie at 2025-07-12T17:31:52+02:00 Add calculations to TrivColorable - - - - - 181ac50c by Sven Tennie at 2025-07-12T17:31:52+02:00 Better allocReg check (check upper boundary for floats) - - - - - 481f7b9a by Sven Tennie at 2025-07-12T17:31:52+02:00 point free: floatVecFormat & intVecFormat - - - - - 34a8f4c4 by Sven Tennie at 2025-07-12T17:31:52+02:00 Delete trailing whitespace - - - - - 1c1cbe2d by Sven Tennie at 2025-07-12T17:31:53+02:00 Formatting - - - - - fad2f676 by Sven Tennie at 2025-07-12T17:31:53+02:00 Comment t Haddock - - - - - b8a8ce44 by Sven Tennie at 2025-07-12T17:31:53+02:00 Cleanup session functions - - - - - d6d66d62 by Sven Tennie at 2025-07-12T17:31:53+02:00 Update comment - - - - - 3e820218 by Sven Tennie at 2025-07-12T17:31:53+02:00 Formatting / better error message - - - - - 49b4a7b8 by Sven Tennie at 2025-07-12T17:31:53+02:00 Prepare for more cpu_features - - - - - 751fd4fc by Sven Tennie at 2025-07-12T17:31:53+02:00 Improve comment - - - - - 31be1ad7 by Sven Tennie at 2025-07-12T17:31:53+02:00 cpuinfo.py: Better comments - - - - - 126f1674 by Sven Tennie at 2025-07-12T17:31:53+02:00 Cleanup Instr - - - - - f5c80f0c by Sven Tennie at 2025-07-12T17:31:53+02:00 Refactor vector configuration - - - - - c274fae2 by Sven Tennie at 2025-07-12T17:31:53+02:00 Delete obsolete TODO - - - - - 219 changed files: - compiler/CodeGen.Platform.h - compiler/GHC.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - + compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CallConv.hs - compiler/GHC/CmmToAsm/Config.hs - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/RV64.hs - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs - compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Map/Expr.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config.hs - compiler/GHC/Driver/Config/CmmToAsm.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - + compiler/GHC/Driver/Session/Inspect.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Platform/Reg/Class.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Runtime/Eval/Types.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/GHC/Stg/BcPrep.hs - compiler/GHC/Stg/FVs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Splice.hs - − compiler/GHC/Types/Breakpoint.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Utils/Outputable.hs - compiler/ghc.cabal.in - configure.ac - distrib/configure.ac.in - docs/users_guide/eventlog-formats.rst - docs/users_guide/exts/doandifthenelse.rst - docs/users_guide/exts/ffi.rst - docs/users_guide/ghci.rst - docs/users_guide/using.rst - ghc/GHCi/UI.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Packages.hs - hadrian/src/Settings/Program.hs - libraries/Win32 - libraries/array - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Control/Exception.hs - libraries/binary - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/GHC/Compact.hs - libraries/ghc-compact/GHC/Compact/Serialized.hs - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - + libraries/ghc-experimental/src/System/Mem/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc - libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/tests/parse_tso_flags.hs - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - + libraries/ghci/GHCi/Debugger.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/Run.hs - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/text - + m4/fp_riscv_check_gcc_version.m4 - + m4/fp_riscv_march.m4 - + rts/AllocArray.c - + rts/AllocArray.h - rts/CheckVectorSupport.c - rts/Disassembler.c - rts/Heap.c - rts/Interpreter.c - rts/Interpreter.h - rts/Prelude.h - rts/PrimOps.cmm - rts/RtsStartup.c - rts/RtsSymbols.c - rts/RtsUtils.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/ThreadLabels.c - rts/Threads.c - rts/Weak.c - rts/external-symbols.list.in - rts/include/Rts.h - rts/include/rts/Bytecodes.h - rts/include/rts/Constants.h - rts/include/rts/prof/CCS.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/GC.h - rts/include/rts/storage/Heap.h - rts/include/rts/storage/TSO.h - rts/include/stg/MachRegs.h - rts/include/stg/MachRegs/riscv64.h - rts/include/stg/MiscClosures.h - rts/rts.cabal - rts/sm/Storage.c - testsuite/driver/cpu_features.py - testsuite/driver/cpuinfo.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/bkpcabal08/bkpcabal08.stdout - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/ghci.debugger/scripts/T26042b.hs - + testsuite/tests/ghci.debugger/scripts/T26042b.script - + testsuite/tests/ghci.debugger/scripts/T26042b.stdout - + testsuite/tests/ghci.debugger/scripts/T26042c.hs - + testsuite/tests/ghci.debugger/scripts/T26042c.script - + testsuite/tests/ghci.debugger/scripts/T26042c.stdout - + testsuite/tests/ghci.debugger/scripts/T26042d.hs - + testsuite/tests/ghci.debugger/scripts/T26042d.script - + testsuite/tests/ghci.debugger/scripts/T26042d.stdout - + testsuite/tests/ghci.debugger/scripts/T26042e.hs - + testsuite/tests/ghci.debugger/scripts/T26042e.script - + testsuite/tests/ghci.debugger/scripts/T26042e.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f.hs - + testsuite/tests/ghci.debugger/scripts/T26042f.script - + testsuite/tests/ghci.debugger/scripts/T26042f1.stderr - + testsuite/tests/ghci.debugger/scripts/T26042f1.stdout - + testsuite/tests/ghci.debugger/scripts/T26042f2.stdout - + testsuite/tests/ghci.debugger/scripts/T26042g.hs - + testsuite/tests/ghci.debugger/scripts/T26042g.script - + testsuite/tests/ghci.debugger/scripts/T26042g.stdout - testsuite/tests/ghci.debugger/scripts/all.T - + testsuite/tests/indexed-types/should_fail/T26176.hs - + testsuite/tests/indexed-types/should_fail/T26176.stderr - testsuite/tests/indexed-types/should_fail/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/rts/T22859.hs - + testsuite/tests/rts/T22859.stderr - testsuite/tests/rts/all.T - + testsuite/tests/simd/should_run/VectorCCallConv.hs - + testsuite/tests/simd/should_run/VectorCCallConv.stdout - + testsuite/tests/simd/should_run/VectorCCallConv_c.c - testsuite/tests/simd/should_run/all.T - testsuite/tests/simd/should_run/simd013C.c - + testsuite/tests/typecheck/should_compile/T14010.hs - testsuite/tests/typecheck/should_compile/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs - utils/haddock/CHANGES.md - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock-test/src/Test/Haddock/Config.hs - utils/haddock/haddock.cabal - utils/haddock/html-test/ref/Bug1004.html - + utils/haddock/html-test/ref/Bug25739.html - + utils/haddock/html-test/src/Bug25739.hs - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1b5fe558ee7aa1c08ee525b9a40ca… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1b5fe558ee7aa1c08ee525b9a40ca… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 3 commits: Cleanup Instr
by Sven Tennie (＠supersven) 12 Jul '25

12 Jul '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: 15bfd8bc by Sven Tennie at 2025-07-12T15:20:51+02:00 Cleanup Instr - - - - - 4320c021 by Sven Tennie at 2025-07-12T16:59:22+02:00 Refactor vector configuration - - - - - e1b5fe55 by Sven Tennie at 2025-07-12T17:21:02+02:00 Delete obsolete TODO - - - - - 2 changed files: - compiler/GHC/CmmToAsm/RV64/Instr.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/Instr.hs ===================================== @@ -138,21 +138,6 @@ regUsageOfInstr platform instr = case instr of usage (regOp op1 ++ regOp op2 ++ regOp op3, regOp op1) _ -> panic $ "regUsageOfInstr: " ++ instrCon instr where - -- filtering the usage is necessary, otherwise the register - -- allocator will try to allocate pre-defined fixed stg - -- registers as well, as they show up. - usage :: ([(Reg, Format)], [(Reg, Format)]) -> RegUsage - usage (srcRegs, dstRegs) = - RU - (map mkFmt $ filter (interesting platform) srcRegs) - (map mkFmt $ filter (interesting platform) dstRegs) - - mkFmt (r, fmt) = RegWithFormat r fmt - - regAddr :: AddrMode -> [(Reg, Format)] - regAddr (AddrRegImm r1 _imm) = [(r1, II64)] - regAddr (AddrReg r1) = [(r1, II64)] - regOp :: Operand -> [(Reg, Format)] regOp (OpReg fmt r1) = [(r1, fmt)] regOp (OpAddr a) = regAddr a @@ -162,10 +147,25 @@ regUsageOfInstr platform instr = case instr of regTarget (TBlock _bid) = [] regTarget (TReg r1) = [(r1, II64)] - -- Is this register interesting for the register allocator? - interesting :: Platform -> (Reg, Format) -> Bool - interesting _ ((RegVirtual _), _) = True - interesting platform ((RegReal (RealRegSingle i)), _) = freeReg platform i + regAddr :: AddrMode -> [(Reg, Format)] + regAddr (AddrRegImm r1 _imm) = [(r1, II64)] + regAddr (AddrReg r1) = [(r1, II64)] + + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage :: ([(Reg, Format)], [(Reg, Format)]) -> RegUsage + usage (srcRegs, dstRegs) = + RU + (map mkFmt $ filter (interesting platform) srcRegs) + (map mkFmt $ filter (interesting platform) dstRegs) + where + mkFmt (r, fmt) = RegWithFormat r fmt + + -- Is this register interesting for the register allocator? + interesting :: Platform -> (Reg, Format) -> Bool + interesting _ ((RegVirtual _), _) = True + interesting platform ((RegReal (RealRegSingle i)), _) = freeReg platform i -- | Caller-saved registers (according to calling convention) -- @@ -240,7 +240,7 @@ patchRegsOfInstr instr env = case instr of VSUB o1 o2 o3 -> VSUB (patchOp o1) (patchOp o2) (patchOp o3) VMUL o1 o2 o3 -> VMUL (patchOp o1) (patchOp o2) (patchOp o3) VQUOT mbS o1 o2 o3 -> VQUOT mbS (patchOp o1) (patchOp o2) (patchOp o3) - VREM s o1 o2 o3 -> VREM s (patchOp o1) (patchOp o2) (patchOp o3) + VREM s o1 o2 o3 -> VREM s (patchOp o1) (patchOp o2) (patchOp o3) VSMIN o1 o2 o3 -> VSMIN (patchOp o1) (patchOp o2) (patchOp o3) VSMAX o1 o2 o3 -> VSMAX (patchOp o1) (patchOp o2) (patchOp o3) VUMIN o1 o2 o3 -> VUMIN (patchOp o1) (patchOp o2) (patchOp o3) @@ -452,7 +452,7 @@ mkRegRegMoveInstr :: Format -> Reg -> Reg -> Instr mkRegRegMoveInstr fmt src dst = ANN desc instr where desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst - instr = MOV (operandFromReg fmt dst) (operandFromReg fmt src) + instr = MOV (OpReg fmt dst) (OpReg fmt src) -- | Take the source and destination from this (potential) reg -> reg move instruction -- @@ -678,8 +678,7 @@ data Instr -- - fmsub : d = - r1 * r2 + r3 -- - fnmadd: d = - r1 * r2 - r3 FMA FMASign Operand Operand Operand Operand - | -- TODO: Care about the variants (<instr>.x.y) -> sum type - VMV Operand Operand + | VMV Operand Operand | VID Operand | VMSEQ Operand Operand Operand | VMERGE Operand Operand Operand Operand @@ -816,21 +815,17 @@ data Operand OpAddr AddrMode deriving (Eq, Show) --- TODO: This just wraps a constructor... Inline? -operandFromReg :: Format -> Reg -> Operand -operandFromReg = OpReg - operandFromRegNo :: Format -> RegNo -> Operand -operandFromRegNo fmt = operandFromReg fmt . regSingle +operandFromRegNo fmt = OpReg fmt . regSingle zero, ra, sp, gp, tp, fp, tmp :: Operand -zero = operandFromReg II64 zeroReg -ra = operandFromReg II64 raReg -sp = operandFromReg II64 spMachReg +zero = OpReg II64 zeroReg +ra = OpReg II64 raReg +sp = OpReg II64 spMachReg gp = operandFromRegNo II64 3 tp = operandFromRegNo II64 4 fp = operandFromRegNo II64 8 -tmp = operandFromReg II64 tmpReg +tmp = OpReg II64 tmpReg x0, x1, x2, x3, x4, x5, x6, x7 :: Operand x8, x9, x10, x11, x12, x13, x14, x15 :: Operand @@ -844,13 +839,9 @@ x4 = operandFromRegNo II64 4 x5 = operandFromRegNo II64 x5RegNo x6 = operandFromRegNo II64 6 x7 = operandFromRegNo II64 x7RegNo - x8 = operandFromRegNo II64 8 - x9 = operandFromRegNo II64 9 - x10 = operandFromRegNo II64 x10RegNo - x11 = operandFromRegNo II64 11 x12 = operandFromRegNo II64 12 x13 = operandFromRegNo II64 13 @@ -885,53 +876,29 @@ d4 = operandFromRegNo FF64 36 d5 = operandFromRegNo FF64 37 d6 = operandFromRegNo FF64 38 d7 = operandFromRegNo FF64 d7RegNo - d8 = operandFromRegNo FF64 40 - d9 = operandFromRegNo FF64 41 - d10 = operandFromRegNo FF64 d10RegNo - d11 = operandFromRegNo FF64 43 - d12 = operandFromRegNo FF64 44 - d13 = operandFromRegNo FF64 45 - d14 = operandFromRegNo FF64 46 - d15 = operandFromRegNo FF64 47 - d16 = operandFromRegNo FF64 48 - d17 = operandFromRegNo FF64 d17RegNo - d18 = operandFromRegNo FF64 50 - d19 = operandFromRegNo FF64 51 - d20 = operandFromRegNo FF64 52 - d21 = operandFromRegNo FF64 53 - d22 = operandFromRegNo FF64 54 - d23 = operandFromRegNo FF64 55 - d24 = operandFromRegNo FF64 56 - d25 = operandFromRegNo FF64 57 - d26 = operandFromRegNo FF64 58 - d27 = operandFromRegNo FF64 59 - d28 = operandFromRegNo FF64 60 - d29 = operandFromRegNo FF64 61 - d30 = operandFromRegNo FF64 62 - d31 = operandFromRegNo FF64 d31RegNo fitsIn12bitImm :: (Num a, Ord a, Bits a) => a -> Bool ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -2,6 +2,7 @@ module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where +import Data.Maybe import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -155,7 +156,11 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = ) ) where - instrs' = injectVectorConfig (toOL optInstrs) + instrs' :: OrdList Instr + instrs' + | isJust (ncgVectorMinBits config) = injectVectorConfig (toOL optInstrs) + | otherwise = toOL optInstrs + -- TODO: Check if we can filter more instructions here. -- TODO: Shouldn't this be a more general check on a higher level? And, is this still needed? -- Filter out identity moves. E.g. mov x18, x18 will be dropped. @@ -168,8 +173,6 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = injectVectorConfig instrs = fst $ foldlOL injectVectorConfig' (nilOL, Nothing) instrs -- TODO: Fuse this with optInstrs - -- TODO: Check config and only run this when vectors are configured - -- TODO: Check if vectorMinBits is sufficient for the vector config injectVectorConfig' :: (OrdList Instr, Maybe Format) -> Instr -> (OrdList Instr, Maybe Format) injectVectorConfig' (accInstr, configuredVecFmt) currInstr = let configuredVecFmt' Nothing = Nothing @@ -217,14 +220,16 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) = ) configVec :: Format -> Instr - configVec (VecFormat length fmt) = - VSETIVLI - (OpReg II64 zeroReg) - (fromIntegral length) - ((formatToWidth . scalarFormatFormat) fmt) - M1 - TA - MA + configVec vFmt@(VecFormat length fmt) + | Just vlen <- (ncgVectorMinBits config), + (formatInBytes vFmt) * 8 <= fromIntegral vlen = + VSETIVLI + (OpReg II64 zeroReg) + (fromIntegral length) + ((formatToWidth . scalarFormatFormat) fmt) + M1 + TA + MA configVec fmt = pprPanic "Unsupported vector configuration" ((text . show) fmt) asmLbl = blockLbl blockid @@ -620,7 +625,6 @@ pprInstr platform instr = case instr of | isFloatRegOp o1 && isIntRegOp o2 && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2 | isIntRegOp o1 && isFloatRegOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2 | isIntRegOp o1 && isFloatRegOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2 - -- TODO: Why does this NOP (reg1 == reg2) happen? | isVectorRegOp o1 && isVectorRegOp o2 -> op2 (text "\tvmv.v.v") o1 o2 | (OpImm (ImmInteger i)) <- o2, fitsIn12bitImm i -> @@ -833,7 +837,6 @@ pprInstr platform instr = case instr of VMERGE o1 o2 o3 o4 -> pprPanic "RV64.pprInstr - VMERGE wrong operands." (pprOps platform [o1, o2, o3, o4]) VSLIDEDOWN o1 o2 o3 | allVectorRegOps [o1, o2] && isIntOp o3 -> op3 (text "\tvslidedown.vx") o1 o2 o3 VSLIDEDOWN o1 o2 o3 -> pprPanic "RV64.pprInstr - VSLIDEDOWN wrong operands." (pprOps platform [o1, o2, o3]) - -- TODO: adjust VSETIVLI to contain only format? VSETIVLI (OpReg fmt dst) len width grouping ta ma -> line $ text "\tvsetivli" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b1096a6b4db4c53085f53cff62572… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b1096a6b4db4c53085f53cff62572… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/spec_tyfams] 19 commits: compiler: Import AnnotationWrapper from ghc-internal
by Simon Peyton Jones (＠simonpj) 12 Jul '25

12 Jul '25

Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC Commits: 67957854 by Ben Gamari at 2025-07-09T09:44:44-04:00 compiler: Import AnnotationWrapper from ghc-internal Since `GHC.Desugar` exported from `base` has been deprecated. - - - - - 813d99d6 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-compact: Eliminate dependency on ghc-prim - - - - - 0ec952a1 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Eliminate dependency on ghc-prim - - - - - 480074c3 by Ben Gamari at 2025-07-09T09:44:44-04:00 ghc-heap: Drop redundant import - - - - - 03455829 by Ben Gamari at 2025-07-09T09:44:45-04:00 ghc-prim: Bump version to 0.13.1 There are no interface changes from 0.13.0 but the implementation now lives in `ghc-internal`. - - - - - d315345a by Ben Gamari at 2025-07-09T09:44:45-04:00 template-haskell: Bump version number to 2.24.0.0 Bumps exceptions submodule. - - - - - 004c800e by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump GHC version number to 9.14 - - - - - eb1a3816 by Ben Gamari at 2025-07-09T09:44:45-04:00 Bump parsec to 3.1.18.0 Bumps parsec submodule. - - - - - 86f83296 by Ben Gamari at 2025-07-09T09:44:45-04:00 unix: Bump to 2.8.7.0 Bumps unix submodule. - - - - - 89e13998 by Ben Gamari at 2025-07-09T09:44:45-04:00 binary: Bump to 0.8.9.3 Bumps binary submodule. - - - - - 55fff191 by Ben Gamari at 2025-07-09T09:44:45-04:00 Win32: Bump to 2.14.2.0 Bumps Win32 submodule. - - - - - 7dafa40c by Ben Gamari at 2025-07-09T09:44:45-04:00 base: Bump version to 4.22.0 Bumps various submodules. - - - - - ef03d8b8 by Rodrigo Mesquita at 2025-07-09T09:45:28-04:00 base: Export displayExceptionWithInfo This function should be exposed from base following CLC#285 Approved change in CLC#344 Fixes #26058 - - - - - 01d3154e by Wen Kokke at 2025-07-10T17:06:36+01:00 Fix documentation for HEAP_PROF_SAMPLE_STRING - - - - - ac259c48 by Wen Kokke at 2025-07-10T17:06:38+01:00 Fix documentation for HEAP_PROF_SAMPLE_COST_CENTRE - - - - - 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Specialise: Improve specialisation by refactoring interestingDict This MR addresses #26051, which concerns missed type-class specialisation. The main payload of the MR is to completely refactor the key function `interestingDict` in GHC.Core.Opt.Specialise The main change is that we now also look at the structure of the dictionary we consider specializing on, rather than only the type. See the big `Note [Interesting dictionary arguments]` - - - - - ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00 Treat tuple dictionaries uniformly; don't unbox them See `Note [Do not unbox class dictionaries]` in DmdAnal.hs, sep (DNB1). This MR reverses the plan in #23398, which suggested a special case to unbox tuple dictionaries in worker/wrapper. But: - This was the cause of a pile of complexity in the specialiser (#26158) - Even with that complexity, specialision was still bad, very bad See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 And it's entirely unnecessary! Specialision works fine without unboxing tuple dictionaries. - - - - - be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Remove complex special case from the type-class specialiser There was a pretty tricky special case in Specialise which is no longer necessary. * Historical Note [Floating dictionaries out of cases] * #26158 * #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 This MR removes it. Hooray. - - - - - 65 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/eventlog-formats.rst - libraries/Win32 - libraries/array - libraries/base/base.cabal.in - libraries/base/src/Control/Exception.hs - libraries/binary - libraries/deepseq - libraries/directory - libraries/exceptions - libraries/filepath - libraries/ghc-boot-th/ghc-boot-th.cabal.in - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-compact/GHC/Compact.hs - libraries/ghc-compact/GHC/Compact/Serialized.hs - libraries/ghc-compact/ghc-compact.cabal - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-prim/changelog.md - libraries/ghc-prim/ghc-prim.cabal - libraries/ghci/ghci.cabal.in - libraries/haskeline - libraries/hpc - libraries/os-string - libraries/parsec - libraries/process - libraries/semaphore-compat - libraries/stm - libraries/template-haskell/template-haskell.cabal.in - libraries/terminfo - libraries/text - libraries/unix - testsuite/tests/dmdanal/should_compile/T23398.hs - testsuite/tests/dmdanal/should_compile/T23398.stderr - 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/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26051.hs - + testsuite/tests/simplCore/should_compile/T26051.stderr - + testsuite/tests/simplCore/should_compile/T26051_Import.hs - testsuite/tests/simplCore/should_compile/all.T - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/haddock/haddock-library/haddock-library.cabal - utils/haddock/haddock-test/haddock-test.cabal - utils/haddock/haddock.cabal - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68e88cfcde40ccfef20b6f8751056d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68e88cfcde40ccfef20b6f8751056d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 15 commits: Formatting
by Sven Tennie (＠supersven) 12 Jul '25

12 Jul '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: 3ba1b71a by Sven Tennie at 2025-07-12T10:22:24+02:00 Formatting - - - - - 1d7e1328 by Sven Tennie at 2025-07-12T12:17:04+02:00 Add haddock - - - - - cfce9319 by Sven Tennie at 2025-07-12T12:25:26+02:00 Haddock - - - - - ebdf9753 by Sven Tennie at 2025-07-12T12:36:54+02:00 Add calculations to TrivColorable - - - - - 3b1e5c9b by Sven Tennie at 2025-07-12T12:57:18+02:00 Better allocReg check (check upper boundary for floats) - - - - - c0eed9cf by Sven Tennie at 2025-07-12T13:11:19+02:00 point free: floatVecFormat & intVecFormat - - - - - fe65c5c0 by Sven Tennie at 2025-07-12T13:12:16+02:00 Delete trailing whitespace - - - - - 98247b80 by Sven Tennie at 2025-07-12T13:13:44+02:00 Formatting - - - - - 2331c9b8 by Sven Tennie at 2025-07-12T13:15:12+02:00 Comment t Haddock - - - - - 60d5833a by Sven Tennie at 2025-07-12T13:25:50+02:00 Cleanup session functions - - - - - aa346342 by Sven Tennie at 2025-07-12T13:40:04+02:00 Update comment - - - - - e986d733 by Sven Tennie at 2025-07-12T13:45:29+02:00 Formatting / better error message - - - - - 06d5126d by Sven Tennie at 2025-07-12T14:17:21+02:00 Prepare for more cpu_features - - - - - f4e033f9 by Sven Tennie at 2025-07-12T14:21:33+02:00 Improve comment - - - - - 2b1096a6 by Sven Tennie at 2025-07-12T14:45:47+02:00 cpuinfo.py: Better comments - - - - - 14 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/RV64.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs - compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs - compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/StgToCmm/Prim.hs - m4/fp_riscv_check_gcc_version.m4 - testsuite/driver/cpu_features.py - testsuite/driver/cpuinfo.py - testsuite/driver/testlib.py Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -213,10 +213,10 @@ vecFormat ty = _ -> pprPanic "Incorrect vector element width" (ppr elemTy) floatVecFormat :: Int -> Width -> Format -floatVecFormat length width = vecFormat (cmmVec length (cmmFloat width)) +floatVecFormat length = vecFormat . cmmVec length . cmmFloat intVecFormat :: Int -> Width -> Format -intVecFormat length width = vecFormat (cmmVec length (cmmBits width)) +intVecFormat length = vecFormat . cmmVec length . cmmBits -- | Check if a format represents a vector isVecFormat :: Format -> Bool ===================================== compiler/GHC/CmmToAsm/RV64.hs ===================================== @@ -49,7 +49,7 @@ instance Instruction RV64.Instr where mkLoadInstr = RV64.mkLoadInstr takeDeltaInstr = RV64.takeDeltaInstr isMetaInstr = RV64.isMetaInstr - mkRegRegMoveInstr _ = RV64.mkRegRegMoveInstr + mkRegRegMoveInstr _ = RV64.mkRegRegMoveInstr takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr mkJumpInstr = RV64.mkJumpInstr mkStackAllocInstr = RV64.mkStackAllocInstr ===================================== compiler/GHC/CmmToAsm/RV64/Regs.hs ===================================== @@ -123,13 +123,12 @@ tmpReg = regSingle tmpRegNo v0Reg :: Reg v0Reg = regSingle v0RegNo --- | All machine register numbers. Including potential vector registers. +-- | All machine register numbers, including potential vector registers. allMachRegNos :: [RegNo] allMachRegNos = intRegs ++ fpRegs ++ vRegs where intRegs = [x0RegNo .. x31RegNo] fpRegs = [d0RegNo .. d31RegNo] - -- TODO: If Vector extension is turned off, this should become the empty list vRegs = [v0RegNo .. v31RegNo] -- | Registers available to the register allocator. @@ -138,10 +137,10 @@ allMachRegNos = intRegs ++ fpRegs ++ vRegs -- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6, -- D1..D6.) -- --- We pretend that vector registers are always available. If they aren't, we --- simply don't emit instructions using them. This is much simpler than fixing --- the register allocators which expect a configuration per platform (which we --- can only set when GHC itself gets build.) +-- We pretend that vector registers (RVV 1.0) are always available. If they +-- aren't, we simply don't emit instructions using them. This is much simpler +-- than fixing the register allocators which expect a configuration per +-- platform (which we can only set when GHC itself gets built.) allocatableRegs :: Platform -> [RealReg] allocatableRegs platform = let isFree = freeReg platform @@ -159,6 +158,7 @@ allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo] allVecRegs :: [Reg] allVecRegs = map regSingle [v0RegNo .. v31RegNo] +-- | Vector argument `Reg`s according to the calling convention allVecArgRegs :: [Reg] allVecArgRegs = map regSingle [v8RegNo .. v23RegNo] ===================================== compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs ===================================== @@ -144,8 +144,8 @@ allocatableRegs arch rc = ArchMipsel -> panic "trivColorable ArchMipsel" ArchS390X -> panic "trivColorable ArchS390X" ArchRISCV64 -> case rc of - Separate.RcInteger -> 14 -- TODO: Write the calculation of this magic number down. And, fix the value if needed. - Separate.RcFloat -> 20 -- TODO: See riscv64.h for TODO. + Separate.RcInteger -> 32 - 7 - 11 -- 32 - (zero, lr, sp, gp, tp, fp, tmp) - 11 STG regs + Separate.RcFloat -> 32 - 2 * 6 -- 32 - float STG regs - double STG regs | TODO: See riscv64.h for TODO. Separate.RcVector -> 32 - 6 - 1 -- 32 - pc_MAX_Real_XMM_REG - 1 mask_register ArchLoongArch64 -> case rc of Separate.RcInteger -> 16 ===================================== compiler/GHC/CmmToAsm/Reg/Linear/RV64.hs ===================================== @@ -71,7 +71,6 @@ getFreeRegs cls (FreeRegs g f v) = case cls of RcInteger -> go 0 g allocatableIntRegs RcFloat -> go 32 f allocatableDoubleRegs - -- TODO: If there's no Vector support, we should return an empty list or panic. RcVector -> go 64 v allocatableVectorRegs where go _ _ [] = [] @@ -90,7 +89,7 @@ getFreeRegs cls (FreeRegs g f v) = allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f v) | r < 32 && testBit g r = FreeRegs (clearBit g r) f v - | r >= 32 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) v + | r >= 32 && r <= 63 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) v | r >= 64 && testBit v (r - 64) = FreeRegs g f (clearBit v (r - 64)) | otherwise = pprPanic "Linear.RV64.allocateReg" ===================================== compiler/GHC/Driver/Config/StgToCmm.hs ===================================== @@ -88,7 +88,7 @@ initStgToCmmConfig dflags mod = StgToCmmConfig , stgToCmmAvx = isAvxEnabled dflags , stgToCmmAvx2 = isAvx2Enabled dflags , stgToCmmAvx512f = isAvx512fEnabled dflags - , stgToCmmVectorMinBits = vectorMinBits dflags + , stgToCmmVectorMinBits = vectorMinBits dflags , stgToCmmTickyAP = gopt Opt_Ticky_AP dflags -- See Note [Saving foreign call target to local] , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -449,7 +449,7 @@ data DynFlags = DynFlags { avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. avx512f :: Bool, -- Enable AVX-512 instructions. avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. - vectorMinBits :: Maybe Word, -- Minimal expected vector register width in bits (currently, RISCV-V only) + vectorMinBits :: Maybe Word, -- ^ Minimal expected vector register width in bits (currently, RISCV-V only) fma :: Bool, -- ^ Enable FMA instructions. -- Constants used to control the amount of optimization done. ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2864,7 +2864,7 @@ word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) word64Suffix fn = Word64Suffix (\n -> upd (fn n)) word64SuffixM :: (Word64 -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -word64SuffixM fn = Word64Suffix (\n -> updM (fn n)) +word64SuffixM fn = Word64Suffix (updM . fn) floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) floatSuffix fn = FloatSuffix (\n -> upd (fn n)) @@ -3850,12 +3850,11 @@ updatePlatformConstants dflags mconstants = do return dflags1 setVectorMinBits :: Word64 -> DynFlags -> DynP DynFlags -setVectorMinBits v dflags = - let validValues = [16,32,64,128,256,512] - in +setVectorMinBits v dflags = + let validValues = [16, 32, 64, 128, 256, 512] + in if v `elem` validValues then - pure $ dflags { vectorMinBits = (Just . fromIntegral) v} + pure $ dflags { vectorMinBits = (Just . fromIntegral) v} else do - addErr ("Minimal vector register size can only be one of" ++ show validValues) + addErr ("Minimal vector register size can only be one of: " ++ show validValues) pure dflags - ===================================== compiler/GHC/StgToCmm/Config.hs ===================================== @@ -76,12 +76,11 @@ data StgToCmmConfig = StgToCmmConfig , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. , stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see -- Note [Saving foreign call target to local] for details - -- TODO: Update comment ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested - -- during compilation. In essence, this means checking for @-fllvm@ which is - -- the only backend that currently allows SIMD instructions, see - -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags only call site. + -- during compilation. Some backends (e.g. the C backend) or architectures + -- don't implement SIMD instructions, see + -- Ghc.StgToCmm.Prim.checkVecCompatibility for these flags' only call site. , stgToCmmVecInstrsErr :: Maybe String -- ^ Error (if any) to raise when vector instructions are -- used, see @StgToCmm.Prim.checkVecCompatibility@ , stgToCmmAvx :: !Bool -- ^ check for Advanced Vector Extensions ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -2637,11 +2637,15 @@ checkVecCompatibility cfg vcat l w = checkRISCV64 :: Width -> FCode () checkRISCV64 w = case stgToCmmVectorMinBits cfg of - Nothing -> sorry "Vector support has not been configured." + Nothing -> sorry "Vector support has not been configured. Check '-mriscv-vlen'." Just w' | widthInBits w <= fromIntegral w' -> return () Just w' -> sorry - $ "Vector size is " ++ show w ++ ", but only " ++ show w' ++ " configured." + $ "Vector width is " + ++ show w + ++ ", but only " + ++ show w' + ++ " configured. Check '-mriscv-vlen'." vecWidth = typeWidth (vecCmmType vcat l w) ===================================== m4/fp_riscv_check_gcc_version.m4 ===================================== @@ -18,7 +18,7 @@ AC_DEFUN([FP_RISCV_CHECK_GCC_VERSION], [ AC_REQUIRE([FP_GCC_VERSION]) AC_REQUIRE([AC_CANONICAL_TARGET]) - # + # Check if target is RISC-V case "$target" in riscv64*-*-*) ===================================== testsuite/driver/cpu_features.py ===================================== @@ -14,7 +14,8 @@ SUPPORTED_CPU_FEATURES = { 'popcnt', 'bmi1', 'bmi2', # riscv: - 'zvl128b', 'zvl256b', 'zvl512b' + 'zvl32b', 'zvl64b', 'zvl128b', 'zvl256b', 'zvl512b', + 'zvl1024b' } cpu_feature_cache = None ===================================== testsuite/driver/cpuinfo.py ===================================== @@ -2126,8 +2126,9 @@ def _get_cpu_info_from_ibm_pa_features(): def _get_cpu_info_from_riscv_isa(): ''' - Returns the CPU info gathered from 'cat /proc/device-tree/cpus/cpu@0/riscv,isa' - Returns {} if this file does not exist (i.e. we're not on RISC-V Linux) + Returns the CPU info gathered from 'cat + /proc/device-tree/cpus/cpu@0/riscv,isa' (Linux) and/or tries to figure out + vector extensions by running assembly code. ''' def remove_prefix(prefix, text): @@ -2165,10 +2166,10 @@ def _get_cpu_info_from_riscv_isa(): flags = output.split('_') - # The usage of the Zvl* extensions in the industry is very - # inconsistent. Though, they are useful to communicate the VLEN. So, if - # they are not provided by the system, we try to figure them out on our - # own. + # The usage of the Zvl* extensions in the industry is very + # inconsistent. Though, they are useful to communicate the VLEN. So, if + # they are not provided by the system, we try to figure them out on our + # own. # E.g. rv64imafdcvh arch_string = flags[0] ===================================== testsuite/driver/testlib.py ===================================== @@ -424,7 +424,8 @@ def req_fma_cpu( name, opts ): Require FMA support. """ - # RISC-V: Imply float and double extensions, so we only have to change for vectors. + # RISC-V: We imply float and double extensions (rv64g), so we only have to + # check for vector support. if not(have_cpu_feature('avx') or have_cpu_feature('zvl128b')): opts.skip = True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a40bf1997b45830062c9558c8273f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6a40bf1997b45830062c9558c8273f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/supersven/riscv-vectors] 4 commits: Adjust vector check in all.T
by Sven Tennie (＠supersven) 12 Jul '25

12 Jul '25

Sven Tennie pushed to branch wip/supersven/riscv-vectors at Glasgow Haskell Compiler / GHC Commits: 696d1213 by Sven Tennie at 2025-07-04T18:34:51+02:00 Adjust vector check in all.T - - - - - d00766d6 by Sven Tennie at 2025-07-04T19:10:44+02:00 Print vectors to show that the stack is intact - - - - - 897fd7be by Sven Tennie at 2025-07-05T15:56:24+02:00 Check for GCC >= 14 in autoconf - - - - - 6a40bf19 by Sven Tennie at 2025-07-05T19:51:24+02:00 VectorCCallConv test: Test doubles as well - - - - - 8 changed files: - configure.ac - distrib/configure.ac.in - + m4/fp_riscv_check_gcc_version.m4 - testsuite/driver/testlib.py - testsuite/tests/simd/should_run/VectorCCallConv.hs - testsuite/tests/simd/should_run/VectorCCallConv.stdout - testsuite/tests/simd/should_run/VectorCCallConv_c.c - testsuite/tests/simd/should_run/all.T Changes: ===================================== configure.ac ===================================== @@ -612,9 +612,10 @@ AC_SYS_INTERPRETER() dnl ** look for GCC and find out which version dnl Figure out which C compiler to use. Gcc is preferred. -dnl If gcc, make sure it's at least 4.7 +dnl If gcc, make sure it's at least 4.7 (14 for RISC-V 64bit) dnl FP_GCC_VERSION +FP_RISCV_CHECK_GCC_VERSION dnl ** Check support for the extra flags passed by GHC when compiling via C ===================================== distrib/configure.ac.in ===================================== @@ -225,6 +225,7 @@ dnl ** Check gcc version and flags we need to pass it ** FP_GCC_VERSION FP_GCC_SUPPORTS_NO_PIE FP_GCC_SUPPORTS_VIA_C_FLAGS +FP_RISCV_CHECK_GCC_VERSION FPTOOLS_SET_C_LD_FLAGS([target],[CFLAGS],[LDFLAGS],[IGNORE_LINKER_LD_FLAGS],[CPPFLAGS]) FPTOOLS_SET_C_LD_FLAGS([build],[CONF_CC_OPTS_STAGE0],[CONF_GCC_LINKER_OPTS_STAGE0],[CONF_LD_LINKER_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) ===================================== m4/fp_riscv_check_gcc_version.m4 ===================================== @@ -0,0 +1,37 @@ +# FP_RISCV_CHECK_GCC_VERSION +# +# We cannot use all GCC versions that are generally supported: Up to +# (including) GCC 13, GCC does not support the expected C calling convention +# for vectors. Thus, we require at least GCC 14. +# +# Details: GCC 13 expects vector arguments to be passed on stack / by +# reference, though the "Standard Vector Calling Convention Variant" +# (https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/master/riscv-cc.a…) +# - which is the new default (e.g. for GCC 14) - expects vector arguments in +# registers v8 to v23. I guess, this is due to the "Standard Vector Calling +# Convention Variant" being pretty new. And, the GCC implementors had to make +# up design decissions before this part of the standard has been ratified. +# As long as the calling convention is consistently used for all code, this +# isn't an issue. But, we have to be able to call C functions compiled by GCC +# with code emitted by GHC. + +AC_DEFUN([FP_RISCV_CHECK_GCC_VERSION], [ + AC_REQUIRE([FP_GCC_VERSION]) + AC_REQUIRE([AC_CANONICAL_TARGET]) + # + # Check if target is RISC-V + case "$target" in + riscv64*-*-*) + AC_MSG_NOTICE([Assert GCC version for RISC-V. Detected version is $GccVersion]) + if test -n "$GccVersion"; then + AC_CACHE_CHECK([risc-v version of gcc], [fp_riscv_check_gcc_version], [ + FP_COMPARE_VERSIONS([$GccVersion], [-lt], [14.0], + [AC_MSG_ERROR([Need at least GCC version 14 for RISC-V])], + [AC_MSG_RESULT([good])] + ) + ]) + fi + ;; + # Ignore riscv32*-*-* as we don't have a NCG for RISC-V 32bit targets + esac +]) ===================================== testsuite/driver/testlib.py ===================================== @@ -416,7 +416,7 @@ def req_basic_simd_cpu( name, opts ): - PowerPC with AltiVec (not currently supported) """ - if not (arch('aarch64') or have_cpu_feature('sse2') or have_cpu_feature('zvl128b')): + if not (arch('aarch64') or have_cpu_feature('sse2') or have_cpu_feature('zvl128b')): opts.skip = True def req_fma_cpu( name, opts ): ===================================== testsuite/tests/simd/should_run/VectorCCallConv.hs ===================================== @@ -7,6 +7,7 @@ module Main where import Data.Int +import GHC.Float import GHC.Int import GHC.Prim import System.IO @@ -38,46 +39,151 @@ unpackInt64X2 :: Int64X2# -> (Int64, Int64) unpackInt64X2 v = case unpackInt64X2# v of (# x0, x1 #) -> (I64# x0, I64# x1) +foreign import ccall "printVecs_doublex2_c" + printVecs_doublex2# :: + DoubleX2# -> -- v8 + DoubleX2# -> -- v9 + DoubleX2# -> -- v10 + DoubleX2# -> -- v11 + DoubleX2# -> -- v12 + DoubleX2# -> -- v13 + DoubleX2# -> -- v14 + DoubleX2# -> -- v15 + DoubleX2# -> -- v16 + DoubleX2# -> -- v17 + DoubleX2# -> -- v18 + DoubleX2# -> -- v19 + DoubleX2# -> -- v20 + DoubleX2# -> -- v21 + DoubleX2# -> -- v22 + DoubleX2# -> -- v23 + IO () + +foreign import ccall "return_doubleX2" + return_doubleX2# :: (# #) -> DoubleX2# + +unpackDoubleX2 :: DoubleX2# -> (Double, Double) +unpackDoubleX2 v = case unpackDoubleX2# v of + (# x0, x1 #) -> (D# x0, D# x1) + main :: IO () main = do -- Use some negative values to fill more bits and discover possible overlaps. - let v8 = packInt64X2# (# 0#Int64, -1#Int64 #) - v9 = packInt64X2# (# -2#Int64, 3#Int64 #) - v10 = packInt64X2# (# -4#Int64, 5#Int64 #) - v11 = packInt64X2# (# -6#Int64, 7#Int64 #) - v12 = packInt64X2# (# -8#Int64, 9#Int64 #) - v13 = packInt64X2# (# -10#Int64, 11#Int64 #) - v14 = packInt64X2# (# -12#Int64, 13#Int64 #) - v15 = packInt64X2# (# -14#Int64, 15#Int64 #) - v16 = packInt64X2# (# -16#Int64, 17#Int64 #) - v17 = packInt64X2# (# -18#Int64, 19#Int64 #) - v18 = packInt64X2# (# -20#Int64, 21#Int64 #) - v19 = packInt64X2# (# -22#Int64, 23#Int64 #) - v20 = packInt64X2# (# -24#Int64, 25#Int64 #) - v21 = packInt64X2# (# -26#Int64, 27#Int64 #) - v22 = packInt64X2# (# -28#Int64, 29#Int64 #) - v23 = packInt64X2# (# -30#Int64, 31#Int64 #) - - print "Arguments" + let int_v8 = packInt64X2# (# 0#Int64, -1#Int64 #) + int_v9 = packInt64X2# (# -2#Int64, 3#Int64 #) + int_v10 = packInt64X2# (# -4#Int64, 5#Int64 #) + int_v11 = packInt64X2# (# -6#Int64, 7#Int64 #) + int_v12 = packInt64X2# (# -8#Int64, 9#Int64 #) + int_v13 = packInt64X2# (# -10#Int64, 11#Int64 #) + int_v14 = packInt64X2# (# -12#Int64, 13#Int64 #) + int_v15 = packInt64X2# (# -14#Int64, 15#Int64 #) + int_v16 = packInt64X2# (# -16#Int64, 17#Int64 #) + int_v17 = packInt64X2# (# -18#Int64, 19#Int64 #) + int_v18 = packInt64X2# (# -20#Int64, 21#Int64 #) + int_v19 = packInt64X2# (# -22#Int64, 23#Int64 #) + int_v20 = packInt64X2# (# -24#Int64, 25#Int64 #) + int_v21 = packInt64X2# (# -26#Int64, 27#Int64 #) + int_v22 = packInt64X2# (# -28#Int64, 29#Int64 #) + int_v23 = packInt64X2# (# -30#Int64, 31#Int64 #) + + double_v8 = packDoubleX2# (# 0.0##, -1.0## #) + double_v9 = packDoubleX2# (# -2.0##, 3.0## #) + double_v10 = packDoubleX2# (# -4.0##, 5.0## #) + double_v11 = packDoubleX2# (# -6.0##, 7.0## #) + double_v12 = packDoubleX2# (# -8.0##, 9.0## #) + double_v13 = packDoubleX2# (# -10.0##, 11.0## #) + double_v14 = packDoubleX2# (# -12.0##, 13.0## #) + double_v15 = packDoubleX2# (# -14.0##, 15.0## #) + double_v16 = packDoubleX2# (# -16.0##, 17.0## #) + double_v17 = packDoubleX2# (# -18.0##, 19.0## #) + double_v18 = packDoubleX2# (# -20.0##, 21.0## #) + double_v19 = packDoubleX2# (# -22.0##, 23.0## #) + double_v20 = packDoubleX2# (# -24.0##, 25.0## #) + double_v21 = packDoubleX2# (# -26.0##, 27.0## #) + double_v22 = packDoubleX2# (# -28.0##, 29.0## #) + double_v23 = packDoubleX2# (# -30.0##, 31.0## #) + + print "Arguments (int)" hFlush stdout printVecs_int64x2# - v8 - v9 - v10 - v11 - v12 - v13 - v14 - v15 - v16 - v17 - v18 - v19 - v20 - v21 - v22 - v23 - - print "Return values" + int_v8 + int_v9 + int_v10 + int_v11 + int_v12 + int_v13 + int_v14 + int_v15 + int_v16 + int_v17 + int_v18 + int_v19 + int_v20 + int_v21 + int_v22 + int_v23 + + print "Arguments (double)" + hFlush stdout + printVecs_doublex2# + double_v8 + double_v9 + double_v10 + double_v11 + double_v12 + double_v13 + double_v14 + double_v15 + double_v16 + double_v17 + double_v18 + double_v19 + double_v20 + double_v21 + double_v22 + double_v23 + + print "Return values (int)" let v = return_int64X2# (# #) print $ unpackInt64X2 v + + print "Return values (double)" + let v = return_doubleX2# (# #) + print $ unpackDoubleX2 v + + -- Check that these registers weren't messed up + print "Initial vectors (int)" + print $ unpackInt64X2 int_v8 + print $ unpackInt64X2 int_v9 + print $ unpackInt64X2 int_v10 + print $ unpackInt64X2 int_v11 + print $ unpackInt64X2 int_v12 + print $ unpackInt64X2 int_v13 + print $ unpackInt64X2 int_v14 + print $ unpackInt64X2 int_v15 + print $ unpackInt64X2 int_v16 + print $ unpackInt64X2 int_v17 + print $ unpackInt64X2 int_v18 + print $ unpackInt64X2 int_v19 + print $ unpackInt64X2 int_v20 + print $ unpackInt64X2 int_v21 + print $ unpackInt64X2 int_v22 + print $ unpackInt64X2 int_v23 + + print "Initial vectors (double)" + print $ unpackDoubleX2 double_v8 + print $ unpackDoubleX2 double_v9 + print $ unpackDoubleX2 double_v10 + print $ unpackDoubleX2 double_v11 + print $ unpackDoubleX2 double_v12 + print $ unpackDoubleX2 double_v13 + print $ unpackDoubleX2 double_v14 + print $ unpackDoubleX2 double_v15 + print $ unpackDoubleX2 double_v16 + print $ unpackDoubleX2 double_v17 + print $ unpackDoubleX2 double_v18 + print $ unpackDoubleX2 double_v19 + print $ unpackDoubleX2 double_v20 + print $ unpackDoubleX2 double_v21 + print $ unpackDoubleX2 double_v22 + print $ unpackDoubleX2 double_v23 ===================================== testsuite/tests/simd/should_run/VectorCCallConv.stdout ===================================== @@ -1,4 +1,4 @@ -"Arguments" +"Arguments (int)" [0, -1] [-2, 3] [-4, 5] @@ -15,5 +15,58 @@ [-26, 27] [-28, 29] [-30, 31] -"Return values" +"Arguments (double)" +[0.000000, -1.000000] +[-2.000000, 3.000000] +[-4.000000, 5.000000] +[-6.000000, 7.000000] +[-8.000000, 9.000000] +[-10.000000, 11.000000] +[-12.000000, 13.000000] +[-14.000000, 15.000000] +[-16.000000, 17.000000] +[-18.000000, 19.000000] +[-20.000000, 21.000000] +[-22.000000, 23.000000] +[-24.000000, 25.000000] +[-26.000000, 27.000000] +[-28.000000, 29.000000] +[-30.000000, 31.000000] +"Return values (int)" (-9223372036854775808,9223372036854775807) +"Return values (double)" +(2.2250738585072014e-308,1.7976931348623157e308) +"Initial vectors (int)" +(0,-1) +(-2,3) +(-4,5) +(-6,7) +(-8,9) +(-10,11) +(-12,13) +(-14,15) +(-16,17) +(-18,19) +(-20,21) +(-22,23) +(-24,25) +(-26,27) +(-28,29) +(-30,31) +"Initial vectors (double)" +(0.0,-1.0) +(-2.0,3.0) +(-4.0,5.0) +(-6.0,7.0) +(-8.0,9.0) +(-10.0,11.0) +(-12.0,13.0) +(-14.0,15.0) +(-16.0,17.0) +(-18.0,19.0) +(-20.0,21.0) +(-22.0,23.0) +(-24.0,25.0) +(-26.0,27.0) +(-28.0,29.0) +(-30.0,31.0) ===================================== testsuite/tests/simd/should_run/VectorCCallConv_c.c ===================================== @@ -1,4 +1,5 @@ #include "riscv_vector.h" +#include <float.h> #include <stdio.h> static void printVec_int64(vint64m1_t v, int length) { @@ -44,3 +45,47 @@ vint64m1_t return_int64X2() { int64_t v[] = {INT64_MIN, INT64_MAX}; return __riscv_vle64_v_i64m1(v, 2); } + +static void printVec_double(vfloat64m1_t v, int length) { + // Extract and print elements from the vector register + double temp[length]; // Temporary array to hold vector elements + __riscv_vse64_v_f64m1(temp, v, length); // Store vector to memory + + printf("[%f", temp[0]); + for (int i = 1; i < length; i++) { + printf(", %f", temp[i]); + } + printf("]\n"); + fflush(stdout); +} +// Provide many vectors to enforce stack usage +void printVecs_doublex2_c(vfloat64m1_t v8, vfloat64m1_t v9, vfloat64m1_t v10, + vfloat64m1_t v11, vfloat64m1_t v12, vfloat64m1_t v13, + vfloat64m1_t v14, vfloat64m1_t v15, vfloat64m1_t v16, + vfloat64m1_t v17, vfloat64m1_t v18, vfloat64m1_t v19, + vfloat64m1_t v20, vfloat64m1_t v21, vfloat64m1_t v22, + vfloat64m1_t v23) { + printVec_double(v8, 2); + printVec_double(v9, 2); + printVec_double(v10, 2); + printVec_double(v11, 2); + printVec_double(v12, 2); + printVec_double(v13, 2); + printVec_double(v14, 2); + printVec_double(v15, 2); + printVec_double(v16, 2); + printVec_double(v17, 2); + printVec_double(v18, 2); + printVec_double(v19, 2); + printVec_double(v20, 2); + printVec_double(v21, 2); + printVec_double(v22, 2); + printVec_double(v23, 2); + + fflush(stdout); +} + +vfloat64m1_t return_doubleX2() { + double v[] = {DBL_MIN, DBL_MAX}; + return __riscv_vle64_v_f64m1(v, 2); +} ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -26,7 +26,7 @@ def riscvVlen(): elif have_cpu_feature('zvl512b'): return 512 else: - raise Exception("Vector extension not supported by CPU or VLEN too small.") + return 0 # Ensure we set the CPU features we have available. # @@ -35,7 +35,7 @@ def riscvVlen(): # with or without -mavx2. setTestOpts([ # TODO: -optc and -opta should not be required, but provided by the GHC pipeline - when(arch('riscv64'), extra_hc_opts('-mriscv-vlen' + str(riscvVlen()) + " -optc=-march=rv64gv -opta=-march=rv64gv")) + when(arch('riscv64') and (riscvVlen() > 0), extra_hc_opts('-mriscv-vlen' + str(riscvVlen()) + " -optc=-march=rv64gv -opta=-march=rv64gv")) ]) test('simd_insert_baseline', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80263d354b4743a66c458587ff8d17… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80263d354b4743a66c458587ff8d17… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/warning-for-last-and-init] Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial
by Bodigrim (＠Bodigrim) 12 Jul '25

12 Jul '25

Bodigrim pushed to branch wip/warning-for-last-and-init at Glasgow Haskell Compiler / GHC Commits: 8f16552d by Mike Pilgrem at 2025-07-12T01:04:22+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). - - - - - 17 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Prelude/Basic.hs - ghc/GHCi/UI.hs - ghc/Main.hs - 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/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - testsuite/tests/driver/j-space/jspace.hs - testsuite/tests/rts/KeepCafsBase.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -112,8 +112,7 @@ import GHC.Utils.Misc import Data.ByteString ( ByteString ) import Data.Function ( on ) -import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) -import qualified Data.List as Partial ( init, last ) +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL, unsnoc ) import Data.Ord ( comparing ) import Control.Monad ( guard ) import qualified Data.Set as Set @@ -1871,10 +1870,10 @@ app_ok fun_ok primop_ok fun args PrimOpId op _ | primOpIsDiv op - , Lit divisor <- Partial.last args + , Just (initArgs, Lit divisor) <- unsnoc args -- there can be 2 args (most div primops) or 3 args -- (WordQuotRem2Op), hence the use of last/init - -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) initArgs -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -183,7 +183,7 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) processSCCs [] = return () processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs - processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + processSCCs (NECyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) cycle_err uids = @@ -195,8 +195,8 @@ checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) ++ [text "-" <+> ppr final] where - start = init uids - final = last uids + start = NE.init uids + final = NE.last uids -- | Check that we don't have multiple units with the same UnitId. checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () ===================================== compiler/GHC/Prelude/Basic.hs ===================================== @@ -2,8 +2,8 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] --- See Note [Proxies for head and tail] -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} +-- See Note [Proxies for partial list functions] +{-# OPTIONS_GHC -Wno-x-partial #-} -- | Custom minimal GHC "Prelude" -- @@ -24,7 +24,7 @@ module GHC.Prelude.Basic , bit , shiftL, shiftR , setBit, clearBit - , head, tail, unzip + , head, tail, init, last, unzip , strictGenericLength ) where @@ -59,7 +59,7 @@ NoImplicitPrelude. There are two motivations for this: -} import qualified Prelude -import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, init, last, unzip) import Control.Applicative (Applicative(..)) import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) import Data.Foldable1 as X hiding (head, last) @@ -118,24 +118,35 @@ setBit = \ x i -> x Bits..|. bit i clearBit :: (Num a, Bits.Bits a) => a -> Int -> a clearBit = \ x i -> x Bits..&. Bits.complement (bit i) -{- Note [Proxies for head and tail] +{- Note [Proxies for partial list functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, +Prelude.head, Prelude.tail, Prelude.init and Prelude.last +have recently acquired {-# WARNING in "x-partial" #-}, but the GHC codebase uses them fairly extensively and insists on building warning-free. Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which employs them, we define warning-less proxies and export them from GHC.Prelude. -} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] head :: HasCallStack => [a] -> a head = Prelude.head {-# INLINE head #-} --- See Note [Proxies for head and tail] +-- See Note [Proxies for partial list functions] tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-} +-- See Note [Proxies for partial list functions] +init :: HasCallStack => [a] -> [a] +init = Prelude.init +{-# INLINE init #-} + +-- See Note [Proxies for partial list functions] +last :: HasCallStack => [a] -> a +last = Prelude.last +{-# INLINE last #-} + {- | The 'genericLength' function defined in base can't be specialised due to the NOINLINE pragma. ===================================== ghc/GHCi/UI.hs ===================================== @@ -133,7 +133,7 @@ import Data.Char import Data.Function import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) -import Data.List ( find, intercalate, intersperse, +import Data.List ( find, intercalate, intersperse, unsnoc, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.List.NonEmpty as NE import qualified Data.Set as S @@ -2399,9 +2399,9 @@ setContextAfterLoad keep_ctxt (Just graph) = do [] -> let graph' = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing - in case graph' of - [] -> setContextKeepingPackageModules keep_ctxt [] - xs -> load_this (last xs) + in case unsnoc graph' of + Nothing -> setContextKeepingPackageModules keep_ctxt [] + Just (_, lst) -> load_this lst (m:_) -> load_this m where ===================================== ghc/Main.hs ===================================== @@ -88,7 +88,7 @@ import System.Exit import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except (throwE, runExceptT) -import Data.List ( isPrefixOf, partition, intercalate ) +import Data.List ( isPrefixOf, partition, intercalate, unsnoc ) import Prelude import qualified Data.List.NonEmpty as NE @@ -115,8 +115,7 @@ main = do argv0 <- getArgs let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 - mbMinusB | null minusB_args = Nothing - | otherwise = Just (drop 2 (last minusB_args)) + mbMinusB = drop 2 . snd <$> unsnoc minusB_args let argv2 = map (mkGeneralLocated "on the commandline") argv1 ===================================== libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs ===================================== @@ -13,7 +13,7 @@ import GHC.Boot.TH.PprLib import GHC.Boot.TH.Syntax import Data.Word ( Word8 ) import Data.Char ( toLower, chr ) -import Data.List ( intersperse ) +import Data.List ( intersperse, unsnoc ) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) @@ -214,9 +214,10 @@ pprExp i (MDoE m ss_) = parensIf (i > noPrec) $ pprStms [s] = ppr s pprStms ss = braces (semiSep ss) -pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' -pprExp _ (CompE ss) = +pprExp _ (CompE ss) = case unsnoc ss of + Nothing -> text "<<Empty CompExp>>" + Just (ss', s) -> if null ss' -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. @@ -225,8 +226,6 @@ pprExp _ (CompE ss) = <+> bar <+> commaSep ss' <> text "]" - where s = last ss - ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -13,6 +13,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- For init in formatRealFloatAlt +{-# OPTIONS_GHC -Wno-x-partial #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Float ===================================== libraries/ghc-internal/src/GHC/Internal/List.hs ===================================== @@ -190,12 +190,18 @@ tail :: HasCallStack => [a] -> [a] tail (_:xs) = xs tail [] = errorEmptyList "tail" -{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} +{-# WARNING in "x-partial" tail "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'Data.List.uncons' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} -- | $\mathcal{O}(n)$. Extract the last element of a list, which must be -- finite and non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -218,10 +224,18 @@ last xs = foldl (\_ x -> x) lastError xs lastError :: HasCallStack => a lastError = errorEmptyList "last" +{-# WARNING in "x-partial" last "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(n)$. Return all the elements of a list except the last one. -- The list must be non-empty. -- --- WARNING: This function is partial. Consider using 'unsnoc' instead. +-- To disable the warning about partiality put +-- @{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}@ +-- at the top of the file. To disable it throughout a package put the same +-- options into @ghc-options@ section of Cabal file. To disable it in GHCi +-- put @:set -Wno-x-partial -Wno-unrecognised-warning-flags@ into @~/.ghci@ +-- config file. See also the +-- [migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides…. -- -- ==== __Examples__ -- @@ -240,6 +254,8 @@ init (x:xs) = init' x xs where init' _ [] = [] init' y (z:zs) = y : init' z zs +{-# WARNING in "x-partial" init "This is a partial function, it throws an error on empty lists. Use 'Data.List.unsnoc' instead. Consider refactoring to use \"Data.List.NonEmpty\"." #-} + -- | $\mathcal{O}(1)$. Test whether a list is empty. -- -- >>> null [] ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -825,11 +825,12 @@ output_flags = std_flags where -- XXX bits copied from System.FilePath, since that's not available here - combine a b - | null b = a - | null a = b - | pathSeparator [last a] = a ++ b - | otherwise = a ++ [pathSeparatorChar] ++ b + combine a [] = a + combine a b = case unsnoc a of + Nothing -> b + Just (_, lastA) + | pathSeparator [lastA] -> a ++ b + | otherwise -> a ++ [pathSeparatorChar] ++ b tempCounter :: IORef Int tempCounter = unsafePerformIO $ newIORef 0 ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs ===================================== @@ -54,6 +54,7 @@ import GHC.Internal.Base hiding (NonEmpty(..),Type, Module, sequence) import GHC.Internal.Data.Data hiding (Fixity(..)) import GHC.Internal.Data.NonEmpty (NonEmpty(..)) import GHC.Internal.Data.Traversable +import GHC.Internal.List (unsnoc) import GHC.Internal.Word import GHC.Internal.Generics (Generic) import GHC.Internal.IORef @@ -73,7 +74,7 @@ import GHC.Internal.Control.Monad.Fix import GHC.Internal.Control.Exception import GHC.Internal.Num import GHC.Internal.IO.Unsafe -import GHC.Internal.List (dropWhile, break, replicate, reverse, last) +import GHC.Internal.List (dropWhile, break, replicate, reverse) import GHC.Internal.MVar import GHC.Internal.IO.Exception import GHC.Internal.Unicode @@ -82,6 +83,16 @@ import qualified GHC.Internal.Types as Kind (Type) import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions +#ifdef BOOTSTRAP_TH +#if MIN_VERSION_base(4,19,0) +import Data.List (unsnoc) +#else +import Data.Maybe (maybe) +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +#endif +#endif + ----------------------------------------------------- -- -- The Quasi class @@ -1296,7 +1307,7 @@ mkName str -- (i.e. non-empty, starts with capital, all alpha) is_rev_mod_name rev_mod_str | (compt, rest) <- break (== '.') rev_mod_str - , not (null compt), isUpper (last compt), all is_mod_char compt + , Just (_, lastCompt) <- unsnoc compt, isUpper lastCompt, all is_mod_char compt = case rest of [] -> True (_dot : rest') -> is_rev_mod_name rest' ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Posix import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs ===================================== @@ -104,7 +104,7 @@ module System.FilePath.Windows import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper) import Data.Maybe(isJust) -import Data.List(stripPrefix, isSuffixOf) +import Data.List(stripPrefix, isSuffixOf, uncons, unsnoc) import System.Environment(getEnv) @@ -203,14 +203,20 @@ isExtSeparator = (== extSeparator) splitSearchPath :: String -> [FilePath] splitSearchPath = f where - f xs = case break isSearchPathSeparator xs of - (pre, [] ) -> g pre - (pre, _:post) -> g pre ++ f post - - g "" = ["." | isPosix] - g ('\"':x@(_:_)) | isWindows && last x == '\"' = [init x] - g x = [x] - + f xs = let (pre, post) = break isSearchPathSeparator xs + in case uncons post of + Nothing -> g pre + Just (_, t) -> g pre ++ f t + + g x = case uncons x of + Nothing -> ["." | isPosix] + Just (h, t) + | h == '"' + , Just{} <- uncons t -- >= 2 + , isWindows + , Just (i, l) <- unsnoc t + , l == '"' -> [i] + | otherwise -> [x] -- | Get a list of 'FilePath's in the $PATH variable. getSearchPath :: IO [FilePath] @@ -233,12 +239,17 @@ getSearchPath = fmap splitSearchPath (getEnv "PATH") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) -splitExtension x = case nameDot of - "" -> (x,"") - _ -> (dir ++ init nameDot, extSeparator : ext) - where - (dir,file) = splitFileName_ x - (nameDot,ext) = breakEnd isExtSeparator file +splitExtension x = case unsnoc nameDot of + -- Imagine x = "no-dots", then nameDot = "" + Nothing -> (x, mempty) + Just (initNameDot, _) + -- Imagine x = "\\shared.with.dots\no-dots" + | isWindows && null (dropDrive nameDot) -> (x, mempty) + -- Imagine x = "dir.with.dots/no-dots" + | any isPathSeparator ext -> (x, mempty) + | otherwise -> (initNameDot, extSeparator : ext) + where + (nameDot, ext) = breakEnd isExtSeparator x -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- @@ -594,9 +605,13 @@ replaceBaseName pth nam = combineAlways a (nam <.> ext) -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool -hasTrailingPathSeparator "" = False -hasTrailingPathSeparator x = isPathSeparator (last x) +hasTrailingPathSeparator = isJust . getTrailingPathSeparator +getTrailingPathSeparator :: FilePath -> Maybe Char +getTrailingPathSeparator x = case unsnoc x of + Just (_, lastX) + | isPathSeparator lastX -> Just lastX + _ -> Nothing hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False @@ -619,12 +634,12 @@ addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pat -- > Windows: dropTrailingPathSeparator "\\" == "\\" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x dropTrailingPathSeparator :: FilePath -> FilePath -dropTrailingPathSeparator x = - if hasTrailingPathSeparator x && not (isDrive x) - then let x' = dropWhileEnd isPathSeparator x - in if null x' then [last x] else x' - else x - +dropTrailingPathSeparator x = case getTrailingPathSeparator x of + Just lastX + | not (isDrive x) + -> let x' = dropWhileEnd isPathSeparator x + in if null x' then [lastX] else x' + _ -> x -- | Get the directory name, move up one level. -- @@ -863,28 +878,37 @@ makeRelative root path -- > Posix: normalise "bob/fred/." == "bob/fred/" -- > Posix: normalise "//home" == "/home" normalise :: FilePath -> FilePath -normalise path = result ++ [pathSeparator | addPathSeparator] - where - (drv,pth) = splitDrive path - result = joinDrive' (normaliseDrive drv) (f pth) +normalise filepath = + result <> + (if addPathSeparator + then [pathSeparator] + else mempty) + where + (drv,pth) = splitDrive filepath + + result = joinDrive' (normaliseDrive drv) (f pth) - joinDrive' "" "" = "." - joinDrive' d p = joinDrive d p + joinDrive' d p + = if null d && null p + then "." + else joinDrive d p - addPathSeparator = isDirPath pth - && not (hasTrailingPathSeparator result) - && not (isRelativeDrive drv) + addPathSeparator = isDirPath pth + && not (hasTrailingPathSeparator result) + && not (isRelativeDrive drv) - isDirPath xs = hasTrailingPathSeparator xs - || not (null xs) && last xs == '.' && hasTrailingPathSeparator (init xs) + isDirPath xs = hasTrailingPathSeparator xs || case unsnoc xs of + Nothing -> False + Just (initXs, lastXs) -> lastXs == '.' && hasTrailingPathSeparator initXs - f = joinPath . dropDots . propSep . splitDirectories + f = joinPath . dropDots . propSep . splitDirectories - propSep (x:xs) | all isPathSeparator x = [pathSeparator] : xs - | otherwise = x : xs - propSep [] = [] + propSep (x:xs) + | all isPathSeparator x = [pathSeparator] : xs + | otherwise = x : xs + propSep [] = [] - dropDots = filter ("." /=) + dropDots = filter ("." /=) normaliseDrive :: FilePath -> FilePath normaliseDrive "" = "" ===================================== testsuite/tests/driver/j-space/jspace.hs ===================================== @@ -7,7 +7,7 @@ import System.Environment import GHC.Driver.Env.Types import GHC.Profiling import System.Mem -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, unsnoc) import Control.Monad import System.Exit import GHC.Platform @@ -41,7 +41,9 @@ initGhcM xs = do requestHeapCensus performGC [ys] <- filter (isPrefixOf (ghcUnitId <> ":GHC.Unit.Module.ModDetails.ModDetails")) . lines <$> readFile "jspace.hp" - let (n :: Int) = read (last (words ys)) + let (n :: Int) = case unsnoc (words ys) of + Nothing -> error "input is unexpectedly empty" + Just (_, lst) -> read lst -- The output should be 50 * 8 * word_size (i.e. 3600, or 1600 on 32-bit architectures): -- the test contains DEPTH + WIDTH + 2 = 50 modules J, H_0, .., H_DEPTH, W_1, .., W_WIDTH, -- and each ModDetails contains 1 (info table) + 8 word-sized fields. ===================================== testsuite/tests/rts/KeepCafsBase.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-x-partial #-} + module KeepCafsBase (x) where x :: Int ===================================== utils/check-exact/Utils.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Base (NonEmpty(..)) import GHC.Parser.Lexer (allocateComments) import Data.Data hiding ( Fixity ) -import Data.List (sortBy, partition) +import Data.List (sortBy, partition, unsnoc) import qualified Data.Map.Strict as Map import Debug.Trace @@ -734,8 +734,9 @@ ghead info [] = error $ "ghead "++info++" []" ghead _info (h:_) = h glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h +glast info xs = case unsnoc xs of + Nothing -> error $ "glast " ++ info ++ " []" + Just (_, lst) -> lst gtail :: String -> [a] -> [a] gtail info [] = error $ "gtail " ++ info ++ " []" ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs ===================================== @@ -755,7 +755,7 @@ ppHtmlIndex divAlphabet << unordList ( map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars, any ((== c) . toUpper . head . fst) index + [ [c] | c <- initialChars, any (maybe False ((== c) . toUpper . fst) . List.uncons . fst) index ] ++ [merged_name] ) @@ -772,7 +772,7 @@ ppHtmlIndex writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part - index_part = [(n, stuff) | (n, stuff) <- this_ix, toUpper (head n) == c] + index_part = [(n, stuff) | (n@(headN : _), stuff) <- this_ix, toUpper headN == c] index :: [(String, Map GHC.Name [(Module, Bool)])] index = sortBy cmp (Map.toAscList full_index) ===================================== utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs ===================================== @@ -30,7 +30,7 @@ import Control.Arrow (first) import Control.Monad import Data.Char (chr, isAlpha, isSpace, isUpper) import Data.Functor (($>)) -import Data.List (elemIndex, intercalate, intersperse, unfoldr) +import Data.List (elemIndex, intercalate, intersperse, unfoldr, unsnoc) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set @@ -870,10 +870,10 @@ codeblock = DocCodeBlock . parseParagraph . dropSpaces <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") where - dropSpaces xs = - case splitByNl xs of - [] -> xs - ys -> case T.uncons (last ys) of + dropSpaces xs = let ys = splitByNl xs in + case unsnoc ys of + Nothing -> xs + Just (_, lastYs) -> case T.uncons lastYs of Just (' ', _) -> case mapM dropSpace ys of Nothing -> xs Just zs -> T.intercalate "\n" zs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f16552d7617e1f41b5da85b8d2ed2a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] (Applicative docs typo: missing "one")
by Marge Bot (＠marge-bot) 11 Jul '25

11 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 2b4db9ba by Pi Delport at 2025-07-11T16:40:52-04:00 (Applicative docs typo: missing "one") - - - - - 1 changed file: - libraries/ghc-internal/src/GHC/Internal/Base.hs Changes: ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1047,7 +1047,7 @@ class Functor f where -- * sequence computations and combine their results ('<*>' and 'liftA2'). -- -- A minimal complete definition must include implementations of 'pure' --- and of either '<*>' or 'liftA2'. If it defines both, then they must behave +-- and one of either '<*>' or 'liftA2'. If it defines both, then they must behave -- the same as their default definitions: -- -- @('<*>') = 'liftA2' 'id'@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b4db9bacf4a54552179154d067efc5… You're receiving this email because of your account on gitlab.haskell.org.

1 0