[Git][ghc/ghc][wip/T26865] ghc-internal: Move GHC.Internal.Data.Bool to base
by Teo Camarasu (＠teo) 02 Feb '26
by Teo Camarasu (＠teo) 02 Feb '26
02 Feb '26
Teo Camarasu pushed to branch wip/T26865 at Glasgow Haskell Compiler / GHC
Commits:
4d75c77b by Teo Camarasu at 2026-02-02T12:40:15+00:00
ghc-internal: Move GHC.Internal.Data.Bool to base
This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression.
Resolves 26865
- - - - -
19 changed files:
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TypeError.hs
- 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
Changes:
=====================================
libraries/base/src/Data/Bool.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
-- |
--
@@ -24,4 +24,39 @@ module Data.Bool
bool
) where
-import GHC.Internal.Data.Bool
\ No newline at end of file
+import GHC.Internal.Base
+
+-- $setup
+-- >>> import Prelude
+
+-- | Case analysis for the 'Bool' type. @'bool' f t p@ evaluates to @f@
+-- when @p@ is 'False', and evaluates to @t@ when @p@ is 'True'.
+--
+-- This is equivalent to @if p then t else f@; that is, one can
+-- think of it as an if-then-else construct with its arguments
+-- reordered.
+--
+-- @since base-4.7.0.0
+--
+-- ==== __Examples__
+--
+-- Basic usage:
+--
+-- >>> bool "foo" "bar" True
+-- "bar"
+-- >>> bool "foo" "bar" False
+-- "foo"
+--
+-- Confirm that @'bool' f t p@ and @if p then t else f@ are
+-- equivalent:
+--
+-- >>> let p = True; f = "bar"; t = "foo"
+-- >>> bool f t p == if p then t else f
+-- True
+-- >>> let p = False
+-- >>> bool f t p == if p then t else f
+-- True
+--
+bool :: a -> a -> Bool -> a
+bool f _ False = f
+bool _ t True = t
=====================================
libraries/base/src/Data/List.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
-- |
--
@@ -184,7 +184,7 @@ module Data.List
genericReplicate
) where
-import GHC.Internal.Data.Bool (otherwise)
+import GHC.Internal.Base (otherwise)
import GHC.Internal.Data.Function (const)
import GHC.Internal.Data.List
import GHC.Internal.Data.List.NonEmpty (NonEmpty(..))
=====================================
libraries/base/src/Data/List/NubOrdSet.hs
=====================================
@@ -11,7 +11,7 @@ module Data.List.NubOrdSet (
insert,
) where
-import GHC.Internal.Data.Bool (Bool(..))
+import GHC.Internal.Base (Bool(..))
import GHC.Internal.Data.Function ((.))
import GHC.Internal.Data.Ord (Ordering(..))
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -140,7 +140,6 @@ Library
GHC.Internal.Control.Monad.ST.Imp
GHC.Internal.Control.Monad.ST.Lazy.Imp
GHC.Internal.Data.Bits
- GHC.Internal.Data.Bool
GHC.Internal.Data.Coerce
GHC.Internal.Data.Data
GHC.Internal.Data.Dynamic
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs deleted
=====================================
@@ -1,64 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Internal.Data.Bool
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries(a)haskell.org
--- Stability : stable
--- Portability : portable
---
--- The 'Bool' type and related functions.
---
------------------------------------------------------------------------------
-
-module GHC.Internal.Data.Bool (
- -- * Booleans
- Bool(..),
- -- ** Operations
- (&&),
- (||),
- not,
- otherwise,
- bool,
- ) where
-
-import GHC.Internal.Base
-
--- $setup
--- >>> import Prelude
-
--- | Case analysis for the 'Bool' type. @'bool' f t p@ evaluates to @f@
--- when @p@ is 'False', and evaluates to @t@ when @p@ is 'True'.
---
--- This is equivalent to @if p then t else f@; that is, one can
--- think of it as an if-then-else construct with its arguments
--- reordered.
---
--- @since base-4.7.0.0
---
--- ==== __Examples__
---
--- Basic usage:
---
--- >>> bool "foo" "bar" True
--- "bar"
--- >>> bool "foo" "bar" False
--- "foo"
---
--- Confirm that @'bool' f t p@ and @if p then t else f@ are
--- equivalent:
---
--- >>> let p = True; f = "bar"; t = "foo"
--- >>> bool f t p == if p then t else f
--- True
--- >>> let p = False
--- >>> bool f t p == if p then t else f
--- True
---
-bool :: a -> a -> Bool -> a
-bool f _ False = f
-bool _ t True = t
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
=====================================
@@ -50,7 +50,6 @@ module GHC.Internal.Data.Foldable (
find
) where
-import GHC.Internal.Data.Bool
import GHC.Internal.Data.Either
import GHC.Internal.Data.Eq
import GHC.Internal.Data.Functor.Utils (Max(..), Min(..), (#.))
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
=====================================
@@ -30,8 +30,7 @@ module GHC.Internal.Data.Function
, applyWhen
) where
-import GHC.Internal.Base ( TYPE, ($), (.), id, const, flip )
-import GHC.Internal.Data.Bool ( Bool(..) )
+import GHC.Internal.Base ( TYPE, Bool(..), ($), (.), id, const, flip )
infixl 0 `on`
infixl 1 &
@@ -171,7 +170,7 @@ x & f = f x
-- | 'applyWhen' applies a function to a value if a condition is true,
-- otherwise, it returns the value unchanged.
--
--- It is equivalent to @'flip' ('GHC.Internal.Data.Bool.bool' 'id')@.
+-- It is equivalent to @'flip' ('Data.Bool.bool' 'id')@.
--
-- ==== __Examples__
--
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
@@ -23,7 +23,7 @@ module GHC.Internal.Data.Type.Bool (
If, type (&&), type (||), Not
) where
-import GHC.Internal.Data.Bool
+import GHC.Internal.Base
-- This needs to be in base because (&&) is used in Data.Type.Equality.
-- The other functions do not need to be in base, but seemed to be appropriate
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
=====================================
@@ -34,14 +34,11 @@ module GHC.Internal.Data.Type.Ord (
, OrdCond
) where
-import GHC.Internal.Show(Show(..))
+import GHC.Internal.Base
+import GHC.Internal.Show (Show(..))
import GHC.Internal.TypeError
import GHC.Internal.TypeLits.Internal
import GHC.Internal.TypeNats.Internal
-import GHC.Internal.Types (type (~), Char)
-import GHC.Internal.Data.Bool
-import GHC.Internal.Data.Eq
-import GHC.Internal.Data.Ord
-- | 'Compare' branches on the kind of its arguments to either compare by
-- 'Symbol' or 'Nat'.
=====================================
libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
=====================================
@@ -37,13 +37,12 @@ module GHC.Internal.Data.Version (
) where
import GHC.Internal.Data.Functor ( Functor(..) )
-import GHC.Internal.Data.Bool ( (&&) )
import GHC.Internal.Data.Eq
import GHC.Internal.Int ( Int )
import GHC.Internal.Data.List ( map, sort, concat, concatMap, intersperse, (++) )
import GHC.Internal.Data.Ord
import GHC.Internal.Data.String ( String )
-import GHC.Internal.Base ( Applicative(..) )
+import GHC.Internal.Base ( Applicative(..), (&&) )
import GHC.Internal.Generics
import GHC.Internal.Unicode ( isDigit, isAlphaNum )
import GHC.Internal.Read
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
=====================================
@@ -49,7 +49,6 @@ import GHC.Internal.Conc.IO
import GHC.Internal.IO.Exception
#if defined(mingw32_HOST_OS)
import GHC.Internal.Windows
-import GHC.Internal.Data.Bool
import GHC.Internal.IO.SubSystem ((<!>))
import GHC.Internal.Foreign.Storable
#endif
@@ -717,7 +716,7 @@ asyncReadRawBufferPtr loc !fd !buf !off !len = do
if l == (-1)
then let sock_errno = c_maperrno_func (fromIntegral rc)
non_sock_errno = Errno (fromIntegral rc)
- errno = bool non_sock_errno sock_errno (fdIsSocket fd)
+ errno = if fdIsSocket fd then sock_errno else non_sock_errno
in ioError (errnoToIOError loc errno Nothing Nothing)
else return (fromIntegral l)
@@ -728,7 +727,7 @@ asyncWriteRawBufferPtr loc !fd !buf !off !len = do
if l == (-1)
then let sock_errno = c_maperrno_func (fromIntegral rc)
non_sock_errno = Errno (fromIntegral rc)
- errno = bool non_sock_errno sock_errno (fdIsSocket fd)
+ errno = if fdIsSocket fd then sock_errno else non_sock_errno
in ioError (errnoToIOError loc errno Nothing Nothing)
else return (fromIntegral l)
@@ -740,7 +739,7 @@ blockingReadRawBufferPtr loc !fd !buf !off !len
let start_ptr = buf `plusPtr` off
recv_ret = c_safe_recv (fdFD fd) start_ptr (fromIntegral len) 0
read_ret = c_safe_read (fdFD fd) start_ptr (fromIntegral len)
- r <- bool read_ret recv_ret (fdIsSocket fd)
+ r <- if fdIsSocket fd then recv_ret else read_ret
when ((fdIsSocket fd) && (r == -1)) c_maperrno
return r
-- We trust read() to give us the correct errno but recv(), as a
@@ -753,7 +752,7 @@ blockingWriteRawBufferPtr loc !fd !buf !off !len
let start_ptr = buf `plusPtr` off
send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0
write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)
- r <- bool write_ret send_ret (fdIsSocket fd)
+ r <- if fdIsSocket fd then send_ret else write_ret
when (r == -1) c_maperrno
return r
-- We don't trust write() to give us the correct errno, and
=====================================
libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
=====================================
@@ -46,7 +46,6 @@ import qualified GHC.Internal.Exception as Ex
import qualified GHC.Internal.Exts as Exts
import qualified GHC.Internal.CString as GHC
import GHC.Internal.IO
-import GHC.Internal.Data.Bool
import GHC.Internal.Base
import GHC.Internal.Show
=====================================
libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
=====================================
@@ -29,7 +29,7 @@ import GHC.Internal.Control.Exception (mask)
import GHC.Internal.Data.Function (const, (.), ($))
import GHC.Internal.Data.Functor (fmap)
#if defined(mingw32_HOST_OS)
-import GHC.Internal.Data.Bool (otherwise)
+import GHC.Internal.Base (otherwise)
#endif
import GHC.Internal.Data.Maybe (Maybe (Nothing), maybe)
#if defined(mingw32_HOST_OS)
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -34,7 +34,6 @@ import GHC.Internal.TH.Monad
import qualified GHC.Internal.TH.Lib as Lib (litE) -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
import GHC.Internal.Data.Either
-import GHC.Internal.Data.Bool
import GHC.Internal.Base hiding (NonEmpty(..), Type, Module, inline)
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Integer
=====================================
libraries/ghc-internal/src/GHC/Internal/TypeError.hs
=====================================
@@ -31,8 +31,7 @@ module GHC.Internal.TypeError
, Unsatisfiable, unsatisfiable
) where
-import GHC.Internal.Data.Bool
-import GHC.Internal.Types (TYPE, Constraint, Symbol)
+import GHC.Internal.Types (TYPE, Bool(True), Constraint, Symbol)
{- Note [Custom type errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -746,7 +746,7 @@ module Data.Bits where
toIntegralSized :: forall a b. (GHC.Internal.Real.Integral a, GHC.Internal.Real.Integral b, Bits a, Bits b) => a -> GHC.Internal.Maybe.Maybe b
module Data.Bool where
- -- Safety: Safe
+ -- Safety: Trustworthy
(&&) :: Bool -> Bool -> Bool
type Bool :: *
data Bool = False | True
@@ -1308,7 +1308,7 @@ module Data.Kind where
type Type = TYPE GHC.Internal.Types.LiftedRep
module Data.List where
- -- Safety: Safe
+ -- Safety: Trustworthy
(!!) :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> GHC.Internal.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Internal.Types.Int -> GHC.Internal.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -746,7 +746,7 @@ module Data.Bits where
toIntegralSized :: forall a b. (GHC.Internal.Real.Integral a, GHC.Internal.Real.Integral b, Bits a, Bits b) => a -> GHC.Internal.Maybe.Maybe b
module Data.Bool where
- -- Safety: Safe
+ -- Safety: Trustworthy
(&&) :: Bool -> Bool -> Bool
type Bool :: *
data Bool = False | True
@@ -1308,7 +1308,7 @@ module Data.Kind where
type Type = TYPE GHC.Internal.Types.LiftedRep
module Data.List where
- -- Safety: Safe
+ -- Safety: Trustworthy
(!!) :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> GHC.Internal.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Internal.Types.Int -> GHC.Internal.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -746,7 +746,7 @@ module Data.Bits where
toIntegralSized :: forall a b. (GHC.Internal.Real.Integral a, GHC.Internal.Real.Integral b, Bits a, Bits b) => a -> GHC.Internal.Maybe.Maybe b
module Data.Bool where
- -- Safety: Safe
+ -- Safety: Trustworthy
(&&) :: Bool -> Bool -> Bool
type Bool :: *
data Bool = False | True
@@ -1308,7 +1308,7 @@ module Data.Kind where
type Type = TYPE GHC.Internal.Types.LiftedRep
module Data.List where
- -- Safety: Safe
+ -- Safety: Trustworthy
(!!) :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> GHC.Internal.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Internal.Types.Int -> GHC.Internal.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -746,7 +746,7 @@ module Data.Bits where
toIntegralSized :: forall a b. (GHC.Internal.Real.Integral a, GHC.Internal.Real.Integral b, Bits a, Bits b) => a -> GHC.Internal.Maybe.Maybe b
module Data.Bool where
- -- Safety: Safe
+ -- Safety: Trustworthy
(&&) :: Bool -> Bool -> Bool
type Bool :: *
data Bool = False | True
@@ -1308,7 +1308,7 @@ module Data.Kind where
type Type = TYPE GHC.Internal.Types.LiftedRep
module Data.List where
- -- Safety: Safe
+ -- Safety: Trustworthy
(!!) :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> GHC.Internal.Types.Int -> a
(!?) :: forall a. [a] -> GHC.Internal.Types.Int -> GHC.Internal.Maybe.Maybe a
(++) :: forall a. [a] -> [a] -> [a]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d75c77bb51367d9c2ea05e5bed57fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d75c77bb51367d9c2ea05e5bed57fd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/ticked_joins] Allow join point Ids to occur below ticks & casts
by sheaf (＠sheaf) 02 Feb '26
by sheaf (＠sheaf) 02 Feb '26
02 Feb '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
63687228 by sheaf at 2026-02-02T11:22:19+01:00
Allow join point Ids to occur below ticks & casts
This commit classifies all join points into two categories:
- true join points
- quasi join points
A quasi join point is a join point for which a jump is enclosed within
a profiling tick or a cast.
The only operational difference is that, for quasi join points, we
cannot perform the case-of-case transformation described in
Note [Join points and case-of-case] in GHC.Core.Opt.Simplify.Iteration.
All of this is explained in detail in Note [Quasi join points].
Fixes #26693 and #26642
Improves on #14610, #26157 and #26422, as it means casts/profiling ticks
don't prevent join points, but it doesn't entirely fix these issues
because we are still inhibiting optimisations (lack of case-of-case).
- - - - -
31 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/profiling/should_run/T2552.prof.sample
- testsuite/tests/profiling/should_run/ioprof.prof.sample
- testsuite/tests/profiling/should_run/scc001.prof.sample
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/636872281a8faa2ec9e6b141ae29ddd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/636872281a8faa2ec9e6b141ae29ddd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/dcoutts/windows-dlls] 4 commits: Try using response files for hadrian linking with ghc.
by Duncan Coutts (＠dcoutts) 02 Feb '26
by Duncan Coutts (＠dcoutts) 02 Feb '26
02 Feb '26
Duncan Coutts pushed to branch wip/dcoutts/windows-dlls at Glasgow Haskell Compiler / GHC
Commits:
8f9918c5 by Duncan Coutts at 2026-02-02T10:05:41+00:00
Try using response files for hadrian linking with ghc.
On windows, the link command line for ghc-internal is well over 32kb.
We did not encounter this before for static libs, since we already use
ar's @file feature (if available, which it is for the llvm toolchain).
We encounter this now on windows for linking dll files (which uses ghc
calling (l)ld rather than ar).
- - - - -
0d53e47b by Duncan Coutts at 2026-02-02T10:05:42+00:00
Use __attribute__(dllimport)) for external RTS symbol declarations
This is needed to be hygenic about DLL symbol imports and exports.
The attribute is ignored on platforms other than Windows.
Use of the attribute however means that external data symbols do not
have a compile-time constant address (they are loaded using an
indirection). This means we have to adjust the rtsSyms initial linker
table so that it is a local constant in a function, rather than a global
constant. We now define it within a function that pre-populates the
symbol table with the RTS symbols.
- - - - -
c07584ba by Duncan Coutts at 2026-02-02T10:05:42+00:00
Experiment with listing RTS symbols
- - - - -
48f4736b by Duncan Coutts at 2026-02-02T10:14:56+00:00
Experimental mingw .refptr mechanism support
- - - - -
8 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/StgToCmm/Lit.hs
- hadrian/src/Builder.hs
- rts/Linker.c
- rts/RtsSymbols.c
- rts/RtsSymbols.h
- + utils/rts-syms/rts-syms.c
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -117,6 +117,7 @@ module GHC.Cmm.CLabel (
hasIdLabelInfo,
isBytesLabel,
isForeignLabel,
+ isForeignLabelUnknownPackage,
isSomeRODataLabel,
isStaticClosureLabel,
@@ -448,8 +449,33 @@ data ForeignLabelSource
-- contain compiled Haskell code, and is not associated with any .hi files.
-- We don't have to worry about Haskell code being inlined from
-- external packages. It is safe to treat the RTS package as "external".
+ --
+ -- On Windows in particular, we assume the label is definately in an
+ -- external DLL and expect to link it against a __imp_* symbol. Thus it
+ -- will /not/ link correctly if the symbol is actually in the same DLL.
| ForeignLabelInExternalPackage
+ -- | The label is somewhere, but we do not know if it is in this package or
+ -- an external package. This is the case we end up with for Haskell FFI
+ -- declarations like @foreign import ccall@. There is not enough
+ -- information to tell us if the label is from the same package (e.g. in
+ -- a local @cbits/blah.c@ file) or is from an external foreign library.
+ --
+ -- On ELF, this is not a problem and the symbol can be resolved without
+ -- knowing if its local or external.
+ --
+ -- On Windows/PE, this is a bit of a problem. On Windows one normally
+ -- needs to know if it's local or external since the symbol names and
+ -- ABI differ. However, GCC & LLVM have extensions to help porting Unix
+ -- software (that is used to not making these distinctions). There are a
+ -- number of useful mechanisms including \"auto import\" (to import
+ -- symbols found in DLLs automatically), a @.refptr@ mechanism to load
+ -- data via an indirection (which the linker can relocate) and
+ -- \"pseudo relocations\" which is a runtime feature to do additional
+ -- relocations beyond what the Win32 native linker does.
+ -- See Note [Mingw .refptr mechanism]
+ | ForeignLabelInUnknownPackage
+
-- | Label is in the package currently being compiled.
-- This is only used for creating hacky tmp labels during code generation.
-- Don't use it in any code that might be inlined across a package boundary
@@ -600,6 +626,8 @@ data CmmLabelInfo
data DynamicLinkerLabelInfo
= CodeStub -- MachO: Lfoo$stub, ELF: foo@plt
| SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+ | DataRefPtr -- Windows: .refptr.foo
+ -- see Note [Mingw .refptr mechanism]
| GotSymbolPtr -- ELF: foo@got
| GotSymbolOffset -- ELF: foo@gotoff
@@ -778,6 +806,10 @@ isForeignLabel :: CLabel -> Bool
isForeignLabel (ForeignLabel _ _ _) = True
isForeignLabel _lbl = False
+isForeignLabelUnknownPackage :: CLabel -> Bool
+isForeignLabelUnknownPackage (ForeignLabel _ ForeignLabelInUnknownPackage _) = True
+isForeignLabelUnknownPackage _lbl = False
+
-- | Whether label is a static closure label (can come from haskell or cmm)
isStaticClosureLabel :: CLabel -> Bool
-- Closure defined in haskell (.hs)
@@ -1308,9 +1340,9 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
LocalBlockLabel _ -> False
- ForeignLabel _ source _ ->
- if os == OSMinGW32
- then case source of
+ ForeignLabel _ source _
+ | os == OSMinGW32 ->
+ case source of
-- Foreign label is in some un-named foreign package (or DLL).
ForeignLabelInExternalPackage -> True
@@ -1318,16 +1350,23 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
-- source file currently being compiled.
ForeignLabelInThisPackage -> False
+ -- Foreign label is either in the same package or is in some
+ -- foreign package/DLL/DSO. Neither yes nor no is the correct
+ -- answer here, because on Windows these are a distinct case
+ -- that need special treatment in the code generator.
+ -- See Note [Mingw .refptr mechanism]
+ ForeignLabelInUnknownPackage -> True
+
-- Foreign label is in some named package.
-- When compiling in the "dyn" way, each package is to be
-- linked into its own DLL.
ForeignLabelInPackage pkgId ->
external_dynamic_refs && (this_unit /= pkgId)
- else -- On Mac OS X and on ELF platforms, false positives are OK,
- -- so we claim that all foreign imports come from dynamic
- -- libraries
- True
+ -- On Mac OS X and on ELF platforms, false positives are OK,
+ -- so we claim that all foreign imports come from dynamic
+ -- libraries
+ | otherwise -> True
CC_Label cc ->
external_dynamic_refs && not (ccFromThisModule cc this_mod)
@@ -1678,6 +1717,7 @@ instance Outputable ForeignLabelSource where
ForeignLabelInPackage pkgId -> parens $ text "package: " <> ppr pkgId
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
+ ForeignLabelInUnknownPackage -> parens $ text "unknown package"
-- -----------------------------------------------------------------------------
-- Machine-dependent knowledge about labels.
@@ -1698,6 +1738,7 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
GotSymbolPtr -> ppLbl <> text "@GOTPCREL"
GotSymbolOffset -> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
| platformArch platform == ArchAArch64 -> ppLbl
| otherwise -> panic "pprDynamicLinkerAsmLabel"
@@ -1710,8 +1751,9 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
OSMinGW32 ->
case dllInfo of
- SymbolPtr -> text "__imp_" <> ppLbl
- _ -> panic "pprDynamicLinkerAsmLabel"
+ SymbolPtr -> text "__imp_" <> ppLbl
+ DataRefPtr -> text ".refptr." <> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
_ -> panic "pprDynamicLinkerAsmLabel"
where
@@ -1738,6 +1780,7 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
GotSymbolPtr -> ppLbl <> text "@gotpcrel"
GotSymbolOffset -> ppLbl
SymbolPtr -> text ".LC_" <> ppLbl
+ _ -> panic "pprDynamicLinkerAsmLabel"
| platformArch platform == ArchPPC_64 ELF_V1
|| platformArch platform == ArchPPC_64 ELF_V2
@@ -1753,6 +1796,7 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
SymbolPtr -> text ".LC_" <> ppLbl
GotSymbolPtr -> ppLbl <> text "@got"
GotSymbolOffset -> ppLbl <> text "@gotoff"
+ _ -> panic "pprDynamicLinkerAsmLabel"
-- Figure out whether `symbol` may serve as an alias
-- to `target` within one compilation unit.
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -152,6 +152,12 @@ cmmMakeDynamicReference config referenceKind lbl
AccessDirectly | ArchWasm32 <- platformArch platform ->
pure $ CmmLit $ CmmLabel lbl
+ -- See Note [Mingw .refptr mechanism]
+ AccessViaRefPtr -> do
+ let refPtr = mkDynamicLinkerLabel DataRefPtr lbl
+ addImport refPtr
+ return $ cmmLoadBWord platform (cmmMakePicReference config refPtr)
+
AccessDirectly -> case referenceKind of
-- for data, we might have to make some calculations:
DataReference -> return $ cmmMakePicReference config lbl
@@ -244,6 +250,7 @@ ncgLabelDynamic config = labelDynamic (ncgThisModule config)
data LabelAccessStyle
= AccessViaStub
| AccessViaSymbolPtr
+ | AccessViaRefPtr -- See Note [Mingw .refptr mechanism]
| AccessDirectly
howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle
@@ -271,6 +278,18 @@ howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelA
--
howToAccessLabel config _arch OSMinGW32 _kind lbl
+ -- If we have a data symbol where it is not known if it is in the same
+ -- PE or another PE, then we resort to the .refptr mechanism.
+ -- See Note [Mingw .refptr mechanism]
+ --
+ -- Note that we do this _even when_ not ncgExternalDynamicRefs, because
+ -- -fexternal-dynamic-refs is about Haskell code being built as DLLs.
+ -- But ForeignLabelInUnknownPackage is about where foreign/C symbols
+ -- come from, which can always be from external DLLs (or static libs).
+ | isForeignLabelUnknownPackage lbl
+ , not (isCFunctionLabel lbl)
+ = AccessViaRefPtr
+
-- Assume all symbols will be in the same PE, so just access them directly.
| not (ncgExternalDynamicRefs config)
= AccessDirectly
@@ -627,6 +646,18 @@ pprImportedSymbol config importedLbl = case (arch,os) of
text "\t.long" <+> ppr_lbl lbl ]
_ -> empty
+ -- See Note [Mingw .refptr mechanism]
+ (_, OSMinGW32) -> case dynamicLinkerLabelInfo importedLbl of
+ Just (DataRefPtr, lbl)
+ -> lines_ [
+ text "\t.section\t.rdata$.refptr." <> ppr_lbl lbl
+ <> text ",\"dr\",discard,.refptr." <> ppr_lbl lbl,
+ text "\t.p2align\t3",
+ text ".globl\t" <> text ".refptr." <> ppr_lbl lbl,
+ text ".refptr." <> ppr_lbl lbl <> char ':',
+ text "\t.quad" <+> ppr_lbl lbl ]
+ _ -> empty
+
-- ELF / Linux
--
-- In theory, we don't need to generate any stubs or symbol pointers
=====================================
compiler/GHC/StgToCmm/Lit.hs
=====================================
@@ -97,8 +97,7 @@ mkSimpleLit platform = \case
(LitNumber LitNumWord64 i) -> CmmInt i W64
(LitFloat r) -> CmmFloat r W32
(LitDouble r) -> CmmFloat r W64
- (LitLabel fs fod)
- -> let -- TODO: Literal labels might not actually be in the current package...
- labelSrc = ForeignLabelInThisPackage
- in CmmLabel (mkForeignLabel fs labelSrc fod)
- other -> pprPanic "mkSimpleLit" (ppr other)
+ (LitLabel fs fod) -> CmmLabel (mkForeignLabel fs labelSrc fod)
+ -- See Note [Mingw .refptr mechanism]
+ where labelSrc = ForeignLabelInUnknownPackage
+ other -> pprPanic "mkSimpleLit" (ppr other)
=====================================
hadrian/src/Builder.hs
=====================================
@@ -356,6 +356,10 @@ instance H.Builder Builder where
Ghc FindHsDependencies _ -> do
runGhcWithResponse path buildArgs buildInputs
+ Ghc LinkHs _ -> do
+ runGhcWithResponse path [ "-v" | verbosity >= Diagnostic ]
+ buildArgs
+
HsCpp -> captureStdout
Make dir -> cmd' buildOptions path ["-C", dir] buildArgs
=====================================
rts/Linker.c
=====================================
@@ -232,7 +232,7 @@ static void ghciRemoveSymbolTable(StrHashTable *table, const SymbolName* key,
static const char *
symbolTypeString (SymType type)
{
- switch (type & ~(SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN)) {
+ switch (type & ~(SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN | SYM_TYPE_RTS_DEF)) {
case SYM_TYPE_CODE: return "code";
case SYM_TYPE_DATA: return "data";
case SYM_TYPE_INDIRECT_DATA: return "indirect-data";
@@ -270,6 +270,9 @@ int ghciInsertSymbolTable(
SymType type,
ObjectCode *owner)
{
+ /* mask out SYM_TYPE_RTS_DEF, see Note [RTS symbol exports] */
+ type &= ~SYM_TYPE_RTS_DEF;
+
RtsSymbolInfo *pinfo = lookupStrHashTable(table, key);
if (!pinfo) /* new entry */
{
@@ -472,16 +475,7 @@ initLinker_ (int retain_cafs)
symhash = allocStrHashTable();
/* populate the symbol table with stuff from the RTS */
- IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
- for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
- IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
- if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
- symhash, sym->lbl, sym->addr,
- sym->strength, sym->type, NULL)) {
- barf("ghciInsertSymbolTable failed");
- }
- }
- IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
+ initLinkerRtsSyms(symhash);
/* Add extra symbols. rtsExtraSyms() is a weakly defined symbol in the rts,
* that can be overrided by linking in an object with a corresponding
=====================================
rts/RtsSymbols.c
=====================================
@@ -9,6 +9,7 @@
#include "ghcplatform.h"
#include "Rts.h"
#include "RtsSymbols.h"
+#include "LinkerInternals.h"
#include "TopHandler.h"
#include "HsFFI.h"
@@ -50,6 +51,18 @@ extern char **environ;
/* -----------------------------------------------------------------------------
* Symbols to be inserted into the RTS symbol table.
+ *
+ * Note [Naming Scheme for Symbol Macros]
+ *
+ * SymI_*: symbol is internal to the RTS. It resides in an object
+ * file/library that is statically.
+ * SymE_*: symbol is external to the RTS library. It might be linked
+ * dynamically.
+ *
+ * Sym*_HasProto : the symbol prototype is imported in an include file
+ * or defined explicitly
+ * Sym*_NeedsProto: the symbol is undefined and we add a dummy
+ * default proto extern void sym(void);
*/
#define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \
@@ -1127,12 +1140,21 @@ extern char **environ;
SymI_HasProto(hs_word2float64)
-/* entirely bogus claims about types of these symbols */
-#define SymI_NeedsProto(vvv) extern void vvv(void);
-#define SymI_NeedsDataProto(vvv) extern StgWord vvv[];
-#define SymE_NeedsProto(vvv) SymI_NeedsProto(vvv);
-#define SymE_NeedsDataProto(vvv) SymI_NeedsDataProto(vvv);
-#define SymE_HasProto(vvv) SymI_HasProto(vvv);
+/* Declare prototypes for the symbols that need it, so we can refer
+ * to them in the rtsSyms table below.
+ *
+ * In particular, for the external ones (SymE_*) we use the dllimport attribute
+ * to indicate that (on Windows) they come from external DLLs. This attribute
+ * is ignored on other platforms.
+ *
+ * The claims about the types of these symbols are entirely bogus.
+ */
+#define SymI_NeedsProto(vvv) extern void vvv(void);
+#define SymI_NeedsDataProto(vvv) extern StgWord vvv[];
+#define SymE_NeedsProto(vvv) extern __attribute__((dllimport)) void vvv(void);
+#define SymE_NeedsDataProto(vvv) extern __attribute__((dllimport)) StgWord vvv[];
+
+#define SymE_HasProto(vvv) /**/
#define SymI_HasProto(vvv) /**/
#define SymI_HasDataProto(vvv) /**/
#define SymI_HasProto_redirect(vvv,xxx,strength,ty) /**/
@@ -1161,17 +1183,23 @@ RTS_SYMBOLS_PRIM
#undef SymE_NeedsProto
#undef SymE_NeedsDataProto
+/* See Note [Naming Scheme for Symbol Macros] */
+
#define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
- (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE },
+ (void*)(&(vvv)), STRENGTH_NORMAL, \
+ SYM_TYPE_CODE | SYM_TYPE_RTS_DEF },
#define SymI_HasDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
- (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_DATA },
+ (void*)(&(vvv)), STRENGTH_NORMAL, \
+ SYM_TYPE_DATA | SYM_TYPE_RTS_DEF },
#define SymE_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
(void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE },
#define SymE_HasDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
(void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_DATA },
-#define SymI_NeedsProto(vvv) SymI_HasProto(vvv)
-#define SymI_NeedsDataProto(vvv) SymI_HasDataProto(vvv)
+#define SymI_NeedsProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE },
+#define SymI_NeedsDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
+ (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_DATA },
#define SymE_NeedsProto(vvv) SymE_HasProto(vvv)
#define SymE_NeedsDataProto(vvv) SymE_HasDataProto(vvv)
@@ -1181,7 +1209,16 @@ RTS_SYMBOLS_PRIM
{ MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
(void*)(&(xxx)), strength, ty },
-RtsSymbolVal rtsSyms[] = {
+
+/* Populate the symbol table with stuff from the RTS. */
+void initLinkerRtsSyms (StrHashTable *symhash) {
+
+ /* The address of data symbols with the dllimport attribute are not
+ * compile-time constants and so cannot be used in constant initialisers.
+ * For this reason, rtsSyms is a local variable within this function
+ * rather than a global constant (as it was historically).
+ */
+ const RtsSymbolVal rtsSyms[] = {
RTS_SYMBOLS
RTS_RET_SYMBOLS
RTS_POSIX_ONLY_SYMBOLS
@@ -1196,7 +1233,19 @@ RtsSymbolVal rtsSyms[] = {
RTS_SYMBOLS_PRIM
SymI_HasDataProto(nonmoving_write_barrier_enabled)
{ 0, 0, STRENGTH_NORMAL, SYM_TYPE_CODE } /* sentinel */
-};
+ };
+
+ IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
+ for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
+ IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
+ if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
+ symhash, sym->lbl, sym->addr,
+ sym->strength, sym->type, NULL)) {
+ barf("ghciInsertSymbolTable failed");
+ }
+ }
+ IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
+}
// Note [Extra RTS symbols]
=====================================
rts/RtsSymbols.h
=====================================
@@ -9,6 +9,7 @@
#pragma once
#include "ghcautoconf.h"
+#include "Hash.h"
#if defined(LEADING_UNDERSCORE)
#define MAYBE_LEADING_UNDERSCORE_STR(s) ("_" s)
@@ -21,8 +22,8 @@ typedef char SymbolName;
/* What kind of thing a symbol identifies. We need to know this to determine how
* to process overflowing relocations. See Note [Processing overflowed relocations].
- * This is bitfield however only the option SYM_TYPE_DUP_DISCARD can be combined
- * with the other values. */
+ * This is bitfield however only the option SYM_TYPE_DUP_DISCARD and
+ * SYM_TYPE_RTS_DEF can be combined with the other values. */
typedef enum _SymType {
SYM_TYPE_CODE = 1 << 0, /* the symbol is a function and can be relocated via a jump island */
SYM_TYPE_DATA = 1 << 1, /* the symbol is data */
@@ -31,8 +32,34 @@ typedef enum _SymType {
however if a duplicate is found with a mismatching
SymType then discard this one. */
SYM_TYPE_HIDDEN = 1 << 4, /* the symbol is hidden and should not be exported */
+ SYM_TYPE_RTS_DEF = 1 << 5, /* the symbol is defined in the RTS DSO */
} SymType;
+/* Note [RTS symbol exports]
+ * SymType and SymStrength are used by the RTS's internal (aka GHCi) linker.
+ * They're also used by the rtsSyms array, which is used to pre-populate the
+ * GHCi linker symbol table (see ghciInsertSymbolTable calls in initLinker_).
+ * The rtsSyms array has a secondary purpose: to be the source of truth for
+ * which symbols are supposed to be exported from the RTS, when the RTS is
+ * built as a shared object (i.e. .so, .dll), which is handled by the native
+ * system linker.
+ *
+ * This is related but different to the GHCi linker. The GHCi linker's symbol
+ * table is pre-populated with RTS exported symbols but also additional symbols
+ * from dependent libraries and a few platform specific symbols and hacks (see
+ * for example Note [Strong symbols], and Note [Symbols for MinGW's printf],
+ * Note [Extra RTS symbols]). The GHCi linker does not need to distinguish
+ * known symbols that are defined within the RTS from known symbols from other
+ * libs. All of them are available to resolve against.
+ *
+ * So to serve the secondary purpose, we use the SYM_TYPE_RTS_DEF flag, which
+ * we combine with the other flags (CODE, DATA etc). We arrange to ignore this
+ * flag when pre-populating the GHCi linker symbol table. But we make use of it
+ * to dump the symbols that are intended to be exported from the RTS. This can
+ * be used by the build system and native linker to limit the symbols exported
+ * from the RTS shared object. See utils/rts-sym/rts-sym.c
+ */
+
typedef enum _SymStrength {
STRENGTH_NORMAL,
STRENGTH_WEAK,
@@ -46,7 +73,7 @@ typedef struct _RtsSymbolVal {
SymType type;
} RtsSymbolVal;
-extern RtsSymbolVal rtsSyms[];
+void initLinkerRtsSyms (StrHashTable *symhash);
extern RtsSymbolVal* __attribute__((weak)) rtsExtraSyms(void);
=====================================
utils/rts-syms/rts-syms.c
=====================================
@@ -0,0 +1,97 @@
+/* A utility to export the symbol table of the RTS. The RTS has a built-in
+ * linker, and has a pre-populated table of known RTS symbols.
+ *
+ * This is used primarily to generate input files for linkers, to limit the
+ * symbols exported from the RTS to those we want to export.
+ *
+ * This utility can generate Windows .def files (for making DLLs), or GNU ld
+ * linker scripts (used by GNU ld and LLVM ld for .so libs). We also support
+ * a raw dump format for curiosity or debugging.
+ */
+
+#include "RtsSymbols.h"
+
+/* RtsSymbols.h is an internal header file.
+ * It defines a symbol table (reordered and simplified for clarity):
+
+extern RtsSymbolVal rtsSyms;
+
+typedef struct _RtsSymbolVal {
+ const SymbolName* lbl;
+ SymbolAddr* addr;
+ SymStrength strength;
+ SymType type;
+ } RtsSymbolVal;
+
+typedef enum _SymType {
+ SYM_TYPE_CODE,
+ SYM_TYPE_DATA,
+ SYM_TYPE_INDIRECT_DATA,
+ SYM_TYPE_DUP_DISCARD,
+ SYM_TYPE_HIDDEN,
+ } SymType;
+
+ typedef enum _SymStrength {
+ STRENGTH_NORMAL,
+ STRENGTH_WEAK,
+ STRENGTH_STRONG,
+ } SymStrength;
+
+ */
+
+#include <stdio.h>
+
+void dump_nm_bsd(void);
+void dump_nm_posix(void);
+void init_ghc_hs_iface(void);
+
+int main (int argc, char *argv[]) {
+ //TODO: formats: raw, map and def
+ dump_nm_posix();
+}
+
+char *format_sym_type(SymType type);
+char *format_sym_strength(SymStrength strength);
+
+void dump_nm_bsd() {
+ for (int i = 0; rtsSyms[i].addr != 0; i++) {
+ RtsSymbolVal *sym = &rtsSyms[i];
+ printf("%.16lx %s%s %s\n", (unsigned long)(sym->addr),
+ format_sym_strength(sym->strength),
+ format_sym_type(sym->type),
+ sym->lbl);
+ }
+}
+
+void dump_nm_posix() {
+ for (int i = 0; rtsSyms[i].addr != 0; i++) {
+ RtsSymbolVal *sym = &rtsSyms[i];
+ printf("%s %s\n", sym->lbl, format_sym_type(sym->type));
+ }
+}
+
+char *format_sym_type(SymType type) {
+ /* Ignore SYM_TYPE_DUP_DISCARD, SYM_TYPE_HIDDEN as they do not occur in
+ * the RTS built-in symbol table. (They can occur in other loaded libraries).
+ */
+ switch (type & ~(SYM_TYPE_DUP_DISCARD | SYM_TYPE_HIDDEN | SYM_TYPE_RTS_DEF)) {
+ case SYM_TYPE_CODE: return "T";
+ case SYM_TYPE_DATA: return "D";
+ case SYM_TYPE_INDIRECT_DATA: return "I";
+ default: return " ";
+ }
+}
+
+char *format_sym_strength(SymStrength strength) {
+ switch (strength) {
+ case STRENGTH_NORMAL: return " ";
+ case STRENGTH_WEAK: return "W";
+ case STRENGTH_STRONG: return "S";
+ default: return " ";
+ }
+}
+
+void init_ghc_hs_iface(void) {
+ return;
+};
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a1ed49b90a53e7299294ee4c60d81…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9a1ed49b90a53e7299294ee4c60d81…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/ticked_joins] Allow join point Ids to occur below ticks & casts
by sheaf (＠sheaf) 02 Feb '26
by sheaf (＠sheaf) 02 Feb '26
02 Feb '26
sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC
Commits:
d48c2efa by sheaf at 2026-02-02T11:10:23+01:00
Allow join point Ids to occur below ticks & casts
This commit classifies all join points into two categories:
- true join points
- quasi join points
A quasi join point is a join point for which a jump is enclosed within
a profiling tick or a cast.
The only operational difference is that, for quasi join points, we
cannot perform the case-of-case transformation described in
Note [Join points and case-of-case] in GHC.Core.Opt.Simplify.Iteration.
All of this is explained in detail in Note [Quasi join points].
Fixes #26693 and #26642
Improves on #14610, #26157 and #26422, as it means casts/profiling ticks
don't prevent join points, but it doesn't entirely fix these issues
because we are still inhibiting optimisations (lack of case-of-case).
- - - - -
31 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/profiling/should_run/T2552.prof.sample
- testsuite/tests/profiling/should_run/ioprof.prof.sample
- testsuite/tests/profiling/should_run/scc001.prof.sample
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d48c2efaab0830a15e0ff46e138e95d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d48c2efaab0830a15e0ff46e138e95d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26548] 15 commits: Remove `GHC.Desugar` from `base`
by Simon Peyton Jones (＠simonpj) 02 Feb '26
by Simon Peyton Jones (＠simonpj) 02 Feb '26
02 Feb '26
Simon Peyton Jones pushed to branch wip/T26548 at Glasgow Haskell Compiler / GHC
Commits:
607b287b by Wolfgang Jeltsch at 2026-01-28T15:41:53+02:00
Remove `GHC.Desugar` from `base`
`GHC.Desugar` was deprecated and should have been removed in GHC 9.14.
However, the removal was forgotten, although there was a code block that
was intended to trigger a compilation error when the GHC version in use
was 9.14 or later. This code sadly didn’t work, because the
`__GLASGOW_HASKELL__` macro was misspelled as `__GLASGOW_HASKELL`.
- - - - -
e8f5a45d by sterni at 2026-01-29T04:19:18-05:00
users_guide: fix runtime error during build with Sphinx 9.1.0
Appears that pathto is stricter about what it accepts now.
Tested Sphinx 8.2.3 and 9.1.0 on the ghc-9.10 branch.
Resolves #26810.
Co-authored-by: Martin Weinelt <hexa(a)darmstadt.ccc.de>
- - - - -
ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00
PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC
There is no native instruction for this, and even if there were a
register pair version we could use, the implementation here is assuming
the values fit in a single register, and we end up only using / defining
the low halves of the registers.
Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes")
Fixes: #23969
- - - - -
43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00
NCG for PPC: add pattern for CmmRegOff to iselExpr64
Closes #26828
- - - - -
aeeb4a20 by Matthew Pickering at 2026-01-30T11:42:47-05:00
determinism: Use deterministic map for Strings in TyLitMap
When generating typeable evidence the types we need evidence for all
cached in a TypeMap, the order terms are retrieved from a type map
determines the order the bindings appear in the program.
A TypeMap is quite diligent to use deterministic maps, apart from in the
TyLitMap, which uses a UniqFM for storing strings, whose ordering
depends on the Unique of the FastString.
This can cause non-deterministic .hi and .o files.
An unexpected side-effect is the error message but RecordDotSyntaxFail8
changing. I looked into this with Sam and this change caused the
constraints to be solved in a different order which results in a
slightly different error message. I have accepted the new test, since
the output before was non-deterministic and the new output is consistent
with the other messages in that file.
Fixes #26846
- - - - -
9e4d70c2 by Andrew Lelechenko at 2026-01-30T11:43:29-05:00
Upgrade text submodule to 2.1.4
- - - - -
631fa5ae by Recursion Ninja at 2026-01-31T22:30:11+00:00
Decouple `L.S.H.Decls` from importing `GHC.Types.Basic`
Data-types within `GHC.Types.Basic` which describe components of
the AST are migrated to `Language.Haskell.Syntax.Basic`. Related
function definitions are also moved.
Types moved to L.H.S. because they are part of the AST:
* TopLevelFlag
* RuleName
Types moved from L.H.S. to GHC.Hs. because they are not needed in the AST:
* TyConFlavour
* TypeOrData
* NewOrData
Migrated instances:
* `Outputable` instances moved to in `GHC.Utils.Outputable`
* `Binary` instance of `Boxity` moved to to `GHC.Utils.Binary`
* Other `Binary` instances are orphans to be migrated later.
The `OverlapMode` data-type is given a TTG extension point.
The `OverlapFlag` data-type, which depends on `OverlapMode`,
is updated to support `OverlapMode` with a GHC "pass" type paramerter.
In order to avoid module import cycles, `OverlapMode` and `OverlapFlag`
are migrated to new modules (no way around this).
* Migrated `OverlapMode` to new module `Language.Haskell.Syntax.Overlap`
* Migrated `OverlapFlag` to new module `GHC.Hs.Decls.Overlap`
- - - - -
9769cc03 by Simon Hengel at 2026-02-01T04:21:03-05:00
Update the documentation for MultiWayIf (fixes #25376)
(so that it matches the implementation)
- - - - -
5fc9442a by Peter Trommler at 2026-02-01T04:21:44-05:00
hadrian: Fix dependency generation for assembler
Assembler files allow # for comments unless in column 1. A modern
cpp for C treats those a preprocessor directives. We tell gcc that
a .S file is assembler with cpp and not C.
Fixes #26819
- - - - -
269c4087 by Simon Peyton Jones at 2026-02-01T19:38:10-05:00
Include current phase in the range for rule/unfoldings
This MR fixes a bad loop in the compiler: #26826.
The fix is to add (WAR2) to
Note [What is active in the RHS of a RULE or unfolding?]
in GHC.Core.Opt.Simplify.Utils
- - - - -
ddf1434f by Vladislav Zavialov at 2026-02-01T19:38:52-05:00
Refactor: merge HsMultilineString into HsString (#26860)
Before this patch, HsLit defined two separate constructors to represent
single-line and multi-line strings:
data HsLit x
...
| HsString (XHsString x) FastString
| HsMultilineString (XHsMultilineString x) FastString
I found this to be an unnecessary complication and an obstacle to unifying
HsLit with HsTyLit. Now we use HsString for both kinds of literals.
One user-facing change here is `ppr (HsString st s)` behaving differently for
single-line strings containing newlines:
x = "first line \
\asdf\n\
\second line"
Previously, the literal was fed to `ftext` with its newlines, producing an
ill-formed SDoc. This issue is now addressed by using `split` for both
single-line and multi-line strings:
vcat $ map text $ split '\n' (unpackFS src)
See the parser/should_fail/T26860ppr test.
In addition (and unrelatedly to the main payload of this patch),
drop the unused pmPprHsLit helper.
- - - - -
8bc23d68 by Simon Peyton Jones at 2026-02-02T09:35:06+00:00
Fix evaluated-ness bug in Simplifier
This fixes #26548, an error which meant that we were failing to
attach evaluated-ness flags to case-alternative-bound variables
- - - - -
7d615601 by Simon Peyton Jones at 2026-02-02T09:35:06+00:00
Be a little less eager to inline
---> OtherCon [] = TrivArg
OtherCon _ = NonTrivArg
Make inlining a tiny bit more eager
---> OtherCon [] = NonTrivArg
In particular
x = mkSymMCo mco
where mco is evaluated. We want that to inline, especially if the
let is strict. Makes a significant difference in Rewrite.hs,
Test case T9872b
OtherCon [] arguments aren't interesting
---> OtherCon [] = TrivArg
Remove white space
Be a little less keen to inline
This commit changes interestingArg to treat lambda as NonTrivArg
rather than ValueArg. That makes parser combinators a bit less
keen to inline. E.g.
<|> p1 p2 = \x -> case p1 x of
Yes -> ...
No -> ...
If we have a call (<|> arg1 arg2) where arg1 is a parser, and hence
often visibly a lambda, it's no so great to inline <|>, because we
are still stuck on x.
This affects for example T17516
Just an experiment.
- - - - -
97e75321 by Simon Peyton Jones at 2026-02-02T09:35:06+00:00
Wibbles
In particular, a lambda is a value argument in interestingArg
For some reason I had changed this and it made many things worse
This wibble puts it back!
- - - - -
70092bd0 by Simon Peyton Jones at 2026-02-02T09:35:06+00:00
Tracing in SpecConstr only
- - - - -
81 changed files:
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Hs/Decls.hs
- + compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/String.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/InlinePragma.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- + compiler/Language/Haskell/Syntax/Decls/Overlap.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/multiway_if.rst
- docs/users_guide/rtd-theme/layout.html
- hadrian/src/Builder.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Settings/Builders/Cc.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/base.cabal.in
- − libraries/base/src/GHC/Desugar.hs
- libraries/text
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/ghc-api/TypeMapStringLiteral.hs
- testsuite/tests/ghc-api/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/numeric/should_compile/T19641.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- + testsuite/tests/parser/should_fail/T26860ppr.hs
- + testsuite/tests/parser/should_fail/T26860ppr.stderr
- testsuite/tests/parser/should_fail/all.T
- + testsuite/tests/simplCore/should_compile/T26548.hs
- + testsuite/tests/simplCore/should_compile/T26548.stderr
- testsuite/tests/simplCore/should_compile/T26615.stderr
- + testsuite/tests/simplCore/should_compile/T26826.hs
- testsuite/tests/simplCore/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/073afea64f641d3b05c3f39accfa2f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/073afea64f641d3b05c3f39accfa2f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
faaa724a by Apoorv Ingle at 2026-02-02T00:46:24-06:00
notes update
Note [Typechecking by expansion: overview]
- - - - -
6 changed files:
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/SrcLoc.hs
Changes:
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1158,7 +1158,8 @@ the typechecker:
ApplicativeStmt.
* Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original
list expression to the expanded expression. The 'fromListN' is assigned
- a generated location span
+ a generated location span with location span details to be of the original list expression
+ c.f. GeneratedSrcSpan in GHC.Tc.Types.SrcLoc
In order for the implicit function calls to not be confused for actual
occurrences of functions in the source code, most of this extra information
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -307,7 +307,7 @@ tcExpr :: HsExpr GhcRn
-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
-- See Note [Application chains and heads] in GHC.Tc.Gen.App
--- Se Note [Overview of Typechecking an XExpr]
+-- Se Note [Typechecking by expansion: overview]
tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
@@ -823,10 +823,10 @@ The rest of this Note explains how that is done.
* The type checker error-stack element `GHC.Tc.Types.ErrCtxt.ErrCtxt`
has two fields
- data ErrCtxt = EC ErrCtxt
+ data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxt
* `CodeSrcFlag` says whether we are typechecking an expanded thing,
- and what that expanded thing is
+ and what that expanded thing is.
* `ErrCtxtMsgM` stores the pre-text error message itself.
When called on an `XExpr`, `addLExprCtxt`, adds the user written thing
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -42,7 +42,6 @@ import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
-import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg )
import GHC.Tc.Types.Constraint( WantedConstraints )
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Types.Evidence
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1368,7 +1368,7 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt)
-- do any tidying.
-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a
-o{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
+{-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt]
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
-- See Note [ErrCtxtStack Manipulation]
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)
-import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..), pprGeneratedSrcSpanDetails)
+import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, pprGeneratedSrcSpanDetails)
import GHC.Unit.Module.Imported (ImportedModsVal(..))
import GHC.Unit.Types
import GHC.Utils.Outputable
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -396,10 +396,10 @@ data SrcSpan =
deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we
-- derive Show for Token
--- Needed for HIE
+-- Needed for HIE. See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
data GeneratedSrcSpanDetails =
OrigSpan !RealSrcSpan -- this the span of the user written thing
- | UnhelpfulGenerated
+ | UnhelpfulGenerated -- we do not have the original location.
deriving (Eq, Show)
data UnhelpfulSpanReason
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/faaa724a6bbdbd534b0273e8a25a370…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/faaa724a6bbdbd534b0273e8a25a370…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] 33 commits: hadrian: Bump QuickCheck upper bound
by Apoorv Ingle (＠ani) 02 Feb '26
by Apoorv Ingle (＠ani) 02 Feb '26
02 Feb '26
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
be8e5236 by Ben Gamari at 2026-01-23T03:28:45-05:00
hadrian: Bump QuickCheck upper bound
This patch bumps QuickCheck upper bound to 2.18. selftest rule
manually tested to work with current latest QuickCheck-2.17.1.0.
- - - - -
5aa328fb by Zubin Duggal at 2026-01-23T03:29:30-05:00
Add genindex to index.rst. This adds a link to the index in the navigation bar.
Fixes #26437
- - - - -
917ab8ff by Oleg Grenrus at 2026-01-23T10:52:55-05:00
Export labelThread from Control.Concurrent
- - - - -
3f5e8d80 by Cheng Shao at 2026-01-23T10:53:37-05:00
ci: only push perf notes on master/release branches
This patch fixes push_perf_notes logic in ci.sh to only push perf
notes on master/release branches. We used to unconditionally push perf
notes even in MRs, but the perf numbers in the wip branches wouldn't
be used as baseline anyway, plus this is causing a space leak in the
ghc-performance-notes repo. See #25317 for the perf notes repo size
problem.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
414b9593 by Cheng Shao at 2026-01-24T07:11:51-05:00
ci: remove duplicate keys in .gitlab-ci.yml
This patch removes accidentally duplicate keys in `.gitlab-ci.yml`.
The YAML spec doesn't allow duplicate keys in the first place, and
according to GitLab docs
(https://docs.gitlab.com/ci/yaml/yaml_optimization/#anchors) the
latest key overrides the earlier entries.
- - - - -
e5cb5491 by Cheng Shao at 2026-01-24T07:12:34-05:00
hadrian: drop obsolete configure/make builder logic for libffi
This patch drops obsolete hadrian logic around `Configure
libffiPath`/`Make libffiPath` builders, they are no longer needed
after libffi-clib has landed. Closes #26815.
- - - - -
2d160222 by Simon Hengel at 2026-01-24T07:13:17-05:00
Fix typo in roles.rst
- - - - -
56db94f7 by Peter Trommler at 2026-01-26T11:26:18+01:00
PPC NCG: Generate clear right insn at arch width
The clear right immediate (clrrxi) is only available in word and
doubleword width. Generate clrrxi instructions at architecture
width for all MachOp widths.
Fixes #24145
- - - - -
5957a8ad by Wolfgang Jeltsch at 2026-01-27T06:11:40-05:00
Add operations for obtaining operating-system handles
This contribution implements CLC proposal #369. It adds operations for
obtaining POSIX file descriptors and Windows handles that underlie
Haskell handles. Those operating system handles can also be obtained
without such additional operations, but this is more involved and, more
importantly, requires using internals.
- - - - -
86a0510c by Greg Steuck at 2026-01-27T06:12:34-05:00
Move flags to precede patterns for grep and read files directly
This makes the tests pass with non-GNU (i.e. POSIX-complicant) tools.
There's no reason to use cat and pipe where direct file argument works.
- - - - -
50761451 by Cheng Shao at 2026-01-27T21:51:23-05:00
ci: update darwin boot ghc to 9.10.3
This patch updates darwin boot ghc to 9.10.3, along with other related
updates, and pays off some technical debt here:
- Update `nixpkgs` and use the `nixpkgs-25.05-darwin` channel.
- Update the `niv` template.
- Update LLVM to 21 and update `llvm-targets` to reflect LLVM 21
layout changes for arm64/x86_64 darwin targets.
- Use `stdenvNoCC` to prevent nix packaged apple sdk from being used
by boot ghc, and manually set `DEVELOPER_DIR`/`SDKROOT` to enforce
the usage of system-wide command line sdk for macos.
- When building nix derivation for boot ghc, run `configure` via the
`arch` command so that `configure` and its subprocesses pick up the
manually specified architecture.
- Remove the previous horrible hack that obliterates `configure` to
make autoconf test result in true. `configure` now properly does its
job.
- Remove the now obsolete configure args and post install settings
file patching logic.
- Use `scheme-small` for texlive to avoid build failures in certain
unused texlive packages, especially on x86_64-darwin.
- - - - -
94dcd15e by Matthew Pickering at 2026-01-27T21:52:05-05:00
Evaluate backtraces for "error" exceptions at the moment they are thrown
See Note [Capturing the backtrace in throw] and
Note [Hiding precise exception signature in throw] which explain the
implementation.
This commit makes `error` and `throw` behave the same with regard to
backtraces. Previously, exceptions raised by `error` would not contain
useful IPE backtraces.
I did try and implement `error` in terms of `throw` but it started to
involve putting diverging functions into hs-boot files, which seemed to
risky if the compiler wouldn't be able to see if applying a function
would diverge.
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383
Fixes #26751
- - - - -
ef35e3ea by Teo Camarasu at 2026-01-27T21:52:46-05:00
ghc-internal: move all Data instances to Data.Data
Most instances of Data are defined in GHC.Internal.Data.Data.
Let's move all remaining instance there.
This moves other modules down in the dependency hierarchy allowing for
more parallelism, and it decreases the likelihood that we would need to
load this heavy .hi file if we don't actually need it.
Resolves #26830
Metric Decrease:
T12227
T16875
- - - - -
5e0ec555 by sheaf at 2026-01-28T06:56:38-05:00
Add test case for #25679
This commit adds the T25679 test case. The test now passes, thanks to
commit 1e53277af36d3f0b6ad5491f70ffc5593a49dcfd.
Fixes #25679
- - - - -
f1cd1611 by sheaf at 2026-01-28T06:56:38-05:00
Improve defaulting of representational equalities
This commit makes the defaulting of representational equalities, introduced
in 1e53277a, a little bit more robust. Now, instead of calling the eager
unifier, it calls the full-blown constraint solver, which means that it can
handle some subtle situations, e.g. involving functional dependencies and
type-family injectivity annotations, such as:
type family F a = r | r -> a
type instance F Int = Bool
[W] F beta ~R Bool
- - - - -
25edf516 by sheaf at 2026-01-28T06:56:38-05:00
Improve errors for unsolved representational equalities
This commit adds a new field of CtLoc, CtExplanations, which allows the
typechecker to leave some information about what it has done. For the moment,
it is only used to improve error messages for unsolved representational
equalities. The typechecker will now accumulate, when unifying at
representational role:
- out-of-scope newtype constructors,
- type constructors that have nominal role in a certain argument,
- over-saturated type constructors,
- AppTys, e.g. `c a ~R# c b`, to report that we must assume that 'c' has
nominal role in its parameters,
- data family applications that do not reduce, potentially preventing
newtype unwrapping.
Now, instead of having to re-construct the possible errors after the fact,
we simply consult the CtExplanations field.
Additionally, this commit modifies the typechecker error messages that
concern out-of-scope newtype constructors. The error message now depends
on whether we have an import suggestion to provide to the user:
- If we have an import suggestion for the newtype constructor,
the message will be of the form:
The data constructor MkN of the newtype N is out of scope
Suggested fix: add 'MkN' to the import list in the import of 'M'
- If we don't have any import suggestions, the message will be
of the form:
NB: The type 'N' is an opaque newtype, whose constructor is hidden
Fixes #15850, #20289, #20468, #23731, #25949, #26137
- - - - -
4d0e6da1 by Simon Peyton Jones at 2026-01-28T06:57:19-05:00
Fix two bugs in short-cut constraint solving
There are two main changes here:
* Use `isSolvedWC` rather than `isEmptyWC` in `tryShortCutSolver`
The residual constraint may have some fully-solved, but
still-there implications, and we don't want them to abort short
cut solving! That bug caused #26805.
* In the short-cut solver, we abandon the fully-solved residual
constraint; but we may thereby lose track of Givens that are
needed, and either report them as redundant or prune evidence
bindings that are in fact needed.
This bug stopped the `constraints` package from compiling;
see the trail in !15389.
The second bug led me to (another) significant refactoring
of the mechanism for tracking needed EvIds. See the new
Note [Tracking needed EvIds] in GHC.Tc.Solver.Solve
It's simpler and much less head-scratchy now.
Some particulars:
* An EvBindsVar now tracks NeededEvIds
* We deal with NeededEvIds for an implication only when it is
fully solved. Much simpler!
* `tryShortCutTcS` now takes a `TcM WantedConstraints` rather than
`TcM Bool`, so that is can plumb the needed EvIds correctly.
* Remove `ic_need` and `ic_need_implic` from Implication (hooray),
and add `ics_dm` and `ics_non_dm` to `IC_Solved`.
Pure refactor
* Shorten data constructor `CoercionHole` to `CH`, following
general practice in GHC.
* Rename `EvBindMap` to `EvBindsMap` for consistency
- - - - -
662480b7 by Cheng Shao at 2026-01-28T06:58:00-05:00
ci: use debian validate bindists instead of fedora release bindists in testing stage
This patch changes the `abi-test`, `hadrian-multi` and `perf` jobs in
the full-ci pipeline testing stage to use debian validate bindists
instead of fedora release bindists, to increase pipeline level
parallelism and allow full-ci pipelines to complete earlier. Closes #26818.
- - - - -
39581ec6 by Cheng Shao at 2026-01-28T06:58:40-05:00
ci: run perf test with -j$cores
This patch makes the perf ci job compile Cabal with -j$cores to speed
up the job.
- - - - -
607b287b by Wolfgang Jeltsch at 2026-01-28T15:41:53+02:00
Remove `GHC.Desugar` from `base`
`GHC.Desugar` was deprecated and should have been removed in GHC 9.14.
However, the removal was forgotten, although there was a code block that
was intended to trigger a compilation error when the GHC version in use
was 9.14 or later. This code sadly didn’t work, because the
`__GLASGOW_HASKELL__` macro was misspelled as `__GLASGOW_HASKELL`.
- - - - -
e8f5a45d by sterni at 2026-01-29T04:19:18-05:00
users_guide: fix runtime error during build with Sphinx 9.1.0
Appears that pathto is stricter about what it accepts now.
Tested Sphinx 8.2.3 and 9.1.0 on the ghc-9.10 branch.
Resolves #26810.
Co-authored-by: Martin Weinelt <hexa(a)darmstadt.ccc.de>
- - - - -
ce2d62fb by Jessica Clarke at 2026-01-29T19:48:51-05:00
PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC
There is no native instruction for this, and even if there were a
register pair version we could use, the implementation here is assuming
the values fit in a single register, and we end up only using / defining
the low halves of the registers.
Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes")
Fixes: #23969
- - - - -
43d97761 by Michael Karcher at 2026-01-29T19:49:43-05:00
NCG for PPC: add pattern for CmmRegOff to iselExpr64
Closes #26828
- - - - -
aeeb4a20 by Matthew Pickering at 2026-01-30T11:42:47-05:00
determinism: Use deterministic map for Strings in TyLitMap
When generating typeable evidence the types we need evidence for all
cached in a TypeMap, the order terms are retrieved from a type map
determines the order the bindings appear in the program.
A TypeMap is quite diligent to use deterministic maps, apart from in the
TyLitMap, which uses a UniqFM for storing strings, whose ordering
depends on the Unique of the FastString.
This can cause non-deterministic .hi and .o files.
An unexpected side-effect is the error message but RecordDotSyntaxFail8
changing. I looked into this with Sam and this change caused the
constraints to be solved in a different order which results in a
slightly different error message. I have accepted the new test, since
the output before was non-deterministic and the new output is consistent
with the other messages in that file.
Fixes #26846
- - - - -
9e4d70c2 by Andrew Lelechenko at 2026-01-30T11:43:29-05:00
Upgrade text submodule to 2.1.4
- - - - -
631fa5ae by Recursion Ninja at 2026-01-31T22:30:11+00:00
Decouple `L.S.H.Decls` from importing `GHC.Types.Basic`
Data-types within `GHC.Types.Basic` which describe components of
the AST are migrated to `Language.Haskell.Syntax.Basic`. Related
function definitions are also moved.
Types moved to L.H.S. because they are part of the AST:
* TopLevelFlag
* RuleName
Types moved from L.H.S. to GHC.Hs. because they are not needed in the AST:
* TyConFlavour
* TypeOrData
* NewOrData
Migrated instances:
* `Outputable` instances moved to in `GHC.Utils.Outputable`
* `Binary` instance of `Boxity` moved to to `GHC.Utils.Binary`
* Other `Binary` instances are orphans to be migrated later.
The `OverlapMode` data-type is given a TTG extension point.
The `OverlapFlag` data-type, which depends on `OverlapMode`,
is updated to support `OverlapMode` with a GHC "pass" type paramerter.
In order to avoid module import cycles, `OverlapMode` and `OverlapFlag`
are migrated to new modules (no way around this).
* Migrated `OverlapMode` to new module `Language.Haskell.Syntax.Overlap`
* Migrated `OverlapFlag` to new module `GHC.Hs.Decls.Overlap`
- - - - -
9769cc03 by Simon Hengel at 2026-02-01T04:21:03-05:00
Update the documentation for MultiWayIf (fixes #25376)
(so that it matches the implementation)
- - - - -
5fc9442a by Peter Trommler at 2026-02-01T04:21:44-05:00
hadrian: Fix dependency generation for assembler
Assembler files allow # for comments unless in column 1. A modern
cpp for C treats those a preprocessor directives. We tell gcc that
a .S file is assembler with cpp and not C.
Fixes #26819
- - - - -
269c4087 by Simon Peyton Jones at 2026-02-01T19:38:10-05:00
Include current phase in the range for rule/unfoldings
This MR fixes a bad loop in the compiler: #26826.
The fix is to add (WAR2) to
Note [What is active in the RHS of a RULE or unfolding?]
in GHC.Core.Opt.Simplify.Utils
- - - - -
ddf1434f by Vladislav Zavialov at 2026-02-01T19:38:52-05:00
Refactor: merge HsMultilineString into HsString (#26860)
Before this patch, HsLit defined two separate constructors to represent
single-line and multi-line strings:
data HsLit x
...
| HsString (XHsString x) FastString
| HsMultilineString (XHsMultilineString x) FastString
I found this to be an unnecessary complication and an obstacle to unifying
HsLit with HsTyLit. Now we use HsString for both kinds of literals.
One user-facing change here is `ppr (HsString st s)` behaving differently for
single-line strings containing newlines:
x = "first line \
\asdf\n\
\second line"
Previously, the literal was fed to `ftext` with its newlines, producing an
ill-formed SDoc. This issue is now addressed by using `split` for both
single-line and multi-line strings:
vcat $ map text $ split '\n' (unpackFS src)
See the parser/should_fail/T26860ppr test.
In addition (and unrelatedly to the main payload of this patch),
drop the unused pmPprHsLit helper.
- - - - -
3c3e041f by Apoorv Ingle at 2026-02-01T23:39:24-06:00
Work for #25001
Notes added [Error Context Stack]
Notes updated Note [Expanding HsDo with XXExprGhcRn]
-------------------------
Metric Decrease:
T9020
-------------------------
* Streamlines implementations of `tcExpr` and `tcXExpr` to work on `XExpr`
* Kills `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`.
* Kills the function `addHeadCtxt` as it is now mearly setting a location
* The function `tcValArgs` does its own argument number management
* Makes `splitHsApps` not look through `XExpr`
* `tcExprSigma` is called if the head of the expression after calling `splitHsApps` turns out to be an `XExpr`
* Removes location information from `OrigPat` payload
* Removes special case of tcBody from `tcLambdaMatches`
* Removes special case of `dsExpr` for `ExpandedThingTc`
* Rename `HsThingRn` to `SrcCodeCtxt`
* Kills `tcl_in_gen_code` and `tcl_err_ctxt`. It is subsumed by `ErrCtxtStack`
* Kills `ExpectedFunTyOrig`. It is subsumed by `CtOrigin`
* Fixes `CtOrigin` for `HsProjection` case in `exprCtOrigin`. It was previously assigned to be `SectionOrigin`. It is now just the expression
* Adds a new `CtOrigin.ExpansionOrigin` for storing the original syntax
* Adds a new `CtOrigin.ExpectedTySyntax` as a replacement for `ExpectedTySyntaxOp`. Cannot kill the former yet because of `ApplicativeDo`
* Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr`
* Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span`
* kill `PopErrCtxt` from `XXExprGhcRn`
* simplify `addArgCtxt` and push `setSrcSpan` inside `addLExprCtxt`. Make sure addExprCtxt is not called by itself
* fun_orig in tcApp depends on the SrcSpan of the head of the application chain (similar to addArgCtxt)
* rename fun_ctxt to fun_lspan, fun_orig passed in tcInstFun to default to app chain head if its user located, fall back to srcCodeOrigin if it's a generated location
* fix quickLookArg function to blame the correct application chain head. The arguments application chain head should be blamed, not the original head when we quick look arg
* Make sure only expression wrapped around generated src span are ignored while adding them to the error context stack
* `getDeepSubsumptionFlag_DataConHead` performs a non-trivial traversal if the expression passed to it is complex.
This traversal is necessary if the head of the function is an `XExpr` and `splitHsApps` does not look through them
- The deepsubsumption flag is stored in EVAlArgQL to reduce the need to call `getDeepSubsumptionFlag_DataConHead`
- `getDeepSubsumptionFlag_DataConHead` is called in `tcExprSigma` and `tcInferAppHead` to reduce AST traversals
* Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes
* wrap `fromListN` with a generated src span with GeneratedSrcSpanDetails field to store the original srcspan
* remove `UnhelpfulGenerated` from `UnhelpfulSpanReason` and into new datatype `GeneratedSrcSpanDetails`
- - - - -
33bf50fe by Simon Peyton Jones at 2026-02-01T23:39:47-06:00
Wibbles
- - - - -
dcfa593c by Apoorv Ingle at 2026-02-02T00:24:42-06:00
notes update
Note [Typechecking by expansion: overview]
- - - - -
268 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/darwin/nix/sources.json
- .gitlab/darwin/toolchain.nix
- compiler/GHC.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/TyCon/RecWalk.hs
- compiler/GHC/Data/Maybe.hs
- compiler/GHC/Hs/Decls.hs
- + compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Errors/Types.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Solver.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Parser/String.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- + compiler/GHC/Tc/Gen/App.hs-boot
- compiler/GHC/Tc/Gen/Default.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/InlinePragma.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Logger.hs
- compiler/GHC/Utils/Monad.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/GHC/Utils/Trace.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- + compiler/Language/Haskell/Syntax/Decls/Overlap.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- compiler/ghc.cabal.in
- docs/users_guide/exts/multiway_if.rst
- docs/users_guide/exts/roles.rst
- docs/users_guide/index.rst
- docs/users_guide/rtd-theme/layout.html
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- hadrian/hadrian.cabal
- hadrian/src/Builder.hs
- hadrian/src/Context.hs
- hadrian/src/Rules/Compile.hs
- hadrian/src/Settings/Builders/Cc.hs
- hadrian/src/Settings/Builders/Configure.hs
- hadrian/src/Settings/Builders/Make.hs
- hadrian/src/Settings/Packages.hs
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Control/Concurrent.hs
- − libraries/base/src/GHC/Desugar.hs
- + libraries/base/src/System/IO/OS.hs
- libraries/base/src/System/Timeout.hs
- libraries/base/tests/IO/all.T
- + libraries/base/tests/IO/osHandles001FileDescriptors.hs
- + libraries/base/tests/IO/osHandles001FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles001WindowsHandles.hs
- + libraries/base/tests/IO/osHandles001WindowsHandles.stdout
- + libraries/base/tests/IO/osHandles002FileDescriptors.hs
- + libraries/base/tests/IO/osHandles002FileDescriptors.stderr
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdin
- + libraries/base/tests/IO/osHandles002FileDescriptors.stdout
- + libraries/base/tests/IO/osHandles002WindowsHandles.hs
- + libraries/base/tests/IO/osHandles002WindowsHandles.stderr
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdin
- + libraries/base/tests/IO/osHandles002WindowsHandles.stdout
- libraries/base/tests/T23454.stderr
- libraries/base/tests/perf/Makefile
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Err.hs
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/Functor/ZipList.hs
- + libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/tests/stack-annotation/all.T
- + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs
- + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
- libraries/text
- llvm-targets
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/default/T25825.hs
- testsuite/tests/default/all.T
- testsuite/tests/deriving/should_fail/T1496.stderr
- testsuite/tests/deriving/should_fail/T4846.stderr
- testsuite/tests/deriving/should_fail/T5498.stderr
- testsuite/tests/deriving/should_fail/T6147.stderr
- testsuite/tests/deriving/should_fail/T7148.stderr
- testsuite/tests/deriving/should_fail/T7148a.stderr
- testsuite/tests/deriving/should_fail/T8984.stderr
- testsuite/tests/deriving/should_fail/deriving-via-fail.stderr
- testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
- testsuite/tests/deriving/should_fail/deriving-via-fail5.stderr
- testsuite/tests/driver/T16318/Makefile
- testsuite/tests/driver/T18125/Makefile
- testsuite/tests/gadt/CasePrune.stderr
- + testsuite/tests/ghc-api/TypeMapStringLiteral.hs
- testsuite/tests/ghc-api/all.T
- testsuite/tests/ghci.debugger/scripts/T8487.stdout
- testsuite/tests/ghci.debugger/scripts/break011.stdout
- testsuite/tests/ghci.debugger/scripts/break017.stdout
- testsuite/tests/ghci.debugger/scripts/break025.stdout
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/indexed-types/should_fail/T9580.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/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/linear/should_fail/LinearRole.stderr
- testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- + testsuite/tests/parser/should_fail/T26860ppr.hs
- + testsuite/tests/parser/should_fail/T26860ppr.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/rebindable/rebindable6.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/roles/should_fail/RolesIArray.stderr
- + testsuite/tests/simplCore/should_compile/T26805.hs
- + testsuite/tests/simplCore/should_compile/T26805.stderr
- + testsuite/tests/simplCore/should_compile/T26826.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs
- testsuite/tests/typecheck/should_compile/T14590.stderr
- + testsuite/tests/typecheck/should_compile/T26805a.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10285.stderr
- testsuite/tests/typecheck/should_fail/T10534.stderr
- testsuite/tests/typecheck/should_fail/T10715b.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T11347.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T15801.stderr
- + testsuite/tests/typecheck/should_fail/T15850.hs
- + testsuite/tests/typecheck/should_fail/T15850.stderr
- + testsuite/tests/typecheck/should_fail/T15850_Lib.hs
- + testsuite/tests/typecheck/should_fail/T20289.hs
- + testsuite/tests/typecheck/should_fail/T20289.stderr
- + testsuite/tests/typecheck/should_fail/T20289_A.hs
- testsuite/tests/typecheck/should_fail/T22645.stderr
- testsuite/tests/typecheck/should_fail/T22924a.stderr
- + testsuite/tests/typecheck/should_fail/T23731.hs
- + testsuite/tests/typecheck/should_fail/T23731.stderr
- + testsuite/tests/typecheck/should_fail/T23731b.hs
- + testsuite/tests/typecheck/should_fail/T23731b.stderr
- + testsuite/tests/typecheck/should_fail/T23731b_aux.hs
- + testsuite/tests/typecheck/should_fail/T25679.hs
- + testsuite/tests/typecheck/should_fail/T25679.stderr
- + testsuite/tests/typecheck/should_fail/T25949.hs
- + testsuite/tests/typecheck/should_fail/T25949.stderr
- + testsuite/tests/typecheck/should_fail/T25949_aux.hs
- + testsuite/tests/typecheck/should_fail/T26137.hs
- + testsuite/tests/typecheck/should_fail/T26137.stderr
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T6069.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T7857.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcCoercibleFail.stderr
- testsuite/tests/typecheck/should_fail/TcCoercibleFail3.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail140.stderr
- testsuite/tests/typecheck/should_fail/tcfail181.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55c4f2b41a36a96c1166721f906e09…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/55c4f2b41a36a96c1166721f906e09…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Refactor: merge HsMultilineString into HsString (#26860)
by Marge Bot (＠marge-bot) 02 Feb '26
by Marge Bot (＠marge-bot) 02 Feb '26
02 Feb '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ddf1434f by Vladislav Zavialov at 2026-02-01T19:38:52-05:00
Refactor: merge HsMultilineString into HsString (#26860)
Before this patch, HsLit defined two separate constructors to represent
single-line and multi-line strings:
data HsLit x
...
| HsString (XHsString x) FastString
| HsMultilineString (XHsMultilineString x) FastString
I found this to be an unnecessary complication and an obstacle to unifying
HsLit with HsTyLit. Now we use HsString for both kinds of literals.
One user-facing change here is `ppr (HsString st s)` behaving differently for
single-line strings containing newlines:
x = "first line \
\asdf\n\
\second line"
Previously, the literal was fed to `ftext` with its newlines, producing an
ill-formed SDoc. This issue is now addressed by using `split` for both
single-line and multi-line strings:
vcat $ map text $ split '\n' (unpackFS src)
See the parser/should_fail/T26860ppr test.
In addition (and unrelatedly to the main payload of this patch),
drop the unused pmPprHsLit helper.
- - - - -
14 changed files:
- compiler/GHC/Hs/Lit.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/String.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/Lit.hs
- + testsuite/tests/parser/should_fail/T26860ppr.hs
- + testsuite/tests/parser/should_fail/T26860ppr.stderr
- testsuite/tests/parser/should_fail/all.T
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Lit.hs
=====================================
@@ -45,7 +45,6 @@ import Language.Haskell.Syntax.Lit
type instance XHsChar (GhcPass _) = SourceText
type instance XHsCharPrim (GhcPass _) = SourceText
type instance XHsString (GhcPass _) = SourceText
-type instance XHsMultilineString (GhcPass _) = SourceText
type instance XHsStringPrim (GhcPass _) = SourceText
type instance XHsInt (GhcPass _) = NoExtField
type instance XHsIntPrim (GhcPass _) = SourceText
@@ -147,7 +146,6 @@ hsLitNeedsParens p = go
go (HsChar {}) = False
go (HsCharPrim {}) = False
go (HsString {}) = False
- go (HsMultilineString {}) = False
go (HsStringPrim {}) = False
go (HsInt _ x) = p > topPrec && il_neg x
go (HsFloatPrim {}) = False
@@ -177,7 +175,6 @@ convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit
convertLit (HsChar a x) = HsChar a x
convertLit (HsCharPrim a x) = HsCharPrim a x
convertLit (HsString a x) = HsString a x
-convertLit (HsMultilineString a x) = HsMultilineString a x
convertLit (HsStringPrim a x) = HsStringPrim a x
convertLit (HsInt a x) = HsInt a x
convertLit (HsIntPrim a x) = HsIntPrim a x
@@ -212,8 +209,7 @@ Equivalently it's True if
instance IsPass p => Outputable (HsLit (GhcPass p)) where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c)
- ppr (HsString st s) = pprWithSourceText st (pprHsString s)
- ppr (HsMultilineString st s) =
+ ppr (HsString st s) =
case st of
NoSourceText -> pprHsString s
SourceText src -> vcat $ map text $ split '\n' (unpackFS src)
@@ -248,36 +244,6 @@ instance Outputable OverLitVal where
ppr (HsFractional f) = ppr f
ppr (HsIsString st s) = pprWithSourceText st (pprHsString s)
--- | pmPprHsLit pretty prints literals and is used when pretty printing pattern
--- match warnings. All are printed the same (i.e., without hashes if they are
--- primitive and not wrapped in constructors if they are boxed). This happens
--- mainly for too reasons:
--- * We do not want to expose their internal representation
--- * The warnings become too messy
-pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc
-pmPprHsLit (HsChar _ c) = pprHsChar c
-pmPprHsLit (HsCharPrim _ c) = pprHsChar c
-pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s)
-pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s)
-pmPprHsLit (HsStringPrim _ s) = pprHsBytes s
-pmPprHsLit (HsInt _ i) = integer (il_value i)
-pmPprHsLit (HsIntPrim _ i) = integer i
-pmPprHsLit (HsWordPrim _ w) = integer w
-pmPprHsLit (HsInt8Prim _ i) = integer i
-pmPprHsLit (HsInt16Prim _ i) = integer i
-pmPprHsLit (HsInt32Prim _ i) = integer i
-pmPprHsLit (HsInt64Prim _ i) = integer i
-pmPprHsLit (HsWord8Prim _ w) = integer w
-pmPprHsLit (HsWord16Prim _ w) = integer w
-pmPprHsLit (HsWord32Prim _ w) = integer w
-pmPprHsLit (HsWord64Prim _ w) = integer w
-pmPprHsLit (HsFloatPrim _ f) = ppr f
-pmPprHsLit (HsDoublePrim _ d) = ppr d
-pmPprHsLit (XLit x) = case ghcPass @p of
- GhcTc -> case x of
- (HsInteger _ i _) -> integer i
- (HsRat f _) -> ppr f
-
negateOverLitVal :: OverLitVal -> OverLitVal
negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)
negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -75,7 +75,6 @@ hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type
hsLitType (HsChar _ _) = charTy
hsLitType (HsCharPrim _ _) = charPrimTy
hsLitType (HsString _ _) = stringTy
-hsLitType (HsMultilineString _ _) = stringTy
hsLitType (HsStringPrim _ _) = addrPrimTy
hsLitType (HsInt _ _) = intTy
hsLitType (HsIntPrim _ _) = intPrimTy
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -117,7 +117,6 @@ dsLit l = do
HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
- HsMultilineString _ str -> mkStringExprFS str
HsInt _ i -> return (mkIntExpr platform (il_value i))
XLit x -> case ghcPass @p of
GhcTc -> case x of
@@ -463,7 +462,6 @@ getSimpleIntegralLit (XLit (HsInteger _ i ty)) = Just (i, ty)
getSimpleIntegralLit HsChar{} = Nothing
getSimpleIntegralLit HsCharPrim{} = Nothing
getSimpleIntegralLit HsString{} = Nothing
-getSimpleIntegralLit HsMultilineString{} = Nothing
getSimpleIntegralLit HsStringPrim{} = Nothing
getSimpleIntegralLit (XLit (HsRat{})) = Nothing
getSimpleIntegralLit HsFloatPrim{} = Nothing
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -3077,7 +3077,6 @@ repLiteral lit
HsChar _ _ -> Just charLName
HsCharPrim _ _ -> Just charPrimLName
HsString _ _ -> Just stringLName
- HsMultilineString _ _ -> Just stringLName
_ -> Nothing
mk_integer :: Integer -> MetaM (HsLit GhcTc)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4131,7 +4131,7 @@ literal :: { Located (HsLit GhcPs) }
: CHAR { sL1 $1 $ HsChar (getCHARs $1) $ getCHAR $1 }
| STRING { sL1 $1 $ HsString (getSTRINGs $1)
$ getSTRING $1 }
- | STRING_MULTI { sL1 $1 $ HsMultilineString (getSTRINGMULTIs $1)
+ | STRING_MULTI { sL1 $1 $ HsString (getSTRINGMULTIs $1)
$ getSTRINGMULTI $1 }
| PRIMINTEGER { sL1 $1 $ HsIntPrim (getPRIMINTEGERs $1)
$ getPRIMINTEGER $1 }
=====================================
compiler/GHC/Parser/String.hs
=====================================
@@ -392,9 +392,9 @@ proposal: https://github.com/ghc-proposals/ghc-proposals/pull/569
Multiline string literals are syntax sugar for normal string literals,
with an extra post processing step. This all happens in the Lexer; that
-is, HsMultilineString will contain the post-processed string. This matches
-the same behavior as HsString, which contains the normalized string
-(see Note [Literal source text]).
+is, the multi-line HsString will contain the post-processed string.
+This matches the behavior of the single-line HsString, which contains
+the normalized string too (see Note [Literal source text]).
The canonical steps for post processing a multiline string are:
1. Collapse string gaps
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -352,18 +352,13 @@ rnExpr (HsOverLabel src v)
hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
HsTyLit noExtField (HsStrTy NoSourceText v)
-rnExpr (HsLit x lit) | Just (src, s) <- stringLike lit
+rnExpr (HsLit x lit) | HsString src s <- lit
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
; return (HsLit x (convertLit lit), emptyFVs) } }
- where
- stringLike = \case
- HsString src s -> Just (src, s)
- HsMultilineString src s -> Just (src, s)
- _ -> Nothing
rnExpr (HsLit x lit)
= do { rnLit lit
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -4786,7 +4786,6 @@ promotionErr name err
tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn)
tyLitFromLit (HsString x str) = Just (HsStrTy x str)
-tyLitFromLit (HsMultilineString x str) = Just (HsStrTy x str)
tyLitFromLit (HsChar x char) = Just (HsCharTy x char)
tyLitFromLit _ = Nothing
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -609,7 +609,6 @@ type family XXParStmtBlock x x'
type family XHsChar x
type family XHsCharPrim x
type family XHsString x
-type family XHsMultilineString x
type family XHsStringPrim x
type family XHsInt x
type family XHsIntPrim x
=====================================
compiler/Language/Haskell/Syntax/Lit.hs
=====================================
@@ -47,8 +47,6 @@ data HsLit x
-- ^ Unboxed character
| HsString (XHsString x) {- SourceText -} FastString
-- ^ String
- | HsMultilineString (XHsMultilineString x) {- SourceText -} FastString
- -- ^ String
| HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString
-- ^ Packed bytes
| HsInt (XHsInt x) IntegralLit
=====================================
testsuite/tests/parser/should_fail/T26860ppr.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE NoOverloadedStrings #-}
+
+module T26860ppr where
+
+-- Test that the error message containing the string literal is well-formatted.
+-- See also: parser/should_fail/MultilineStringsError
+x :: Int
+x = "first line \
+ \asdf\n\
+ \second line"
+
=====================================
testsuite/tests/parser/should_fail/T26860ppr.stderr
=====================================
@@ -0,0 +1,13 @@
+T26860ppr.hs:8:5: error: [GHC-83865]
+ • Couldn't match type ‘[Char]’ with ‘Int’
+ Expected: Int
+ Actual: String
+ • In the expression:
+ "first line \
+ \asdf\n\
+ \second line"
+ In an equation for ‘x’:
+ x = "first line \
+ \asdf\n\
+ \second line"
+
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -244,3 +244,4 @@ test('T25530', normal, compile_fail, [''])
test('T26418', normal, compile_fail, [''])
test('T12488c', normal, compile_fail, [''])
test('T12488d', normal, compile_fail, [''])
+test('T26860ppr', normal, compile_fail, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4794,7 +4794,6 @@ hsLit2String lit =
HsChar src v -> toSourceTextWithSuffix src v ""
HsCharPrim src p -> toSourceTextWithSuffix src p ""
HsString src v -> toSourceTextWithSuffix src v ""
- HsMultilineString src v -> toSourceTextWithSuffix src v ""
HsStringPrim src v -> toSourceTextWithSuffix src v ""
HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v ""
HsIntPrim src v -> toSourceTextWithSuffix src v ""
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ddf1434ff9bb08cfef3c93f23de6b83…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ddf1434ff9bb08cfef3c93f23de6b83…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Include current phase in the range for rule/unfoldings
by Marge Bot (＠marge-bot) 02 Feb '26
by Marge Bot (＠marge-bot) 02 Feb '26
02 Feb '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
269c4087 by Simon Peyton Jones at 2026-02-01T19:38:10-05:00
Include current phase in the range for rule/unfoldings
This MR fixes a bad loop in the compiler: #26826.
The fix is to add (WAR2) to
Note [What is active in the RHS of a RULE or unfolding?]
in GHC.Core.Opt.Simplify.Utils
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Types/InlinePragma.hs
- + testsuite/tests/simplCore/should_compile/T26826.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1417,16 +1417,17 @@ then we *must* choose f to be a loop breaker. Example: see Note
That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.
Wrinkles:
-* We only consider /active/ rules. See Note [Finding rule RHS free vars]
+(RLB1) We only consider /active/ rules.
+ This is important: see Note [Finding rule RHS free vars]
-* We need only consider free vars that are also binders in this Rec
+(RLB2) We need only consider free vars that are also binders in this Rec
group. See also Note [Finding rule RHS free vars]
-* We only consider variables free in the *RHS* of the rule, in
+(RLB3) We only consider variables free in the *RHS* of the rule, in
contrast to the way we build the Rec group in the first place (Note
[Rule dependency info])
-* Why "transitive sequence of rules"? Because active rules apply
+(RLB4) Why "transitive sequence of rules"? Because active rules apply
unconditionally, without checking loop-breaker-ness.
See Note [Loop breaker dependencies].
@@ -1854,10 +1855,13 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds
-------- active_rule_fvs ------------
+ -- See Note [Rules and loop breakers]
active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds
add_active_rule (rule, _, rhs_uds) fvs
- | is_active (ruleActivation rule)
+ | is_active (ruleActivation rule) -- See (RLB1)
= udFreeVars bndr_set rhs_uds `unionVarSet` fvs
+ -- Only consider the `rhs_uss`, not the LHS ones; see (RLB3)
+ -- udFreeVars restricts to bndr_set; see (RLB2)
| otherwise
= fvs
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Core.Opt.Simplify.Env (
-- * Environments
SimplEnv(..), pprSimplEnv, -- Temp not abstract
- SimplPhase(..), isActive,
+ SimplPhase(..), isActive, simplStartPhase, simplEndPhase,
seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,
seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,
seOptCoercionOpts, sePhase, sePlatform, sePreInline,
@@ -293,7 +293,9 @@ data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad
-- | See Note [SimplPhase]
data SimplPhase
-- | A simplifier phase: InitialPhase, Phase 2, Phase 1, Phase 0, FinalPhase
+ -- NB: (SimplPhase p) is equivalent to (SimplPhaseRange p p)
= SimplPhase CompilerPhase
+
-- | Simplifying the RHS of a rule or of a stable unfolding: the range of
-- phases of the activation of the rule/stable unfolding.
--
@@ -302,13 +304,18 @@ data SimplPhase
--
-- See Note [What is active in the RHS of a RULE or unfolding?]
-- in GHC.Core.Opt.Simplify.Utils.
- | SimplPhaseRange
- { simplStartPhase :: CompilerPhase
- , simplEndPhase :: CompilerPhase
- }
+ | SimplPhaseRange CompilerPhase CompilerPhase
deriving Eq
+simplStartPhase :: SimplPhase -> CompilerPhase
+simplStartPhase (SimplPhase p) = p
+simplStartPhase (SimplPhaseRange p _) = p
+
+simplEndPhase :: SimplPhase -> CompilerPhase
+simplEndPhase (SimplPhase p) = p
+simplEndPhase (SimplPhaseRange _ p) = p
+
instance Outputable SimplPhase where
ppr (SimplPhase p) = ppr p
ppr (SimplPhaseRange s e) = brackets $ ppr s <> ellipsis <> ppr e
@@ -322,12 +329,13 @@ instance Outputable SimplPhase where
--
-- See Note [SimplPhase].
isActive :: SimplPhase -> ActivationGhc -> Bool
-isActive (SimplPhase p) act = isActiveInPhase p act
-isActive (SimplPhaseRange start end) act =
- -- To check whether the activation is active throughout the whole phase range,
- -- it's sufficient to check the endpoints of the phase range, because an
- -- activation can never have gaps (all activations are phase intervals).
- isActiveInPhase start act && isActiveInPhase end act
+isActive (SimplPhase p) act
+ = isActiveInPhase p act
+isActive (SimplPhaseRange start end) act
+ = -- To check whether the activation is active throughout the whole phase range,
+ -- it's sufficient to check the endpoints of the phase range, because an
+ -- activation can never have gaps (all activations are phase intervals).
+ isActiveInPhase start act && isActiveInPhase end act
{- Note [SimplPhase]
~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1099,7 +1099,7 @@ updModeForStableUnfoldings :: ActivationGhc -> SimplMode -> SimplMode
-- See Note [Simplifying inside stable unfoldings]
updModeForStableUnfoldings unf_act current_mode
= current_mode
- { sm_phase = phaseFromActivation (sm_phase current_mode) unf_act
+ { sm_phase = phaseForRuleOrUnf (sm_phase current_mode) unf_act
-- See Note [What is active in the RHS of a RULE or unfolding?]
, sm_eta_expand = False
-- See Note [Eta expansion in stable unfoldings and rules]
@@ -1123,27 +1123,32 @@ updModeForRuleRHS :: ActivationGhc -> SimplMode -> SimplMode
updModeForRuleRHS rule_act current_mode =
current_mode
-- See Note [What is active in the RHS of a RULE or unfolding?]
- { sm_phase = phaseFromActivation (sm_phase current_mode) rule_act
+ { sm_phase = phaseForRuleOrUnf (sm_phase current_mode) rule_act
, sm_eta_expand = False
-- See Note [Eta expansion in stable unfoldings and rules]
}
--- | Compute the phase range to set the 'SimplMode' to
--- when simplifying the RHS of a rule or of a stable unfolding.
+-- | `phaseForRuleOrUnf` computes the phase range to use when
+-- simplifying the RHS of a rule or of a stable unfolding.
--
+-- This subtle function implements the careful plan described in
-- See Note [What is active in the RHS of a RULE or unfolding?]
-phaseFromActivation
- :: SimplPhase -- ^ the current simplifier phase
+phaseForRuleOrUnf
+ :: SimplPhase -- ^ the current simplifier phase
-> ActivationGhc -- ^ the activation of the RULE or stable unfolding
-> SimplPhase
-phaseFromActivation p act
- | isNeverActive act
- = p
+phaseForRuleOrUnf current_phase act
+ | start == end
+ = SimplPhase start
| otherwise
- = SimplPhaseRange act_start act_end
+ = SimplPhaseRange start end
where
- act_start = beginPhase act
- act_end = endPhase act
+ start, end :: CompilerPhase
+ start = beginPhase act `earliestPhase` simplStartPhase current_phase
+ end = endPhase act `latestPhase` simplEndPhase current_phase
+ -- The beginPhase/endPhase implements (WAR1)
+ -- The simplStartPhase/simplEndPhase implements (WAR2)
+ -- of Note [What is active in the RHS of a RULE or unfolding?]
{- Note [Simplifying rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1275,26 +1280,47 @@ Our carefully crafted plan is as follows:
-------------------------------------------------------------
When simplifying the RHS of a RULE R with activation range A,
- fire only other rules R' that are active throughout all of A.
+ fire only other rules R' that are active
+ (WAR1) throughout all of A
+ (WAR2) in the current phase
+ See `phaseForRuleOrUnf`.
-------------------------------------------------------------
-Reason: R might fire in any phase in A. Then R' can fire only if R' is active
-in that phase. If not, it's not safe to unconditionally fire R' in the RHS of R.
+Reasons for (WAR1):
+ * R might fire in any phase in A. Then R' can fire only if R' is active in that
+ phase. If not, it's not safe to unconditionally fire R' in the RHS of R.
+
+Reasons for (WAR2):
+ * If A is empty (e.g. a NOINLINE pragma, so the unfolding is never active)
+ we don't want to vacuously satisfy (WAR1) and thereby fire /all/ RULES in
+ the unfolding. Two RULES may be crafted so that they are never simultaneously
+ active, and will loop if they are.
+
+ * Suppose we are in Phase 2, looking at a stable unfolding for INLINE [1].
+ If we just do (WAR1) we will fire RULES active in phase 1; but the
+ occurrence analyser ignores any rules not active in the current phase.
+ So occ-anal may fail to detect a loop breaker; see #26826 for details.
+ See Note [Rules and loop breakers] in GHC.Core.Opt.OccurAnal.
+
+ * Aesthetically, this means that when the simplifer is in phase N, it
+ won't switch to a phase-range that doesn't include N (e.g. might be later
+ than N). This is what caused #26826.
+
+ * Also note that as the current phase advances, it'll eventually be inside
+ the range specified by (WAR1), and hence will not widen the range.
+ Unless the latter is empty, of course.
This plan is implemented by:
- 1. Setting the simplifier phase to the range of phases
- corresponding to the start/end phases of the rule's activation.
+ 1. Setting the simplifier phase to the /range/ of phases
+ corresponding to the start/end phases of the rule's activation, implementing
+ (WAR1) and (WAR2). This happens in `phaseForRuleOrUnf`.
+
2. When checking whether another rule is active, we use the function
isActive :: SimplPhase -> Activation -> Bool
from GHC.Core.Opt.Simplify.Env, which checks whether the other rule is
active throughout the whole range of phases.
-However, if the rule whose RHS we are simplifying is never active, instead of
-setting the phase range to an empty interval, we keep the current simplifier
-phase. This special case avoids firing ALL rules in the RHS of a never-active
-rule.
-
You might wonder about a situation such as the following:
module M1 where
@@ -1307,6 +1333,7 @@ It looks tempting to use "r1" when simplifying the RHS of "r2", yet we
**must not** do so: for any module M that imports M1, we are going to start
simplification in M starting at InitialPhase, and we will see the
fully simplified rules RHSs imported from M1.
+
Conclusion: stick to the plan.
Note [Simplifying inside stable unfoldings]
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -914,9 +914,9 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
where
srcTxt = SourceText $ fsLit "{-# INLINE"
-- See Note [Wrapper activation]
- wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules
- earliest_inline_phase = beginPhase fn_act `laterPhase` nextPhase InitialPhase
- -- laterPhase (nextPhase InitialPhase) is a temporary hack
+ wrapper_phase = foldr (latestPhase . get_rule_phase) earliest_inline_phase rules
+ earliest_inline_phase = beginPhase fn_act `latestPhase` nextPhase InitialPhase
+ -- latestPhase (nextPhase InitialPhase) is a temporary hack
-- to inline no earlier than phase 2. I got regressions in
-- 'mate', due to changes in full laziness due to Note [Case
-- MFEs], when I did earlier inlining.
=====================================
compiler/GHC/Types/InlinePragma.hs
=====================================
@@ -104,9 +104,8 @@ module GHC.Types.InlinePragma
, endPhase
-- *** Queries
, isActiveInPhase
- , laterPhase
- , laterThanPhase
- , nextPhase
+ , latestPhase, earliestPhase
+ , laterThanPhase, nextPhase
) where
import GHC.Prelude
@@ -422,13 +421,21 @@ nextPhase (Phase 0) = FinalPhase
nextPhase (Phase n) = Phase (n-1)
nextPhase FinalPhase = FinalPhase
-laterPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
--- ^ Returns the later of two phases
-laterPhase (Phase n1) (Phase n2) = Phase (n1 `min` n2)
-laterPhase InitialPhase p2 = p2
-laterPhase FinalPhase _ = FinalPhase
-laterPhase p1 InitialPhase = p1
-laterPhase _ FinalPhase = FinalPhase
+earliestPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
+-- ^ Returns the earliest of two phases
+earliestPhase (Phase n1) (Phase n2) = Phase (n1 `max` n2)
+earliestPhase InitialPhase _ = InitialPhase
+earliestPhase FinalPhase p2 = p2
+earliestPhase _ InitialPhase = InitialPhase
+earliestPhase p1 FinalPhase = p1
+
+latestPhase :: CompilerPhase -> CompilerPhase -> CompilerPhase
+-- ^ Returns the latest of two phases
+latestPhase (Phase n1) (Phase n2) = Phase (n1 `min` n2)
+latestPhase InitialPhase p2 = p2
+latestPhase FinalPhase _ = FinalPhase
+latestPhase p1 InitialPhase = p1
+latestPhase _ FinalPhase = FinalPhase
-- | @p1 `laterThanOrEqualPhase` p2@ computes whether @p1@ happens (strictly)
-- after @p2@.
=====================================
testsuite/tests/simplCore/should_compile/T26826.hs
=====================================
@@ -0,0 +1,86 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeAbstractions #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeData #-}
+
+module T26826 where
+
+import Data.Kind (Type)
+
+type data AstSpan =
+ FullSpan | PrimalStepSpan AstSpan | PlainSpan
+
+data SAstSpan (s :: AstSpan) where
+ SFullSpan :: SAstSpan FullSpan
+ SPrimalStepSpan :: SAstSpan s -> SAstSpan (PrimalStepSpan s)
+ SPlainSpan :: SAstSpan PlainSpan
+
+class KnownSpan (s :: AstSpan) where
+ knownSpan :: SAstSpan s
+
+instance KnownSpan FullSpan where
+ knownSpan = SFullSpan
+
+instance KnownSpan s => KnownSpan (PrimalStepSpan s) where
+ knownSpan = SPrimalStepSpan (knownSpan @s)
+
+instance KnownSpan PlainSpan where
+ knownSpan = SPlainSpan
+
+class ADReady target where
+ ttlet :: target a -> (target a -> target b) -> target b
+ ttletPrimal :: target a -> (target a -> target b) -> target b
+ ttletPlain :: target a -> (target a -> target b) -> target b
+ tplainPart :: target a -> target a
+ tfromPlain :: target a -> target a
+ tprimalPart :: target a -> target a
+ tfromPrimal :: target a -> target a
+
+type SpanTargetFam target (s :: AstSpan) (y :: Type) = target y
+
+type AstEnv target = ()
+
+data AstTensor (s :: AstSpan) (y :: Type) where
+ AstLet
+ :: forall a b s1 s2.
+ KnownSpan s1
+ => AstTensor s1 a
+ -> AstTensor s2 b
+ -> AstTensor s2 b
+
+ AstPrimalPart :: KnownSpan s' => AstTensor s' a -> AstTensor (PrimalStepSpan s') a
+ AstFromPrimal :: AstTensor (PrimalStepSpan s') a -> AstTensor s' a
+ AstPlainPart :: KnownSpan s' => AstTensor s' a -> AstTensor PlainSpan a
+ AstFromPlain :: AstTensor PlainSpan a -> AstTensor s' a
+
+interpretAst
+ :: forall target s y. (ADReady target, KnownSpan s)
+ => AstEnv target -> AstTensor s y
+ -> SpanTargetFam target s y
+{-# INLINE [1] interpretAst #-}
+interpretAst !env
+ = \case
+ AstLet @_ @_ @s1 @s2 u v ->
+ case knownSpan @s1 of
+ SFullSpan ->
+ ttlet (interpretAst env u)
+ (\_w -> interpretAst env v)
+ SPrimalStepSpan _ ->
+ ttletPrimal (interpretAst env u)
+ (\_w -> interpretAst env v)
+ SPlainSpan ->
+ ttletPlain (interpretAst env u)
+ (\_w -> interpretAst env v)
+ AstPrimalPart a ->
+ tprimalPart (interpretAst env a)
+ AstFromPrimal a ->
+ tfromPrimal (interpretAst env a)
+ AstPlainPart a ->
+ tplainPart (interpretAst env a)
+ AstFromPlain a ->
+ tfromPlain (interpretAst env a)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -578,4 +578,6 @@ test('T26615', [grep_errmsg(r'fEqList')], multimod_compile, ['T26615', '-O -fsp
# T26722: there should be no reboxing in $wg
test('T26722', [grep_errmsg(r'SPEC')], compile, ['-O -dno-typeable-binds'])
+
test('T26805', [grep_errmsg(r'fromInteger')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques'])
+test('T26826', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/269c4087979ff9d675cd1a590761572…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/269c4087979ff9d675cd1a590761572…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
7594dac9 by Simon Peyton Jones at 2026-02-01T23:15:36+00:00
More wibbles
* `bindAuxiliaryTyVars` in Specialise
* `trivial_expr_fold` needs to accept big coercions in CoreToStg
because the binder-swap can duplicate big coercions (boo)
Plus renaming in Specialise
- - - - -
7 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -489,6 +489,15 @@ Wrinkles:
(which is always substituted) with the tyvar-replete-with-unfolding, rather
than merely extending the in-scope set as we do for Ids.
+So: (TCL1) + (TCL2) =
+ EITHER `a` has an unfolding at its binding site,
+ and that unfolding is replicated at every occurrence site
+ OR it doesn't and the occurrences don't either.
+
+
+OR we could insist that tyvar bindings always have an unfolding, and use
+a beta-redex if not.
+
Note [Core top-level string literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As an exception to the usual rule that top-level binders must be lifted,
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -854,7 +854,8 @@ doFloatFromRhs env lvl rec strict_bind tvs (SimplFloats { sfLetFloats = LetFloat
cant_float_types
| not (null tvs), any isTyCoVar float_bndrs
= (pprTraceWhen (any isId float_bndrs)
- "WARNING-TyCo: skipping abstractFloats" (ppr fs)) $
+ "WARNING-TyCo: skipping abstractFloats"
+ (text "binders" <+> ppr (fmap bindersOf fs)))
True
| otherwise
= False
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable
, mkCast, exprType, exprIsHNF
, stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
+import GHC.Core.TyCo.FVs( someTyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.Simplify.Env ( SimplPhase(..), isActive )
@@ -658,17 +659,17 @@ specProgram guts@(ModGuts { mg_module = this_mod
, se_rules = rule_env
, se_dflags = dflags }
- go [] = return ([], emptyUDs)
+ go [] = return (nilOL, emptyUDs)
go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->
go binds
- return (bind' ++ binds', uds')
+ return (bind' `appOL` binds', uds')
-- Specialise the bindings of this module
; (binds', uds) <- runSpecM (go binds)
; (spec_rules, spec_binds) <- specImports top_env uds
- ; return (guts { mg_binds = spec_binds ++ binds'
+ ; return (guts { mg_binds = spec_binds ++ fromOL binds'
, mg_rules = spec_rules ++ local_rules }) }
{-
@@ -677,7 +678,7 @@ Note [Wrap bindings returned by specImports]
'specImports' returns a set of specialized bindings. However, these are lacking
necessary floated dictionary bindings, which are returned by
UsageDetails(ud_binds). These dictionaries need to be brought into scope with
-'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,
+'wrapFloatBinds' before the bindings returned by 'specImports' can be used. See,
for instance, the 'specImports' call in 'specProgram'.
@@ -763,7 +764,7 @@ specImports :: SpecEnv
specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
| not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env)
-- See Note [Disabling cross-module specialisation]
- = return ([], wrapDictBinds dict_binds [])
+ = return ([], wrapFloatBinds dict_binds [])
| otherwise
= do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds
@@ -771,7 +772,7 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
-- Make a Rec: see Note [Glom the bindings if imported functions are specialised]
--
- -- wrapDictBinds: don't forget to wrap the specialized bindings with
+ -- wrapFloatBinds: don't forget to wrap the specialized bindings with
-- bindings for the needed dictionaries.
-- See Note [Wrap bindings returned by specImports]
--
@@ -780,9 +781,9 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules
local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
final_binds
- | null spec_binds = wrapDictBinds dict_binds []
+ | null spec_binds = wrapFloatBinds dict_binds []
| otherwise = glomValBinds $
- wrapDictBinds dict_binds $
+ wrapFloatBinds dict_binds $
map (mapBindBndrs (addRulesToId local_rule_base)) $
spec_binds
@@ -791,10 +792,10 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
-- | Specialise a set of calls to imported bindings
spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope
- ---In-scope set includes the FloatedDictBinds
+ ---In-scope set includes the FloatBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
- -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
+ -> FloatBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallDetails -- Calls for imported things
-> CoreM ( SpecEnv -- Env contains the new rules
@@ -824,10 +825,10 @@ spec_imports env callers dict_binds calls
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope
- ---In-scope set includes the FloatedDictBinds
+ ---In-scope set includes the FloatBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
- -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
+ -> FloatBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallInfoSet -- Imported function and calls for it
-> CoreM ( SpecEnv
@@ -889,7 +890,7 @@ spec_import env callers dict_binds cis@(CIS fn _)
(dict_binds `thenFDBs` dict_binds1)
new_calls
- ; let final_binds = wrapDictBinds dict_binds1 $
+ ; let final_binds = wrapFloatBinds dict_binds1 $
spec_binds2 ++ spec_binds1
; return (env, rules2 ++ rules1, final_binds) }
@@ -1161,6 +1162,20 @@ And if the call is to the same type, one specialisation is enough.
Avoiding this recursive specialisation loop is one reason for the
'callers' stack passed to specImports and specImport.
+Note [Specialisation and type-variable bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC allows let-bindings for type variables e.g.
+ a::Type = Type (Maybe b)
+We need to account for these when specialising:
+
+(STV1) The ci_fvs field of a CallInfo includes free TyVars
+
+(STV2) When dumping calls, in `deleteCallsMentioning`, we ignore
+ free tyvars when Opt_PolymorphicSpecialisation is on.
+ See (MP1) in Note [Specialising polymorphic dictionaries]
+
+(STV3) A FloatBind can be a type binding; see `bindAuxiliaryTyVars`
+
************************************************************************
* *
@@ -1287,8 +1302,8 @@ specLam env bndrs body
= specExpr env body
| otherwise
= do { (body', uds) <- specExpr env body
- ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds
- ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }
+ ; let (free_uds, dumped_dbs) = dumpUDs env bndrs uds
+ ; return (mkLams bndrs (wrapFloatBindsE dumped_dbs body'), free_uds) }
--------------
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
@@ -1313,8 +1328,8 @@ specCase env scrut case_bndr alts
(env_alt, case_bndr') = substBndr env case_bndr
spec_alt (Alt con args rhs)
= do { (rhs', uds) <- specExpr env_rhs rhs
- ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
- ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }
+ ; let (free_uds, dumped_dbs) = dumpUDs env (case_bndr' : args') uds
+ ; return (Alt con args' (wrapFloatBindsE dumped_dbs rhs'), free_uds) }
where
(env_rhs, args') = substBndrs env_alt args
@@ -1420,8 +1435,8 @@ End of Historical Note
************************************************************************
-}
-bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
-bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })
+bringFloatedDictsIntoScope :: SpecEnv -> FloatBinds -> SpecEnv
+bringFloatedDictsIntoScope env (FDB { fbs_bndrs = dx_bndrs })
= -- pprTrace "brought into scope" (ppr dx_bndrs) $
env {se_subst=subst'}
where
@@ -1432,7 +1447,7 @@ specBind :: TopLevelFlag
-- top level binders in scope
-> InBind
-> (SpecEnv -> SpecM (body, UsageDetails)) -- Process the body
- -> SpecM ( [OutBind] -- New bindings
+ -> SpecM ( OrdList OutBind -- New bindings
, body -- Body
, UsageDetails) -- And info to pass upstream
-- Returned UsageDetails:
@@ -1448,13 +1463,13 @@ specBind top_lvl env (NonRec tv (Type rhs_ty)) do_body
; let rhs_ty' = substTy env rhs_ty
bind' = NonRec tv' (Type rhs_ty')
- (free_uds, dump_dbs, float_all) = dumpBindUDs True [tv'] body_uds
- final_binds = mkDB bind' : fromOL dump_dbs
+ (free_uds, dump_dbs, float_all) = dumpBindUDs env True [tv'] body_uds
+ final_binds = unitOL (mkDB bind') `appOL` dump_dbs
; if float_all then
- return ([], body', free_uds `snocDictBinds` final_binds)
+ return (nilOL, body', free_uds `snocFloatBinds` final_binds)
else
- return (map db_bind final_binds, body', free_uds) }
+ return (fmap fb_bind final_binds, body', free_uds) }
specBind top_lvl env (NonRec fn rhs) do_body
= do { (rhs', rhs_uds) <- specExpr env rhs
@@ -1486,31 +1501,30 @@ specBind top_lvl env (NonRec fn rhs) do_body
; let can_float_this_one = exprIsTopLevelBindable rhs (idType fn)
-- exprIsTopLevelBindable: see Note [Care with unlifted bindings]
- (free_uds, dump_dbs, float_all) = dumpBindUDs can_float_this_one [fn4] body_uds1
+ (free_uds, dump_dbs, float_all) = dumpBindUDs env can_float_this_one [fn4] body_uds1
all_free_uds = free_uds `thenUDs` rhs_uds
pairs = spec_defns ++ [(fn4, rhs')]
-- fn4 mentions the spec_defns in its rules,
-- so put the latter first
- final_binds :: [DictBind]
+ final_binds :: OrdList FloatBind
-- See Note [From non-recursive to recursive]
final_binds | not (isNilOL dump_dbs)
, not (null spec_defns)
- = [recWithDumpedDicts pairs dump_dbs]
+ = unitOL (recWithDumpedDicts pairs dump_dbs)
| otherwise
- = [mkDB $ NonRec b r | (b,r) <- pairs]
- ++ fromOL dump_dbs
-
+ = toOL [mkDB $ NonRec b r | (b,r) <- pairs]
+ `appOL` dump_dbs
; if float_all then
-- Rather than discard the calls mentioning the bound variables
-- we float this (dictionary) binding along with the others
- return ([], body', all_free_uds `snocDictBinds` final_binds)
+ return (nilOL, body', all_free_uds `snocFloatBinds` final_binds)
else
-- No call in final_uds mentions bound variables,
-- so we can just leave the binding here
- return (map db_bind final_binds, body', all_free_uds) }
+ return (fmap fb_bind final_binds, body', all_free_uds) }
specBind top_lvl env (Rec pairs) do_body
@@ -1538,14 +1552,14 @@ specBind top_lvl env (Rec pairs) do_body
<- specDefns rec_env uds2 (bndrs2 `zip` rhss)
; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) }
- ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs True bndrs1 uds3
+ ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs env True bndrs1 uds3
final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')
dumped_dbs
; if float_all then
- return ([], body', final_uds `snocDictBind` final_bind)
+ return (nilOL, body', final_uds `snocFloatBind` final_bind)
else
- return ([db_bind final_bind], body', final_uds) }
+ return (unitOL (fb_bind final_bind), body', final_uds) }
---------------------------
@@ -1700,21 +1714,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
already_covered = alreadyCovered env' rule_bndrs fn
rule_lhs_args is_active all_rules
--- ; pprTrace "spec_call" (vcat
--- [ text "fun: " <+> ppr fn
--- , text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "already_covered:" <+> ppr already_covered
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) rule_bndrs))
--- , text "rule_lhs_args:" <+> ppr rule_lhs_args
--- , text "spec_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) spec_bndrs))
--- , text "dx_binds:" <+> ppr dx_binds
--- , text "spec_args: " <+> ppr spec_args
--- , text "rhs_bndrs" <+> ppr (sep (map (pprBndr LambdaBind) rhs_bndrs))
--- , text "rhs_body" <+> ppr rhs_body
--- , text "subst'" <+> ppr subst'
--- ]) $ return ()
+-- ; pprTrace "spec_call" (vcat
+-- [ text "fun: " <+> ppr fn
+-- , text "call info: " <+> ppr _ci
+-- , text "useful: " <+> ppr useful
+-- , text "already_covered:" <+> ppr already_covered
+-- , text "useful: " <+> ppr useful
+-- , text "rule_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) rule_bndrs))
+-- , text "rule_lhs_args:" <+> ppr rule_lhs_args
+-- , text "spec_bndrs:" <+> ppr (sep (map (pprBndr LambdaBind) spec_bndrs))
+-- , text "dx_binds:" <+> ppr dx_binds
+-- , text "spec_args: " <+> ppr spec_args
+-- , text "rhs_bndrs" <+> ppr (sep (map (pprBndr LambdaBind) rhs_bndrs))
+-- , text "rhs_body" <+> ppr rhs_body
+-- , text "subst'" <+> ppr subst'
+-- ]) $ return ()
; if not useful -- No useful specialisation
@@ -1731,12 +1745,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- Make the RHS of the specialised function
; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'
- (rhs_uds2, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs $
- dx_binds `consDictBinds` rhs_uds
+ (rhs_uds2, inner_dumped_dbs) = dumpUDs env spec_rhs_bndrs $
+ dx_binds `consFloatBinds` rhs_uds
-- dx_binds comes from the arguments to the call,
-- and so can mention poly_qvars but no other local binders
spec_rhs = mkLams spec_rhs_bndrs $
- wrapDictBindsE inner_dumped_dbs rhs_body'
+ wrapFloatBindsE inner_dumped_dbs rhs_body'
rule_rhs_args = spec_bndrs
-- Maybe add a void arg to the specialised function,
@@ -1757,7 +1771,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- The wrap_unf_body applies the original unfolding to the specialised
-- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
simpl_opts = initSimpleOpts dflags
- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ wrap_unf_body body = wrapFloatBindsE dx_binds $
+ body `mkApps` spec_args
spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body
rule_lhs_args fn_unf
@@ -2529,10 +2544,11 @@ instance Outputable SpecArg where
ppr UnspecType = text "UnspecType"
ppr UnspecArg = text "UnspecArg"
-specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV
--- Find the free vars of the SpecArgs that are not already in scope
-specArgsFVs interesting args
- = filterFV interesting $
+specArgsFVs :: [SpecArg] -> VarSet
+-- Find the free vars of the SpecArgs
+specArgsFVs args
+ = fvVarSet $
+ filterFV isLocalVar $ -- Including TyVars
foldr (unionFV . get) emptyFV args
where
get :: SpecArg -> FV
@@ -2607,15 +2623,15 @@ specHeader
-- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`
, [OutBndr] -- spec_bndrs: Binders for $sf, and args for the RHS
-- of the RULE. Subset of rule_bndrs.
- , [DictBind] -- dx_binds: Auxiliary dictionary bindings
+ , OrdList FloatBind -- dx_binds: Auxiliary dictionary bindings
, [OutExpr] -- spec_args: Specialised arguments for unfolding
-- Same length as "Args for LHS of rule"
)
-- If we run out of binders, stop immediately
-- See Note [Specialisation Must Preserve Sharing]
-specHeader subst [] _ = pure (False, subst, [], [], [], [], [])
-specHeader subst _ [] = pure (False, subst, [], [], [], [], [])
+specHeader subst [] _ = pure (False, subst, [], [], [], nilOL, [])
+specHeader subst _ [] = pure (False, subst, [], [], [], nilOL, [])
-- We want to specialise on type 'T1', and so we must construct a substitution
-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
@@ -2671,20 +2687,23 @@ specHeader subst (bndr:bndrs) (_ : args)
-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
-- the nitty-gritty), as a LHS rule and unfolding details.
specHeader subst (bndr:bndrs) (SpecDict dict_arg : args)
- = do { -- Make up a fresh binder to use in the RULE
+ = do { let (tv_bndrs, tv_binds) = bindAuxiliaryTyVars subst dict_arg
+ subst1 = subst `Core.extendSubstInScopeSet` tv_bndrs
+
+ -- Make up a fresh binder to use in the RULE
-- It might turn into a dict binding (via bindAuxiliaryDict) which we
-- then float, so we use cloneIdBndr to get a completely fresh binder
- u <- getUniqueM
- ; let (subst1, bndr') = Core.cloneBndr subst u (zapIdOccInfo bndr)
+ ; u <- getUniqueM
+ ; let (subst2, bndr') = Core.cloneBndr subst1 u (zapIdOccInfo bndr)
-- zapIdOccInfo: see Note [Zap occ info in rule binders]
-- Extend the substitution to map bndr :-> dict_arg, for use in the RHS
- ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg
+ ; let (subst3, dx1, spec_dict) = bindAuxiliaryDict subst2 bndr bndr' dict_arg
- ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args
+ ; (_, subst4, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst3 bndrs args
- ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx }
- ; pure ( True, subst3 -- Ha! A useful specialisation!
+ ; let dx' = tv_binds `appOL` dx1 `appOL` dx
+ ; pure ( True, subst4 -- Ha! A useful specialisation!
, bndr' : rule_bs, Var bndr' : rule_es
, spec_bs, dx', spec_dict : spec_args ) }
@@ -2713,13 +2732,46 @@ specHeader subst (bndr:bndrs) (UnspecArg : args)
, bndrs ++ spec_bs, dx, dummy_arg : spec_args ) }
+bindAuxiliaryTyVars :: Subst -> CoreExpr -> (TyVarSet, OrdList FloatBind)
+bindAuxiliaryTyVars subst dict_arg
+ = go emptyVarSet need_bind_tvs
+ where
+ go _ []
+ = (emptyVarSet, nilOL)
+ go tv_bndrs (tv:tvs)
+ | tv `elemVarSet` tv_bndrs
+ = go tv_bndrs tvs
+ | Just unf <- tyVarUnfolding_maybe tv
+ , (child_bndrs, child_binds) <- go tv_bndrs (someTyCoVarsOfTypeList needs_binding unf)
+ , let tv_bndrs1 = child_bndrs `extendVarSet` tv
+ , (rest_bndrs, rest_binds) <- go tv_bndrs1 tvs
+ = ( rest_bndrs
+ , child_binds `appOL` unitOL (mkDB (NonRec tv (Type unf)))
+ `appOL` rest_binds )
+ | otherwise
+ = pprTrace "addTyVarBindings: unxpected 1" (ppr tv $$ ppr dict_arg) $
+ go tv_bndrs tvs
+
+ need_bind_tvs = exprSomeFreeVarsList needs_binding dict_arg
+ in_scope = substInScopeSet subst
+ needs_binding var
+ | isGlobalVar var
+ = False
+ | var `elemInScopeSet` in_scope
+ = False
+ | otherwise
+ = case tyVarUnfolding_maybe var of
+ Just {} -> True
+ Nothing -> pprPanic "addTyVarBindings: unexpected 2"
+ (ppr var $$ ppr dict_arg)
+
-- | Binds a dictionary argument to a fresh name, to preserve sharing
bindAuxiliaryDict
:: Subst
-> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression
- -> ( Subst -- Substitutes for orig_dict_id
- , Maybe DictBind -- Auxiliary dict binding, if any
- , OutExpr) -- Witnessing expression (always trivial)
+ -> ( Subst -- Substitutes for orig_dict_id
+ , OrdList FloatBind -- Auxiliary dict binding, if any
+ , OutExpr) -- Witnessing expression (always trivial)
bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg
-- If the dictionary argument is trivial,
@@ -2727,7 +2779,7 @@ bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg
| exprIsTrivial dict_arg
, let subst' = Core.extendSubst subst orig_dict_id dict_arg
= -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_arg) $
- (subst', Nothing, dict_arg)
+ (subst', nilOL, dict_arg)
| otherwise -- Non-trivial dictionary arg; make an auxiliary binding
, let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg
@@ -2737,7 +2789,7 @@ bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg
`Core.extendSubstInScope` fresh_dict_id'
-- Ensure the new unfolding is in the in-scope set
= -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $
- (subst', Just dict_bind, Var fresh_dict_id')
+ (subst', unitOL dict_bind, Var fresh_dict_id')
addDictUnfolding :: Id -> CoreExpr -> Id
-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]
@@ -2767,34 +2819,34 @@ in the dictionary Id.
********************************************************************* -}
data UsageDetails
- = MkUD { ud_binds :: !FloatedDictBinds
+ = MkUD { ud_binds :: !FloatBinds
, ud_calls :: !CallDetails }
- -- INVARIANT: suppose bs = fdb_bndrs ud_binds
+ -- INVARIANT: suppose bs = fbs_bndrs ud_binds
-- Then 'calls' may *mention* 'bs',
-- but there should be no calls *for* bs
-data FloatedDictBinds -- See Note [Floated dictionary bindings]
- = FDB { fdb_binds :: !(OrdList DictBind)
+data FloatBinds -- See Note [Floated dictionary bindings]
+ = FDB { fbs_binds :: !(OrdList FloatBind)
-- The order is important;
-- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1
- , fdb_bndrs :: !IdSet
- } -- ^ The binders of 'fdb_binds'.
+ , fbs_bndrs :: !IdSet
+ } -- ^ The binders of 'fbs_binds'.
-- Caches a superset of the expression
- -- `mkVarSet (bindersOfDictBinds fdb_binds))`
+ -- `mkVarSet (bindersOfFloatBinds fbs_binds))`
-- for later addition to an InScopeSet
--- | A 'DictBind' is a binding along with a cached set containing its free
+-- | A 'FloatBind' is a binding along with a cached set containing its free
-- variables (both type variables and dictionaries). We need this set
--- in splitDictBinds, when filtering bindings to decide which are
+-- in splitFloatBinds, when filtering bindings to decide which are
-- captured by a binder
-data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }
+data FloatBind = DB { fb_bind :: CoreBind, fb_fvs :: VarSet }
-bindersOfDictBind :: DictBind -> [Id]
-bindersOfDictBind = bindersOf . db_bind
+bindersOfFloatBind :: FloatBind -> [Id]
+bindersOfFloatBind = bindersOf . fb_bind
-bindersOfDictBinds :: Foldable f => f DictBind -> [Id]
-bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []
+bindersOfFloatBinds :: Foldable f => f FloatBind -> [Id]
+bindersOfFloatBinds = bindersOfBinds . foldr ((:) . fb_bind) []
{- Note [Floated dictionary bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2819,7 +2871,7 @@ and continue. But then we have to add $c== to the floats, and so on.
These all float above the binding for 'f', and now we can
successfully specialise 'f'.
-So the DictBinds in (ud_binds :: OrdList DictBind) may contain
+So the FloatBinds in (ud_binds :: OrdList FloatBind) may contain
non-dictionary bindings too.
Note [Specialising polymorphic dictionaries]
@@ -2853,9 +2905,8 @@ Here are the moving parts:
CIS wimwam (CI { ci_key = [@(ST s), dMST @s]
, ci_fvs = {dMST} })
when we come to the /\s. Instead, we simply let it continue to float
- upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that
- are free in the call, but not the /TyVars/. Hence using specArgFreeIds
- in singleCall.
+ upwards. We deal with this in `deleteCallsMentioning`,
+ when `Opt_PolymorphicSpecialisation` is on
NB to be fully kosher we should explicitly quantifying the CallInfo
over 's', but we don't bother. This would matter if there was an
@@ -2953,8 +3004,8 @@ over too many type variables. But that too is now fixed;
see Note [Which type variables to abstract over] in that module.
-}
-instance Outputable DictBind where
- ppr (DB { db_bind = bind, db_fvs = fvs })
+instance Outputable FloatBind where
+ ppr (DB { fb_bind = bind, fb_fvs = fvs })
= text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs
, text "bind:" <+> ppr bind ])
@@ -2964,15 +3015,15 @@ instance Outputable UsageDetails where
[text "binds" <+> equals <+> ppr dbs,
text "calls" <+> equals <+> ppr calls]))
-instance Outputable FloatedDictBinds where
- ppr (FDB { fdb_binds = binds }) = ppr binds
+instance Outputable FloatBinds where
+ ppr (FDB { fbs_binds = binds }) = ppr binds
emptyUDs :: UsageDetails
emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }
-emptyFDBs :: FloatedDictBinds
-emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet }
+emptyFDBs :: FloatBinds
+emptyFDBs = FDB { fbs_binds = nilOL, fbs_bndrs = emptyVarSet }
------------------------------------------------------------
type CallDetails = DIdEnv CallInfoSet
@@ -2990,9 +3041,9 @@ data CallInfo
= CI { ci_key :: [SpecArg] -- Arguments of the call
-- See Note [The (CI-KEY) invariant]
- , ci_fvs :: IdSet -- Free Ids of the ci_key call
+ , ci_fvs :: IdSet -- All free vars of ci_key arguments
-- /not/ including the main id itself, of course
- -- NB: excluding tyvars:
+ -- NB: including tyvars:
-- See Note [Specialising polymorphic dictionaries]
}
@@ -3047,21 +3098,15 @@ getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiT
------------------------------------------------------------
-singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails
-singleCall spec_env id args
+singleCall :: Id -> [SpecArg] -> UsageDetails
+singleCall id args
= MkUD {ud_binds = emptyFDBs,
ud_calls = unitDVarEnv id $ CIS id $
- unitBag (CI { ci_key = args
- , ci_fvs = fvVarSet call_fvs }) }
+ unitBag call_info }
where
- poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)
-
- -- With -fpolymorphic-specialisation, keep just local /Ids/
- -- Otherwise, keep /all/ free vars including TyVars
- -- See (MP1) in Note [Specialising polymorphic dictionaries]
- -- But NB: we don't include the 'id' itself.
- call_fvs | poly_spec = specArgsFVs isLocalId args
- | otherwise = specArgsFVs isLocalVar args
+ call_info = CI { ci_key = args
+ , ci_fvs = specArgsFVs args }
+ -- See (STV1) in Note [Specialisation and type-variable bindings]
mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails
mkCallUDs env fun args
@@ -3076,7 +3121,7 @@ mkCallUDs' env f args
| wantCallsFor env f -- We want it, and...
, not (null ci_key) -- this call site has a useful specialisation
= -- pprTrace "mkCallUDs: keeping" _trace_doc
- singleCall env f ci_key
+ singleCall f ci_key
| otherwise -- See also Note [Specialisations already covered]
= -- pprTrace "mkCallUDs: discarding" _trace_doc
@@ -3352,21 +3397,21 @@ thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
= MkUD { ud_binds = db1 `thenFDBs` db2
, ud_calls = calls1 `unionCalls` calls2 }
-thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
--- Combine FloatedDictBinds
+thenFDBs :: FloatBinds -> FloatBinds -> FloatBinds
+-- Combine FloatBinds
-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa
-thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })
- (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })
- = FDB { fdb_binds = dbs1 `appOL` dbs2
- , fdb_bndrs = bs1 `unionVarSet` bs2 }
+thenFDBs (FDB { fbs_binds = dbs1, fbs_bndrs = bs1 })
+ (FDB { fbs_binds = dbs2, fbs_bndrs = bs2 })
+ = FDB { fbs_binds = dbs1 `appOL` dbs2
+ , fbs_bndrs = bs1 `unionVarSet` bs2 }
-----------------------------
-_dictBindBndrs :: OrdList DictBind -> [Id]
-_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs
+_dictBindBndrs :: OrdList FloatBind -> [Id]
+_dictBindBndrs dbs = foldr ((++) . bindersOf . fb_bind) [] dbs
--- | Construct a 'DictBind' from a 'CoreBind'
-mkDB :: CoreBind -> DictBind
-mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }
+-- | Construct a 'FloatBind' from a 'CoreBind'
+mkDB :: CoreBind -> FloatBind
+mkDB bind = DB { fb_bind = bind, fb_fvs = bind_fvs bind }
-- | Identify the free variables of a 'CoreBind'
bind_fvs :: CoreBind -> VarSet
@@ -3397,54 +3442,54 @@ pair_fvs (bndr, rhs) = bndr_fvs `unionVarSet` rhs_fvs
-- whether a dictionary binding depends on an imported
-- DFun in case we try to specialise that imported DFun
--- | Flatten a set of "dumped" 'DictBind's, and some other binding
+-- | Flatten a set of "dumped" 'FloatBind's, and some other binding
-- pairs, into a single recursive binding.
-recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind
+recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList FloatBind -> FloatBind
recWithDumpedDicts pairs dbs
- = DB { db_bind = Rec bindings
- , db_fvs = fvs `delVarSetList` map fst bindings }
+ = DB { fb_bind = Rec bindings
+ , fb_fvs = fvs `delVarSetList` map fst bindings }
where
(bindings, fvs) = foldr add ([], emptyVarSet)
(dbs `snocOL` mkDB (Rec pairs))
- add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc)
+ add (DB { fb_bind = bind, fb_fvs = fvs }) (prs_acc, fvs_acc)
= case bind of
NonRec b r -> ((b,r) : prs_acc, fvs')
Rec prs1 -> (prs1 ++ prs_acc, fvs')
where
fvs' = fvs_acc `unionVarSet` fvs
-snocDictBind :: UsageDetails -> DictBind -> UsageDetails
-snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db
- = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db
- , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
+snocFloatBind :: UsageDetails -> FloatBind -> UsageDetails
+snocFloatBind uds@MkUD{ud_binds= FDB { fbs_binds = dbs, fbs_bndrs = bs }} db
+ = uds { ud_binds = FDB { fbs_binds = dbs `snocOL` db
+ , fbs_bndrs = bs `extendVarSetList` bindersOfFloatBind db } }
-snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
+snocFloatBinds :: UsageDetails -> OrdList FloatBind -> UsageDetails
-- Add ud_binds to the tail end of the bindings in uds
-snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
- = uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs)
- , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
+snocFloatBinds uds@MkUD{ud_binds=FDB{ fbs_binds = binds, fbs_bndrs = bs }} dbs
+ = uds { ud_binds = FDB { fbs_binds = binds `appOL` dbs
+ , fbs_bndrs = bs `extendVarSetList` bindersOfFloatBinds dbs } }
-consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
-consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
- = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
- , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
+consFloatBinds :: OrdList FloatBind -> UsageDetails -> UsageDetails
+consFloatBinds dbs uds@MkUD{ud_binds=FDB{fbs_binds = binds, fbs_bndrs = bs}}
+ = uds { ud_binds = FDB{ fbs_binds = dbs `appOL` binds
+ , fbs_bndrs = bs `extendVarSetList` bindersOfFloatBinds dbs } }
-wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
-wrapDictBinds (FDB { fdb_binds = dbs }) binds
+wrapFloatBinds :: FloatBinds -> [CoreBind] -> [CoreBind]
+wrapFloatBinds (FDB { fbs_binds = dbs }) binds
= foldr add binds dbs
where
- add (DB { db_bind = bind }) binds = bind : binds
+ add (DB { fb_bind = bind }) binds = bind : binds
-wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr
-wrapDictBindsE dbs expr
+wrapFloatBindsE :: OrdList FloatBind -> CoreExpr -> CoreExpr
+wrapFloatBindsE dbs expr
= foldr add expr dbs
where
- add (DB { db_bind = bind }) expr = Let bind expr
+ add (DB { fb_bind = bind }) expr = Let bind expr
----------------------
-dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind)
+dumpUDs :: SpecEnv -> [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList FloatBind)
-- Used at binder; just dump anything mentioning the binder
-dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+dumpUDs env bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
| null bndrs = (uds, nilOL) -- Common in case alternatives
| otherwise = -- pprTrace "dumpUDs" (vcat
-- [ text "bndrs" <+> ppr bndrs
@@ -3455,19 +3500,20 @@ dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
where
free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }
bndr_set = mkVarSet bndrs
- (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+ (free_dbs, dump_dbs, dump_set) = splitFloatBinds orig_dbs bndr_set
-- Delete calls:
-- * For any binder in `bndrs`
-- * That mention a dictionary bound in `dump_set`
-- These variables aren't in scope "above" the binding and the `dump_dbs`,
-- so no call should mention them. (See #26682.)
- free_calls = deleteCallsMentioning dump_set $
+ free_calls = deleteCallsMentioning env dump_set $
deleteCallsFor bndrs orig_calls
-dumpBindUDs :: Bool -- Main binding can float to top
+dumpBindUDs :: SpecEnv
+ -> Bool -- Main binding can float to top
-> [CoreBndr] -> UsageDetails
- -> (UsageDetails, OrdList DictBind, Bool)
+ -> (UsageDetails, OrdList FloatBind, Bool)
-- Used at a let(rec) binding.
-- We return a boolean indicating whether the binding itself
-- is mentioned, directly or indirectly, by any of the ud_calls;
@@ -3475,17 +3521,17 @@ dumpBindUDs :: Bool -- Main binding can float to top
-- See Note [Floated dictionary bindings]
-- If the boolean is True, then the returned ud_calls can mention `bndrs`;
-- if False, then returned ud_calls must not mention `bndrs`
-dumpBindUDs can_float_bind bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+dumpBindUDs env can_float_bind bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
= ( MkUD { ud_binds = free_dbs, ud_calls = free_calls2 }
, dump_dbs
, can_float_bind && calls_mention_bndrs )
where
bndr_set = mkVarSet bndrs
- (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+ (free_dbs, dump_dbs, dump_set) = splitFloatBinds orig_dbs bndr_set
free_calls1 = deleteCallsFor bndrs orig_calls
calls_mention_bndrs = dump_set `intersectsVarSet` callDetailsFVs free_calls1
free_calls2 | can_float_bind = free_calls1
- | otherwise = deleteCallsMentioning dump_set free_calls1
+ | otherwise = deleteCallsMentioning env dump_set free_calls1
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
@@ -3502,22 +3548,22 @@ callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
Just cis -> filterCalls cis orig_dbs
----------------------
-filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
+filterCalls :: CallInfoSet -> FloatBinds -> [CallInfo]
-- Remove
-- (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries]
-- (b) loopy DFuns: Note [Avoiding loops (DFuns)]
-filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
+filterCalls (CIS fn call_bag) (FDB { fbs_binds = dbs })
| isDFunId fn = filter ok_call de_dupd_calls -- Deals with (b)
| otherwise = de_dupd_calls
where
de_dupd_calls = removeDupCalls call_bag -- Deals with (a)
dump_set = foldl' go (unitVarSet fn) dbs
- -- This dump-set could also be computed by splitDictBinds
- -- (_,_,dump_set) = splitDictBinds dbs {fn}
+ -- This dump-set could also be computed by splitFloatBinds
+ -- (_,_,dump_set) = splitFloatBinds dbs {fn}
-- But this variant is shorter
- go so_far (DB { db_bind = bind, db_fvs = fvs })
+ go so_far (DB { fb_bind = bind, fb_fvs = fvs })
| fvs `intersectsVarSet` so_far
= extendVarSetList so_far (bindersOf bind)
| otherwise = so_far
@@ -3558,16 +3604,16 @@ beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
go_arg _ _ = False
----------------------
-splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)
--- splitDictBinds dbs bndrs returns
+splitFloatBinds :: FloatBinds -> IdSet -> (FloatBinds, OrdList FloatBind, IdSet)
+-- splitFloatBinds dbs bndrs returns
-- (free_dbs, dump_dbs, dump_set)
-- where
-- * dump_dbs depends, transitively on bndrs
-- * free_dbs does not depend on bndrs
-- * dump_set = bndrs `union` bndrs(dump_dbs)
-splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
- = (FDB { fdb_binds = free_dbs
- , fdb_bndrs = bs `minusVarSet` dump_set }
+splitFloatBinds (FDB { fbs_binds = dbs, fbs_bndrs = bs }) bndr_set
+ = (FDB { fbs_binds = free_dbs
+ , fbs_bndrs = bs `minusVarSet` dump_set }
, dump_dbs, dump_set)
where
(free_dbs, dump_dbs, dump_set)
@@ -3576,7 +3622,7 @@ splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
-- we're accumulating the set of dumped ids in dump_set
split_db (free_dbs, dump_dbs, dump_idset) db
- | DB { db_bind = bind, db_fvs = fvs } <- db
+ | DB { fb_bind = bind, fb_fvs = fvs } <- db
, dump_idset `intersectsVarSet` fvs -- Dump it
= (free_dbs, dump_dbs `snocOL` db,
extendVarSetList dump_idset (bindersOf bind))
@@ -3586,15 +3632,26 @@ splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
----------------------
-deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
+deleteCallsMentioning :: SpecEnv -> VarSet -> CallDetails -> CallDetails
-- Remove calls mentioning any Id in bndrs
-- NB: The call is allowed to mention TyVars in bndrs
-- Note [Specialising polymorphic dictionaries]
-- ci_fvs are just the free /Ids/
-deleteCallsMentioning bndrs calls
+deleteCallsMentioning env bndrs calls
= mapDVarEnv (ciSetFilter keep_call) calls
where
- keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs
+ keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bad_bndrs
+
+ poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags env)
+
+ -- With -fpolymorphic-specialisation, we allow calls to float outside
+ -- the binding of a TyVar, so we restrict the bad_bndrs to just the Ids
+ -- See (STV2) in Note [Specialisation and type-variable bindings]
+ -- and (MP1) in Note [Specialising polymorphic dictionaries]
+ -- But NB: we don't include the 'id' itself.
+ bad_bndrs | poly_spec = filterVarSet isId bndrs
+ | otherwise = bndrs
+
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
-- Remove calls *for* bndrs
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -6,7 +6,7 @@ module GHC.Core.TyCo.FVs
tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet,
tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,
- tyCoFVsOfType, tyCoVarsOfTypeList,
+ tyCoFVsOfType, tyCoVarsOfTypeList, someTyCoVarsOfTypeList,
tyCoFVsOfTypes, tyCoVarsOfTypesList,
deepTcvFolder,
@@ -601,6 +601,9 @@ tyCoVarsOfTypeList :: Type -> [TyCoVar]
-- See Note [Free variables of types]
tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty
+someTyCoVarsOfTypeList :: InterestingVarFun -> Type -> [TyCoVar]
+someTyCoVarsOfTypeList fv_cand ty = fvVarList $ filterFV fv_cand $ tyCoFVsOfType ty
+
-- | Returns free variables of types, including kind variables as
-- a deterministic set. For type synonyms it does /not/ expand the
-- synonym.
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -510,13 +510,13 @@ zipCoEnv cvs cos
instance Outputable Subst where
ppr (Subst in_scope ids tvs cvs)
- = text "<InScope =" <+> in_scope_doc
- $$ text " IdSubst =" <+> ppr ids
- $$ text " TvSubst =" <+> ppr tvs
- $$ text " CvSubst =" <+> ppr cvs
+ = vcat [ -- text "<InScope =" <+> _in_scope_doc,
+ text " IdSubst =" <+> ppr ids,
+ text " TvSubst =" <+> ppr tvs,
+ text " CvSubst =" <+> ppr cvs ]
<> char '>'
where
- in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)
+ _in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)
{-
%************************************************************************
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -143,6 +143,7 @@ exprType e = go emptyVarSet e
-- should return (Maybe (Int,b)), having expanded out the `a`
expand = expandTyVarUnfoldings
+ go :: VarSet -> CoreExpr -> Type
go tvs (Var var) = expand tvs $ idType var
go tvs (Lit lit) = expand tvs $ literalType lit
go tvs (Coercion co) = expand tvs $ coercionType co
@@ -1379,7 +1380,12 @@ coercionIsTrivial :: Coercion -> Bool
coercionIsTrivial co = coercionSize co < 10 -- Try this out
{-# INLINE trivial_expr_fold #-}
-trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
+trivial_expr_fold :: (Coercion -> Bool) -- Whether a coercion is trivial
+ -> (Id -> r) -- What to do for a Var
+ -> (Literal -> r) -- What to do for a Lit
+ -> r -- What do to for other trivial
+ -> r -- What to do for non-trivial
+ -> CoreExpr -> r
-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]
-- This is meant to have the code of both functions in one place and make it
-- easy to derive custom predicates.
@@ -1394,7 +1400,7 @@ trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
-- * Type application or abstraction
-- * Ticks other than `tickishIsCode`
-- * `case e of {}` an empty case
-trivial_expr_fold k_id k_lit k_triv k_not_triv = go
+trivial_expr_fold co_is_triv k_id k_lit k_triv k_not_triv = go
where
-- If you change this function, be sure to change
-- SetLevels.notWorthFloating as well!
@@ -1402,14 +1408,14 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go
go (Var v) = k_id v -- See Note [Variables are trivial]
go (Lit l) | litIsTrivial l = k_lit l
go (Type _) = k_triv
- go (Coercion co) | coercionIsTrivial co = k_triv
+ go (Coercion co) | co_is_triv co = k_triv
go (App f arg)
| not (isRuntimeArg arg) = go f
| exprIsUnaryClassFun f = go arg
| otherwise = k_not_triv
go (Lam b e) | not (isRuntimeVar b) = go e
go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial]
- go (Cast e co) | coercionIsTrivial co = go e
+ go (Cast e co) | co_is_triv co = go e
go (Let b e) | isTyCoBind b = go e
-- ToDo: what about a non-triv coercion?
go (Case e b _ as)
@@ -1420,7 +1426,7 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go
go _ = k_not_triv
exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e
+exprIsTrivial e = trivial_expr_fold coercionIsTrivial (const True) (const True) True False e
{-
Note [getIdFromTrivialExpr]
@@ -1441,12 +1447,12 @@ T12076lit for an example where this matters.
getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id
-- See Note [getIdFromTrivialExpr]
-getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e
+getIdFromTrivialExpr e = trivial_expr_fold (const True) id (const panic) panic panic e
where
panic = pprPanic "getIdFromTrivialExpr" (ppr e)
getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
-getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e
+getIdFromTrivialExpr_maybe e = trivial_expr_fold (const True) Just (const Nothing) Nothing Nothing e
{- *********************************************************************
* *
@@ -3299,8 +3305,6 @@ Wrinkles
= \a. \(x:[a]). let @b = [a] in
reverse (x:b)
where the /occurrence/ Var (x:b) has a different type to the /binding/ x:[a].
- Worse
-
-}
type AbsVar = Var
@@ -3317,26 +3321,33 @@ mkPolyAbsLams :: forall b. (b -> AbsVar, Var -> b -> b)
mkPolyAbsLams (getter,setter) bndrs body
= go emptyVarSet [] bndrs
where
- go :: TyVarSet -- Earlier TyVar bndrs that have TyVarUnfoldings
- -> [Bind b] -- Accumulated impedence-matching bindings (reversed)
- -> [b] -- Binders, bs
- -> Expr b -- The resulting lambda
- go _ binds [] = mkLets (reverse binds) body
+ wrap_bind :: Expr b -> (b,Expr b) -> Expr b
+ -- wrap_bind e (bndr, rhs) = (\bndr.e) rhs
+ -- Very like let bndr=rhs in e
+ -- but, for type-bindings at least, does not require that the occurrences
+ -- of bndr have the unfolding from the let-binding
+ wrap_bind e (bndr, rhs) = App (Lam bndr e) rhs
+
+ go :: TyVarSet -- Earlier TyVar bndrs that have TyVarUnfoldings
+ -> [(b,Expr b)] -- Accumulated impedence-matching bindings (reversed)
+ -> [b] -- Binders, bs
+ -> Expr b -- The resulting lambda
+ go _ binds [] = foldl wrap_bind body binds
go unf_tvs binds (bndr:bndrs)
| Just ty <- tyVarUnfolding_maybe var
- = go (unf_tvs `extendVarSet` var) (NonRec bndr (Type ty) : binds) bndrs
+ = go (unf_tvs `extendVarSet` var) ((bndr, Type ty) : binds) bndrs
| isTyVar var, change_ty
, let binds' | isDeadBinder var = binds
- | otherwise = NonRec bndr (Type (mkTyVarTy var1)) : binds
+ | otherwise = (bndr, varToCoreExpr var1) : binds
-- Why this let-binding?
= Lam (setter var1 bndr) (go unf_tvs binds' bndrs)
| isId var, change_ty || change_unf
, let binds' | isDeadBinder var = binds
- | otherwise = NonRec bndr (varToCoreExpr id2) : binds
+ | otherwise = (bndr, varToCoreExpr id2) : binds
= Lam (setter id2 bndr) (go unf_tvs binds' bndrs)
| otherwise
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -598,9 +598,9 @@ sumPrimReps _ = []
getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg
-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.
-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or
--- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.
+-- `case unsafeEqualityProof of UnsafeRefl -> e` might intervene.
-- Good thing we can just call `trivial_expr_fold` here.
-getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e
+getStgArgFromTrivialArg e = trivial_expr_fold (const True) StgVarArg StgLitArg panic panic e
where
panic = pprPanic "getStgArgFromTrivialArg" (ppr e)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7594dac9aacaeebebdfcdf168b3fa49…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7594dac9aacaeebebdfcdf168b3fa49…
You're receiving this email because of your account on gitlab.haskell.org.
1
0