Hannes Siebenhandl pushed to branch wip/fendor/ghc-ghci-mhu-27640 at Glasgow Haskell Compiler / GHC Commits: b5d29ab8 by Brandon Chinn at 2026-08-25T18:42:08-04:00 Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - e60eb3bc by Andreas Klebinger at 2026-08-25T18:42:59-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 987ac4fc by fendor at 2026-08-26T17:06:05+02:00 GHCi: Fix order of `PackageDBFlag`s for interactive home unit `PackageDBFlag`s are stored in reverse order of cli specification. When sorting the `PackageDBFlag`s by longest common prefix, we need thus to reverse the package db stacks before calculating the prefix. We make sure to reverse the package db stack for the interactive home unit to uphold that later specified package dbs overwrite earlier ones. Resolved and adds regression test for #27640 - - - - - 21 changed files: - changelog.d/T27202 - ghc/GHCi/UI.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs - rts/linker/elf_reloc_riscv64.c - + testsuite/tests/ghci/prog-mhu007/Makefile - + testsuite/tests/ghci/prog-mhu007/a/A.hs - + testsuite/tests/ghci/prog-mhu007/all.T - + testsuite/tests/ghci/prog-mhu007/b/B.hs - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.script - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg - + testsuite/tests/ghci/prog-mhu007/unitA - + testsuite/tests/ghci/prog-mhu007/unitB - 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 Changes: ===================================== changelog.d/T27202 ===================================== @@ -1,7 +1,7 @@ section: ghci synopsis: Fix regression to honour module targets in nested directories into GHCi after startup. -issues: #27202 -mrs: !15980 +issues: #27202 #27640 +mrs: !15980 !16591 description: { Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup. ===================================== ghc/GHCi/UI.hs ===================================== @@ -763,7 +763,7 @@ installInteractiveHomeUnits dflags = do -- However, in the case of multiple home units, initialised via @ghci -unit ... -unit ...@, there -- are not @-package-db@ arguments in the base 'DynFlags'... -- To fix this, we look at the home units and merge their package dbs stacks. - -- We assume, that many package db stacks look almost identical, and only differ in view elements. + -- We assume, that many package db stacks look almost identical, and only differ in few unit databases. -- Thus, we try to extract a common package db stack (i.e., longest common prefix), and then concat -- the rest of the package db stacks. At last, we add the two result package db stacks. -- This should work reliably with cabal and stack, but it is hacky. @@ -864,8 +864,14 @@ installInteractiveHomeUnits dflags = do pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] - concatPackageDbStacksUsingLongestCommonPrefix stacks = + concatPackageDbStacksUsingLongestCommonPrefix stacks' = let + -- Package DB stacks are accumulated from the cli right to left. + -- E.g., @-clear-package-db -global-package-db@ is stored as + -- @[PackageDB GlobalPkgDb, ClearPackageDBs]@. + -- Hence, we reverse the stacks, before computing the longest common prefix, + -- otherwise the prefix won't match at all. + stacks = map List.reverse stacks' -- O (m * n) -- m ... Number of PackageDBFlag stacks -- n ... Size of the stacks @@ -873,8 +879,21 @@ installInteractiveHomeUnits dflags = do map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose prefix = longestCommonPrefix stacks + + -- We reverse each individual stack segment to maintain the relative order within in a package + -- db stack. + -- There should be no 'ClearPackageDBs' in here, otherwise we are going to overwrite + -- the longest common prefix stacks. + -- + -- @nubOrd@ can silently change precedence of package db stack merging. + -- This is not trivially avoidable right now, since multiple home units could simply + -- have package db stacks that cannot be unified. + unmergeableStack = + nubOrd (concatMap (List.reverse . List.drop (length prefix)) stacks) in - prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks) + -- We reverse the final common package db stack again to match the expectation of 'packageDBFlags' that they are + -- stord in reverse order. + unmergeableStack ++ reverse prefix reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do ===================================== libraries/base/base.cabal.in ===================================== @@ -117,6 +117,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378)) * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413)) * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import Data.Bool (Bool (..), (&&)) +import GHC.Internal.Data.Ord ((<), (>)) +import GHC.Internal.Float (RealFloat (..)) +import GHC.Internal.Real ((/)) +#if __GLASGOW_HASKELL__ >= 1001 +import qualified GHC.Essentials as Rebindable +#endif + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +-- | A pattern synonym for NaN values. +-- +-- Note: Per IEEE 754, NaN is never equal to itself, thus these two snippets +-- have different behavior: +-- +-- @ +-- -- foo1 NaN == "a" +-- foo1 NaN = "a" +-- foo1 _ = "b" +-- +-- -- foo2 NaN == "b" +-- foo2 x = if x == NaN then "a" else "b" +-- @ +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== testsuite/tests/ghci/prog-mhu007/Makefile ===================================== @@ -0,0 +1,33 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +PKGCONF_FOO=local-foo.package.conf +PKGCONF_BAR=local-bar.package.conf +LOCAL_GHC_PKG_FOO = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_FOO) +LOCAL_GHC_PKG_BAR = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_BAR) + +# Finds both packages in different unit databases +.PHONY: prog-mhu007 +prog-mhu007: + cd testpkg-foo && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-foo-0.1.0.0 -this-unit-id testpkg-foo-0.1.0.0-XXX \ + -i. Foo + cd testpkg-bar && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-bar-0.1.0.0 -this-unit-id testpkg-bar-0.1.0.0-XXX \ + -i. Bar + + $(LOCAL_GHC_PKG_FOO) init $(PKGCONF_FOO) 2>/dev/null + $(LOCAL_GHC_PKG_FOO) register --force testpkg-foo/testpkg-foo.pkg 2>/dev/null + $(LOCAL_GHC_PKG_FOO) hide testpkg-foo + $(LOCAL_GHC_PKG_FOO) list + + $(LOCAL_GHC_PKG_BAR) init $(PKGCONF_BAR) 2>/dev/null + $(LOCAL_GHC_PKG_BAR) register --force testpkg-bar/testpkg-bar.pkg 2>/dev/null + $(LOCAL_GHC_PKG_BAR) hide testpkg-bar + $(LOCAL_GHC_PKG_BAR) list + + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code -unit @unitA -unit @unitB < prog-mhu007.script ===================================== testsuite/tests/ghci/prog-mhu007/a/A.hs ===================================== @@ -0,0 +1,3 @@ +module A where + +import Bar ===================================== testsuite/tests/ghci/prog-mhu007/all.T ===================================== @@ -0,0 +1,8 @@ + +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB', 'testpkg-bar/', 'testpkg-foo/']) + +test('prog-mhu007', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog-mhu007']) ===================================== testsuite/tests/ghci/prog-mhu007/b/B.hs ===================================== @@ -0,0 +1,3 @@ +module B where + +import Foo ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.script ===================================== @@ -0,0 +1,5 @@ +:m + A B +"Loaded A and B" +import Foo +import Bar +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout ===================================== @@ -0,0 +1,10 @@ +Reading package info from "testpkg-foo/testpkg-foo.pkg" ... done. +local-foo.package.conf + (testpkg-foo-0.1.0.0) + +Reading package info from "testpkg-bar/testpkg-bar.pkg" ... done. +local-bar.package.conf + (testpkg-bar-0.1.0.0) + +"Loaded A and B" +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-bar +version: 0.1.0.0 +id: testpkg-bar-0.1.0.0-XXX +key: testpkg-bar-0.1.0.0-XXX +exposed: True +exposed-modules: Bar +hidden-modules: +import-dirs: ${pkgroot}/testpkg-bar/dist-testpkg-bar-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs ===================================== @@ -0,0 +1 @@ +module Foo where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-foo +version: 0.1.0.0 +id: testpkg-foo-0.1.0.0-XXX +key: testpkg-foo-0.1.0.0-XXX +exposed: True +exposed-modules: Foo +hidden-modules: +import-dirs: ${pkgroot}/testpkg-foo/dist-testpkg-foo-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/unitA ===================================== @@ -0,0 +1,11 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local-bar.package.conf +-package base +-package-id testpkg-bar-0.1.0.0-XXX ===================================== testsuite/tests/ghci/prog-mhu007/unitB ===================================== @@ -0,0 +1,11 @@ +-i +-ib/ +B +-this-unit-id b-0.0.0 +-this-package-name b +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local-foo.package.conf +-package base +-package-id testpkg-foo-0.1.0.0-XXX ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b304c203d3f30dc9c8c9fa381a12685... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b304c203d3f30dc9c8c9fa381a12685... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help