January 2026 - ghc-commits

[Git][ghc/ghc][wip/26699] Refactoring after adding TTG extension
by recursion-ninja (＠recursion-ninja) 27 Jan '26

27 Jan '26

recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC Commits: 631825ab by Recursion Ninja at 2026-01-26T19:24:37-05:00 Refactoring after adding TTG extension - - - - - 22 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Extension.hs - − compiler/GHC/Hs/Extension.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser.y - compiler/GHC/ThToHs.hs - compiler/GHC/Types/ImportLevel.hs - − compiler/GHC/Types/Name/RdrName.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/OverlapFlag.hs - compiler/GHC/Types/OverlapMode.hs - compiler/GHC/Types/SourceText.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 - ghc/GHCi/UI.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -101,6 +101,7 @@ module GHC.Hs.Decls ( import GHC.Prelude import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -16,10 +16,11 @@ import GHC.Prelude import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Extension import GHC.Types.Name -import GHC.Types.Name.RdrName +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) +import GHC.Utils.Panic import GHC.Parser.Annotation {- @@ -152,9 +153,9 @@ data GhcPass (c :: Pass) where -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist. instance Typeable p => Data (GhcPass p) where - gunfold _ _ _ = error "instance Data GhcPass" - toConstr _ = error "instance Data GhcPass" - dataTypeOf _ = error "instance Data GhcPass" + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" data Pass = Parsed | Renamed | Typechecked deriving (Data) ===================================== compiler/GHC/Hs/Extension.hs-boot deleted ===================================== @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] - -module GHC.Hs.Extension where - -import Data.Type.Equality (type (~)) - --- | Used as a data type index for the hsSyn AST; also serves --- as a singleton type for Pass -data GhcPass (c :: Pass) where - GhcPs :: GhcPass 'Parsed - GhcRn :: GhcPass 'Renamed - GhcTc :: GhcPass 'Typechecked - -data Pass = Parsed | Renamed | Typechecked - --- Type synonyms as a shorthand for tagging -type GhcPs = GhcPass 'Parsed -- Output of parser -type GhcRn = GhcPass 'Renamed -- Output of renamer -type GhcTc = GhcPass 'Typechecked -- Output of typechecker - -type family NoGhcTcPass (p :: Pass) :: Pass where - NoGhcTcPass 'Typechecked = 'Renamed - NoGhcTcPass other = other - -class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p - , IsPass (NoGhcTcPass p) - ) => IsPass p where - ghcPass :: GhcPass p ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -32,8 +32,8 @@ import GHC.Parser.Annotation import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.InlinePragma (ActivationGhc) import GHC.Data.BooleanFormula (BooleanFormula(..)) -import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -72,6 +72,7 @@ import GHC.Types.ForeignCall import GHC.Types.Var import GHC.Types.Id import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceText import GHC.Types.TyThing import GHC.Types.Name hiding( varName, tcName ) ===================================== compiler/GHC/Parser.y ===================================== @@ -70,6 +70,7 @@ import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.InlinePragma +import GHC.Types.OverlapMode import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.PkgQual ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -39,10 +39,11 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Types.Basic as Hs -import GHC.Types.InlinePragma as Hs import GHC.Types.ForeignCall -import GHC.Types.Unique +import GHC.Types.InlinePragma as Hs +import GHC.Types.OverlapMode as Hs import GHC.Types.SourceText +import GHC.Types.Unique import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString ===================================== compiler/GHC/Types/ImportLevel.hs ===================================== @@ -1,7 +1,14 @@ {-# LANGUAGE DerivingVia #-} module GHC.Types.ImportLevel ( - ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels, + -- * ImportLevel + -- ** Data-type + ImportLevel(..), + -- ** Enumeration + allImportLevels, + -- ** Conversion + convImportLevel, + convImportLevelSpec ) where import GHC.Prelude ===================================== compiler/GHC/Types/Name/RdrName.hs deleted ===================================== @@ -1,202 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} - --- | --- Export /only/ the 'RdrName' data-type. --- --- Since 'RdrName' is an integral data-type found in many places throughout --- the compiler, importing a module which exposes 'RdrName' can cause module --- import cycles. By having a dedicated module which exports the bare minimum --- necessary to expose the data-type definition, these module import cycles --- can easily be avoided! -module GHC.Types.Name.RdrName ( - -- * The main type - RdrName(..), - WithUserRdr(..), - isExact_maybe, - rdrNameOcc, - ) where - -import GHC.Prelude - -import GHC.Types.Name -import GHC.Unit.Module -import GHC.Utils.Outputable - -import Data.Data -import qualified Data.Semigroup as S - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `bar` --- > ( ~ ) --- -data RdrName - = Unqual OccName - -- ^ Unqualified name - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance HasOccName RdrName where - occName = rdrNameOcc - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- <decl involving n1,n2> } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Orig _ _) _ = GT - -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrQual_maybe :: RdrName -> Maybe ModuleName -rdrQual_maybe = \case - Qual q _ -> Just q - _ -> Nothing - --------------------------------------------------------------------------------- --- Preserving user-written qualification - --- | 'WithUserRdr' allows us to keep track of the original user-written --- 'RdrName', and in particular, any user-written module qualification. --- --- See Note [IdOcc] in Language.Haskell.Syntax.Extension. -data WithUserRdr a = WithUserRdr RdrName a - deriving stock (Functor, Foldable, Traversable) - -instance NamedThing a => NamedThing (WithUserRdr a) where - getName (WithUserRdr _rdr a) = getName a -instance Outputable (WithUserRdr Name) where - ppr (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name -instance OutputableBndr (WithUserRdr Name) where - pprBndr _ (WithUserRdr rdr name) = - pprName_userQual (rdrQual_maybe rdr) name - pprInfixOcc :: WithUserRdr Name -> SDoc - pprInfixOcc = pprInfixName - pprPrefixOcc = pprPrefixName ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -117,13 +117,12 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Types.Avail -import GHC.Types.Basic +import GHC.Types.Basic ( TyConFlavour(..), tyConFlavourAssoc_maybe ) import GHC.Types.FieldLabel import GHC.Types.GREInfo import GHC.Types.ImportLevel import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.RdrName import GHC.Types.Name.Set import GHC.Types.PkgQual import GHC.Types.SrcLoc as SrcLoc @@ -152,6 +151,65 @@ import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import System.IO.Unsafe ( unsafePerformIO ) +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + {- ************************************************************************ * * @@ -160,6 +218,15 @@ import System.IO.Unsafe ( unsafePerformIO ) ************************************************************************ -} +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -226,6 +293,11 @@ nameRdrName name = Exact name -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool isRdrTc :: RdrName -> Bool @@ -263,6 +335,76 @@ isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- <decl involving n1,n2> } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Orig _ _) _ = GT + {- ************************************************************************ * * @@ -2076,6 +2218,29 @@ pprLoc (UnhelpfulSpan {}) = empty opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@") + +-------------------------------------------------------------------------------- +-- Preserving user-written qualification + +-- | 'WithUserRdr' allows us to keep track of the original user-written +-- 'RdrName', and in particular, any user-written module qualification. +-- +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension. +data WithUserRdr a = WithUserRdr RdrName a + deriving stock (Functor, Foldable, Traversable) + +instance NamedThing a => NamedThing (WithUserRdr a) where + getName (WithUserRdr _rdr a) = getName a +instance Outputable (WithUserRdr Name) where + ppr (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name +instance OutputableBndr (WithUserRdr Name) where + pprBndr _ (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name + pprInfixOcc :: WithUserRdr Name -> SDoc + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a unLocWithUserRdr (L _ (WithUserRdr _ a)) = a @@ -2084,3 +2249,10 @@ noUserRdr n = WithUserRdr (nameRdrName n) n userRdrName :: WithUserRdr Name -> RdrName userRdrName (WithUserRdr rdr _) = rdr + +rdrQual_maybe :: RdrName -> Maybe ModuleName +rdrQual_maybe = \case + Qual q _ -> Just q + _ -> Nothing + +-------------------------------------------------------------------------------- ===================================== compiler/GHC/Types/OverlapFlag.hs ===================================== @@ -41,7 +41,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Types.OverlapMode (changeOverlapModePass) -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Control.DeepSeq (NFData(..)) ===================================== compiler/GHC/Types/OverlapMode.hs ===================================== @@ -5,6 +5,13 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + * (type class): Binary OverlapMode + * (type family): XOverlapMode (GhcPass p) + * (type family): XXOverlapMode (GhcPass p) +-} + module GHC.Types.OverlapMode ( -- * OverlapMode -- ** Data-type @@ -21,15 +28,13 @@ module GHC.Types.OverlapMode ( import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) - +import GHC.Hs.Extension (GhcPass) import GHC.Types.SourceText +import GHC.Utils.Binary -import Language.Haskell.Syntax.Basic (OverlapMode(..)) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension -import Control.DeepSeq ( NFData(..) ) - type instance XOverlapMode (GhcPass _) = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen @@ -77,3 +82,21 @@ hasNonCanonicalFlag :: OverlapMode (GhcPass p) -> Bool hasNonCanonicalFlag = \case NonCanonical{} -> True _ -> False + +instance Binary (OverlapMode (GhcPass p)) where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Types/SourceText.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Utils.Outputable +import GHC.Utils.Binary import GHC.Utils.Panic import Data.Function (on) @@ -112,6 +113,21 @@ instance NFData SourceText where SourceText s -> rnf s NoSourceText -> () +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h + -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText d = d ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -82,6 +82,7 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Types.Unique.DSet +import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Encoding @@ -135,6 +136,11 @@ mkModule = Module instance Uniquable Module where getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n) +instance Binary a => Binary (GenModule a) where + put_ bh (Module p n) = put_ bh p >> put_ bh n + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n + instance NFData (GenModule a) where rnf (Module unit name) = unit `seq` name `seq` () @@ -293,6 +299,23 @@ instance Eq (GenInstantiatedUnit unit) where instance Ord (GenInstantiatedUnit unit) where u1 `compare` u2 = instUnitFS u1 `lexicalCompareFS` instUnitFS u2 +instance Binary InstantiatedUnit where + put_ bh indef = do + put_ bh (instUnitInstanceOf indef) + put_ bh (instUnitInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = mkInstantiatedUnitHash cid insts + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } + instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 @@ -326,6 +349,24 @@ pprUnit HoleUnit = ftext holeFS instance Show Unit where show = unitString +-- Performance: would prefer to have a NameCache like thing +instance Binary Unit where + put_ bh (RealUnit def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (VirtUnit indef_uid) = do + putByte bh 1 + put_ bh indef_uid + put_ bh HoleUnit = + putByte bh 2 + get bh = do b <- getByte bh + u <- case b of + 0 -> fmap RealUnit (get bh) + 1 -> fmap VirtUnit (get bh) + _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u + -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName unitFreeModuleHoles (VirtUnit x) = instUnitHoles x @@ -468,6 +509,10 @@ newtype UnitId = UnitId instance NFData UnitId where rnf (UnitId fs) = rnf fs `seq` () +instance Binary UnitId where + put_ bh (UnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (UnitId fs) + instance Eq UnitId where uid1 == uid2 = getUnique uid1 == getUnique uid2 @@ -503,7 +548,7 @@ stringToUnitId = UnitId . mkFastString -- | A definite unit (i.e. without any free module hole) newtype Definite unit = Definite { unDefinite :: unit } deriving (Functor) - deriving newtype (Eq, Ord, Outputable, Uniquable, IsUnitId) + deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId) --------------------------------------------------------------------- -- WIRED-IN UNITS @@ -651,6 +696,15 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName type ModuleWithIsBoot = GenWithIsBoot Module +instance Binary a => Binary (GenWithIsBoot a) where + put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do + put_ bh gwib_mod + put_ bh gwib_isBoot + get bh = do + gwib_mod <- get bh + gwib_isBoot <- get bh + pure $ GWIB { gwib_mod, gwib_isBoot } + instance Outputable a => Outputable (GenWithIsBoot a) where ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of IsBoot -> [ text "{-# SOURCE #-}" ] ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -120,8 +120,8 @@ import GHC.Prelude import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) -import {-# SOURCE #-} GHC.Hs.Extension (GhcPass) import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Data.TrieMap @@ -130,19 +130,14 @@ import GHC.Utils.Panic.Plain import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint -import GHC.Types.OverlapMode -import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Unique -import GHC.Unit.Types import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) import GHCi.FFI import GHCi.Message -import GHC.Types.Unique.DSet ( unionManyUniqDSets ) - -import Control.DeepSeq ( NFData(..) ) +import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array @@ -2017,85 +2012,6 @@ instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) = rnf fp `seq` rnf mflags `seq` () -instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return NoSourceText - 1 -> do - s <- get bh - return (SourceText s) - _ -> panic $ "Binary SourceText:" ++ show h - --------------------------------------------------------------------------------- --- Instances for the GHC.Unit.Types module --------------------------------------------------------------------------------- - -instance Binary a => Binary (GenModule a) where - put_ bh (Module p n) = put_ bh p >> put_ bh n - -- Module has strict fields, so use $! in order not to allocate a thunk - get bh = do p <- get bh; n <- get bh; return $! Module p n - -instance Binary InstantiatedUnit where - put_ bh indef = do - put_ bh (instUnitInstanceOf indef) - put_ bh (instUnitInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = mkInstantiatedUnitHash cid insts - -- InstantiatedUnit has strict fields, so use $! in order not to allocate a t\ -hunk - return $! InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) ins\ -ts), - instUnitFS = fs, - instUnitKey = getUnique fs - } - --- Performance: would prefer to have a NameCache like thing -instance Binary Unit where - put_ bh (RealUnit def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (VirtUnit indef_uid) = do - putByte bh 1 - put_ bh indef_uid - put_ bh HoleUnit = - putByte bh 2 - get bh = do b <- getByte bh - u <- case b of - 0 -> fmap RealUnit (get bh) - 1 -> fmap VirtUnit (get bh) - _ -> pure HoleUnit - -- Unit has strict fields that need forcing; otherwise we allocate \ -a thunk. - pure $! u - -instance Binary UnitId where - put_ bh (UnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (UnitId fs) - -instance Binary a => Binary (GenWithIsBoot a) where - put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do - put_ bh gwib_mod - put_ bh gwib_isBoot - get bh = do - gwib_mod <- get bh - gwib_isBoot <- get bh - pure $ GWIB { gwib_mod, gwib_isBoot } - -deriving newtype instance Binary x => Binary (Definite x) - --------------------------------------------------------------------------------- - instance Binary Boxity where -- implemented via isBoxed-isomorphism to Bool put_ bh = put_ bh . isBoxed get bh = do @@ -2164,21 +2080,3 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike - -instance Binary (OverlapMode (GhcPass p)) where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> (get bh) >>= \s -> return $ NonCanonical s ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -114,6 +114,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) import GHC.Prelude.Basic ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -3,8 +3,11 @@ {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode +-- | Data-type defintions of the Abstrast Sytntax Tree +-- which *do not* have any /Trees That Grow/ extension points. module Language.Haskell.Syntax.Basic where +import Control.DeepSeq import Data.Data (Data) import Data.Eq import Data.Ord @@ -12,8 +15,6 @@ import Data.Bool import Prelude import GHC.Data.FastString (FastString) -import Language.Haskell.Syntax.Extension -import Control.DeepSeq {- ************************************************************************ @@ -161,81 +162,3 @@ data Fixity = Fixity Int FixityDirection instance NFData Fixity where rnf (Fixity i d) = rnf i `seq` rnf d `seq` () - -data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv - = NoOverlap (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - | Overlapping (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - | Overlaps (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent (XOverlapMode pass) - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" - - | NonCanonical (XOverlapMode pass) - -- ^ Behave like Incoherent, but the instance choice is observable - -- by the program behaviour. See Note [Coherence and specialisation: overview]. - -- - -- We don't have surface syntax for the distinction between - -- Incoherent and NonCanonical instances; instead, the flag - -- `-f{no-}specialise-incoherents` (on by default) controls - -- whether `INCOHERENT` instances are regarded as Incoherent or - -- NonCanonical. - - | XOverlapMode !(XXOverlapMode pass) - -- ^ The /Trees That Grow/ extension point constructor. - -deriving instance ( Eq (XOverlapMode pass) - , Eq (XXOverlapMode pass)) => Eq (OverlapMode pass) - -instance ( NFData (XOverlapMode pass) - , XXOverlapMode pass ~ DataConCantHappen) => NFData (OverlapMode pass) where - rnf = \case - NoOverlap s -> rnf s - Overlappable s -> rnf s - Overlapping s -> rnf s - Overlaps s -> rnf s - Incoherent s -> rnf s - NonCanonical s -> rnf s ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -88,16 +88,17 @@ module Language.Haskell.Syntax.Decls ( -- friends: import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsUntypedSplice ) + (HsExpr, HsUntypedSplice) -- Because Expr imports Decls via HsBracket -import Language.Haskell.Syntax.Basic (OverlapMode, RuleName, TopLevelFlag) +import Language.Haskell.Syntax.Basic + (LexicalFixity, Role, RuleName, TopLevelFlag) import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Binds.InlinePragma (Activation) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode) import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Type -import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity) +import Language.Haskell.Syntax.Type import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) @@ -118,7 +119,7 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) {- ===================================== compiler/Language/Haskell/Syntax/Decls/Overlap.hs ===================================== @@ -0,0 +1,96 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- | +Data-type describing the state of "overlapping instances" for a type. +-} +module Language.Haskell.Syntax.Decls.Overlap where + +import Control.DeepSeq +import Data.Eq +import Prelude + +import Language.Haskell.Syntax.Extension + +-- | The status of overlapping instances /(including no overlap)/ for a type. +data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Overlapping (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + | Overlaps (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent (XOverlapMode pass) + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + + | NonCanonical (XOverlapMode pass) + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + + | XOverlapMode !(XXOverlapMode pass) + -- ^ The /Trees That Grow/ extension point constructor. + +deriving instance ( Eq (XOverlapMode pass) + , Eq (XXOverlapMode pass) + ) => Eq (OverlapMode pass) + +instance ( NFData (XOverlapMode pass) + , XXOverlapMode pass ~ DataConCantHappen + ) => NFData (OverlapMode pass) where + rnf = \case + NoOverlap s -> rnf s + Overlappable s -> rnf s + Overlapping s -> rnf s + Overlaps s -> rnf s + Incoherent s -> rnf s + NonCanonical s -> rnf s ===================================== ghc/GHCi/UI.hs ===================================== @@ -75,6 +75,7 @@ import GHC.Core.TyCo.Ppr import GHC.Types.SafeHaskell ( getSafeMode ) import GHC.Types.SourceError ( SourceError, initSourceErrorContext ) import GHC.Types.Name +import GHC.Types.ImportLevel ( convImportLevel ) import GHC.Types.Var ( varType ) import GHC.Iface.Syntax ( showToHeader ) import GHC.Builtin.Names ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -40,7 +40,7 @@ import GHC.Driver.DynFlags (getDynFlags) import GHC.Types.Basic (TupleSort (..)) import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) -import GHC.Types.OverlapMode (changeOverlapModeType) +import GHC.Types.OverlapMode (OverlapMode, changeOverlapModeType) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) import Haddock.Backends.Hoogle (ppExportD) ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Core.InstEnv (is_dfun_name) import GHC.Types.Name (stableNameCmp) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName (..)) +import GHC.Types.OverlapMode (OverlapMode) import GHC.Types.SrcLoc (srcSpanToRealSrcSpan) import GHC.Types.Var (Specificity) import GHC.Utils.Outputable View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1ea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/631825abd5f66565616eaa5e314f1ea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Move flags to precede patterns for grep and read files directly
by Marge Bot (＠marge-bot) 26 Jan '26

26 Jan '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 4d17cac9 by Greg Steuck at 2026-01-26T18:32:42-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. - - - - - 0b05ae7f by Matthew Pickering at 2026-01-26T18:32:42-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 - - - - - 12 changed files: - libraries/base/changelog.md - libraries/base/tests/perf/Makefile - libraries/ghc-internal/src/GHC/Internal/Err.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 - testsuite/tests/driver/T16318/Makefile - testsuite/tests/driver/T18125/Makefile - 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 Changes: ===================================== libraries/base/changelog.md ===================================== @@ -23,6 +23,7 @@ * `GHC.Conc.catchSTM` and `GHC.Conc.Sync.catchSTM` now attach `WhileHandling` annotation to exceptions thrown from the handler. ([GHC #25365](https://gitlab.haskell.org/ghc/ghc/-/issues/25365)) * Remove `GHC.JS.Prim.Internal.Build`, as per [CLC #329](https://github.com/haskell/core-libraries-committee/issues/329) * Export `labelThread` from `Control.Concurrent`.([CLC proposal #376](https://github.com/haskell/core-libraries-committee/issues/376)) + * Evaluate backtraces for "error" exceptions at the moment they are thrown. ([CLC proposal #383](https://github.com/haskell/core-libraries-committee/issues/383)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/perf/Makefile ===================================== @@ -12,4 +12,4 @@ T17752: # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. - echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) + echo $$(grep -A4 "elem" T17752.dump-simpl) ===================================== libraries/ghc-internal/src/GHC/Internal/Err.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-} {-# LANGUAGE RankNTypes, PolyKinds, DataKinds #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- @@ -25,6 +26,7 @@ module GHC.Internal.Err( absentErr, error, errorWithoutStackTrace, undefined ) where import GHC.Internal.Types (Char, RuntimeRep) import GHC.Internal.Stack.Types +import GHC.Internal.Magic import GHC.Internal.Prim import {-# SOURCE #-} GHC.Internal.Exception ( errorCallWithCallStackException @@ -33,7 +35,10 @@ import {-# SOURCE #-} GHC.Internal.Exception -- | 'error' stops execution and displays an error message. error :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => [Char] -> a -error s = raise# (errorCallWithCallStackException s ?callStack) +error s = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException s ?callStack) + in raise# se -- Bleh, we should be using 'GHC.Internal.Stack.callStack' instead of -- '?callStack' here, but 'GHC.Internal.Stack.callStack' depends on -- 'GHC.Internal.Stack.popCallStack', which is partial and depends on @@ -73,7 +78,10 @@ undefined :: forall (r :: RuntimeRep). forall (a :: TYPE r). -- nor wanted (see #19886). We’d like to use withFrozenCallStack, but that -- is not available in this module yet, and making it so is hard. So let’s just -- use raise# directly. -undefined = raise# (errorCallWithCallStackException "Prelude.undefined" ?callStack) +undefined = + -- See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] + let !se = noinline (errorCallWithCallStackException "Prelude.undefined" ?callStack) + in raise# se -- | Used for compiler-generated error message; -- encoding saves bytes of string junk. ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -8,3 +8,4 @@ test('ann_frame001', ann_frame_opts, compile_and_run, ['']) test('ann_frame002', ann_frame_opts, compile_and_run, ['']) test('ann_frame003', ann_frame_opts, compile_and_run, ['']) test('ann_frame004', ann_frame_opts, compile_and_run, ['']) +test('ann_frame005', ann_frame_opts, compile_and_run, ['']) ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs ===================================== @@ -0,0 +1,73 @@ +import Control.Concurrent.STM +import Control.Exception +import Control.Exception.Backtrace (BacktraceMechanism(IPEBacktrace), setBacktraceMechanismState) +import Control.Exception.Context (displayExceptionContext) +import Control.Monad +import Data.List (isInfixOf) +import TestUtils + +data SimpleBoom = SimpleBoom deriving (Show) + +instance Exception SimpleBoom + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + mapM_ (uncurry runCase) + [ ("throwIO SimpleBoom", throwIOAction) + , ("undefined", undefinedAction) + , ("error", errorAction) + , ("throwSTM", throwSTMAction) + ] + +runCase :: String -> IO () -> IO () +runCase label action = do + putStrLn ("=== " ++ label ++ " ===") + annotateCallStackIO $ + annotateStackStringIO ("catch site for " ++ label) $ + catch action (handler label) + +throwIOAction :: IO () +throwIOAction = + annotateStackStringIO "raising action" $ + annotateStackStringIO "throwIO SimpleBoom" $ + throwIO SimpleBoom + +undefinedAction :: IO () +undefinedAction = + annotateStackStringIO "raising undefined action" $ + void $ + evaluate $ + annotateStackString "undefined thunk" (undefined :: Int) + +errorAction :: IO () +errorAction = + annotateStackStringIO "raising error action" $ + void $ + evaluate $ + annotateStackString "error thunk" (error "error from annotateStackString" :: Int) + +throwSTMAction :: IO () +throwSTMAction = + annotateStackStringIO "raising throwSTM action" $ + atomically $ + annotateStackString "throwSTM SimpleBoom" $ + throwSTM SimpleBoom + +handler :: String -> SomeException -> IO () +handler label se = + annotateStackStringIO ("handler for " ++ label) $ + annotateStackStringIO ("forcing SomeException for " ++ label) $ do + message <- evaluate (displayException se) + putStrLn ("Caught exception: " ++ message) + let ctx = displayExceptionContext (someExceptionContext se) + ctxLines = lines ctx + putStrLn "Exception context:" + case ctxLines of + [] -> putStrLn "<empty>" + ls -> mapM_ (putStrLn . ("- " ++)) ls + let handlerTag = "handler for " ++ label + -- Check that the callstack is from the callsite, not the handling site + when (any (handlerTag `isInfixOf`) ctxLines) $ + error $ "handler annotation leaked into context for " ++ label + putStrLn "Handler annotation not present in context" ===================================== libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout ===================================== @@ -0,0 +1,45 @@ +=== throwIO SimpleBoom === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- throwIO SimpleBoom +- raising action +- catch site for throwIO SimpleBoom +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- throwIO, called at ann_frame005.hs:34:7 in main:Main +Handler annotation not present in context +=== undefined === +Caught exception: Prelude.undefined +Exception context: +- IPE backtrace: +- undefined thunk +- raising undefined action +- catch site for undefined +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- undefined, called at ann_frame005.hs:41:48 in main:Main +Handler annotation not present in context +=== error === +Caught exception: error from annotateStackString +Exception context: +- IPE backtrace: +- error thunk +- raising error action +- catch site for error +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- error, called at ann_frame005.hs:48:44 in main:Main +Handler annotation not present in context +=== throwSTM === +Caught exception: SimpleBoom +Exception context: +- IPE backtrace: +- raising throwSTM action +- catch site for throwSTM +- annotateCallStackIO, called at ann_frame005.hs:26:3 in main:Main +- HasCallStack backtrace: +- collectExceptionAnnotation, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:170:37 in ghc-internal:GHC.Internal.Exception +- toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/STM.hs:190:26 in ghc-internal:GHC.Internal.STM +- throwSTM, called at ann_frame005.hs:55:9 in main:Main +Handler annotation not present in context ===================================== testsuite/tests/driver/T16318/Makefile ===================================== @@ -7,5 +7,5 @@ test_pe = test-package-environment T16318: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -v1 -ignore-dot-ghci -package-env $(test_pe) -e "putStrLn \"Hello\"" > out 2>&1 - C=`cat out | grep "Loaded package environment" -c` ; \ + C=`grep -c "Loaded package environment" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/driver/T18125/Makefile ===================================== @@ -9,5 +9,5 @@ T18125: "$(GHC_PKG)" field base id --simple-output > $(test_pe) "$(GHC_PKG)" field $(test_lib) id --simple-outpu >> $(test_pe) "$(TEST_HC)" $(TEST_HC_OPTS) -Wunused-packages -package-env $(test_pe) T18125.hs > out 2>&1 - C=`cat out | grep "$(test_lib)" -c` ; \ + C=`grep -c "$(test_lib)" out` ; \ if [ $$C != "1" ]; then false; fi ===================================== testsuite/tests/ghci.debugger/scripts/T8487.stdout ===================================== @@ -1,4 +1,5 @@ Breakpoint 0 activated at T8487.hs:(5,8)-(7,53) Stopped in Main.f, T8487.hs:(5,8)-(7,53) _result :: IO String = _ -ma :: Either SomeException String = Left _ +ma :: Either SomeException String = Left + (SomeException (ErrorCall ...)) ===================================== testsuite/tests/ghci.debugger/scripts/break011.stdout ===================================== @@ -4,9 +4,10 @@ HasCallStack backtrace: error, called at <interactive>:2:1 in interactive:Ghci1 Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = SomeException (ErrorCall _) -1 : main (Test7.hs:2:18-28) -2 : main (Test7.hs:2:8-29) <end of history> @@ -26,7 +27,7 @@ _exception :: SomeException = SomeException (ErrorCall "foo") *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main Stopped in <exception thrown>, <unknown> _exception :: e = _ @@ -35,5 +36,5 @@ _exception :: e = _ *** Exception: foo HasCallStack backtrace: - error, called at Test7.hs:2:18 in main:Main + error, called at Test7.hs:2:18 in interactive-session:Main ===================================== testsuite/tests/ghci.debugger/scripts/break017.stdout ===================================== @@ -1,5 +1,6 @@ "Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) Logged breakpoint at QSort.hs:6:32-34 _result :: Char -> Bool a :: Char ===================================== testsuite/tests/ghci.debugger/scripts/break025.stdout ===================================== @@ -1,3 +1,4 @@ Stopped in <exception thrown>, <unknown> -_exception :: e = _ +_exception :: e = GHC.Internal.Exception.Type.SomeException + (GHC.Internal.Exception.ErrorCall _) () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56b0585109fb60738130e6be0d2fc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a56b0585109fb60738130e6be0d2fc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] 2 commits: fix fix
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: e4500d48 by sheaf at 2026-01-26T23:46:57+01:00 fix fix - - - - - 5239e258 by sheaf at 2026-01-27T00:01:20+01:00 working? - - - - - 4 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1151,7 +1151,11 @@ lintJoinBndrType :: OutType -- Type of the body -- E.g. join j x = rhs in body -- The type of 'rhs' must be the same as the type of 'body' lintJoinBndrType body_ty bndr - | JoinPoint { joinPointArity = arity } <- idJoinPointHood bndr + | JoinPoint + { joinPointArity = arity + , joinPointType = TrueJoinPoint + -- SLD TODO: quasi join points can have intervening casts + } <- idJoinPointHood bndr , let bndr_ty = idType bndr , (bndrs, res) <- splitPiTys bndr_ty = do let msg = ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1127,7 +1127,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS - WUD adj_rhs_uds final_rhs = adjustNonRecRhs (joinPointHoodArity mb_join) $ + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] @@ -1217,7 +1217,7 @@ occAnalRec !_ lvl = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs (joinPointHoodArity mb_join) wtuds + !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -2621,7 +2621,7 @@ occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) occAnal env expr@(Lam {}) - = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail + = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail occAnalLamTail env expr occAnal env (Case scrut bndr ty alts) @@ -2749,7 +2749,7 @@ occAnalApp env (Var fun, args, ticks) -- This caused #18296 | fun `hasKey` runRWKey , [t1, t2, arg] <- args - , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg + , WUD usage arg' <- adjustNonRecRhs (JoinPoint TrueJoinPoint 1) $ occAnalLamTail env arg = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out @@ -3975,21 +3975,21 @@ lookupOccInfoByUnique (UD { ud_env = env ------------------- -- See Note [Adjusting right-hand sides] -adjustNonRecRhs :: Maybe JoinArity +adjustNonRecRhs :: JoinPointHood -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the -- AcyclicSCC case of occAnalRec. -- It returns the adjusted rhs UsageDetails combined with the body usage -adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) +adjustNonRecRhs mb_join (WTUD (TUD rhs_ja uds) rhs) = WUD (adjustTailUsage exact_join rhs uds) rhs where exact_join = - case mb_join_arity of - Nothing -> Nothing - Just ja' -> + case mb_join of + NotJoinPoint -> Nothing + JoinPoint { joinPointArity = ja', joinPointType = ty } -> if ja' == rhs_ja - then Just TrueJoinPoint + then Just ty else Nothing adjustTailUsage :: HasDebugCallStack @@ -4120,11 +4120,8 @@ decideRecJoinPointHood :: TopLevelFlag -> UsageDetails -> [CoreBndr] -> Maybe JoinPointType decideRecJoinPointHood lvl usage bndrs = do bndrsNE <- NE.nonEmpty bndrs - res <- Semi.sconcat <$> traverse ok bndrsNE -- Invariant 3: Either all are join points or none are - pprTraceM "decideRecJoinPointHood" $ - vcat [ text "bndrs:" <+> ppr bndrs - , text "res:" <+> ppr res ] - return res + -- Invariant 3: Either all are join points or none are + Semi.sconcat <$> traverse ok bndrsNE where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) @@ -4132,10 +4129,11 @@ okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Maybe JoinPointType -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. okForJoinPoint lvl bndr tail_call_info - | Just join_ty <- joinId_maybe bndr + | isJoinId bndr -- A current join point should still be one! = warnPprTrace lost_join "Lost join point" lost_join_doc $ - Just join_ty + mb_valid_join + -- NB: we might downgrade 'TrueJoinPoint' to 'QuasiJoinPoint'. | otherwise = mb_valid_join where ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -1895,7 +1895,7 @@ newPolyBndrs dest_lvl , not dest_is_top = asJoinId new_bndr join_ty - ( join_arity + length abs_vars ) + (join_arity + length abs_vars) | otherwise = new_bndr ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2088,7 +2088,7 @@ simplNonRecJoinPoint env bndr rhs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case - | Just TrueJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) + | Just TrueJoinPoint <- joinId_maybe bndr = seCaseCase env | otherwise = False @@ -2114,7 +2114,7 @@ simplRecJoinPoint env pairs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case = - if all ((== Just TrueJoinPoint) . occInfoJoinPointType_maybe . idOccInfo . fst) pairs + if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs then seCaseCase env else False @@ -2154,15 +2154,15 @@ trimJoinCont :: Id -- Used only in error message trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont - | QuasiJoinPoint <- join_ty - -- SLD TODO - = cont - | otherwise = trim arity cont where trim 0 cont@(Stop {}) = cont trim 0 cont + | QuasiJoinPoint <- join_ty + -- SLD TODO explain + = cont + | otherwise = mkBoringStop (contResultType cont) trim n cont@(ApplyToVal { sc_cont = k }) = cont { sc_cont = trim (n-1) k } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3ef7ffcc6418ab11ba039915f9951… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a3ef7ffcc6418ab11ba039915f9951… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26834] 2 commits: Delete unecessary GHC.Internal.Data.Ix
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed to branch wip/T26834 at Glasgow Haskell Compiler / GHC Commits: ffdda2af by Teo Camarasu at 2026-01-26T22:06:19+00:00 Delete unecessary GHC.Internal.Data.Ix - - - - - 2a1f0bdc by Teo Camarasu at 2026-01-26T22:22:43+00:00 ghc-internal: refine List imports - - - - - 17 changed files: - libraries/base/src/Data/Ix.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs - libraries/ghc-internal/src/GHC/Internal/Data/Data.hs - − libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs - libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs - libraries/ghc-internal/src/GHC/Internal/Data/String.hs - libraries/ghc-internal/src/GHC/Internal/Data/Version.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc - libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc - libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/ghc-internal/src/GHC/Internal/Windows.hs Changes: ===================================== libraries/base/src/Data/Ix.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- | -- @@ -42,4 +42,4 @@ module Data.Ix -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. ) where -import GHC.Internal.Data.Ix +import GHC.Internal.Ix ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -153,7 +153,6 @@ Library GHC.Internal.Data.Functor.Identity GHC.Internal.Data.Functor.Utils GHC.Internal.Data.IORef - GHC.Internal.Data.Ix GHC.Internal.Data.List GHC.Internal.Data.List.NonEmpty GHC.Internal.Data.Maybe ===================================== libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Internal.Data.Proxy --import qualified Data.List.NonEmpty as NE import GHC.Internal.Generics import qualified GHC.Internal.Data.List.NonEmpty as NE -import qualified GHC.Internal.Data.List as List +import qualified GHC.Internal.List as List import GHC.Internal.Data.Maybe import GHC.Internal.Data.Tuple --import Prelude ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Data.hs ===================================== @@ -117,7 +117,7 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Monoid import GHC.Internal.Data.NonEmpty ( NonEmpty(..) ) import GHC.Internal.Data.Ord -import GHC.Internal.Data.List (findIndex) +import GHC.Internal.Data.OldList (findIndex) import GHC.Internal.Data.Typeable import GHC.Internal.Data.Version( Version(..) ) import GHC.Internal.Base hiding (Any, IntRep, FloatRep, NonEmpty(..)) ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ix.hs deleted ===================================== @@ -1,64 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.Internal.Data.Ix --- 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 'Ix' class is used to map a contiguous subrange of values in --- type onto integers. It is used primarily for array indexing --- (see the array package). 'Ix' uses row-major order. --- ------------------------------------------------------------------------------ - -module GHC.Internal.Data.Ix - ( - -- * The 'Ix' class - Ix - ( range - , index - , inRange - , rangeSize - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- * Deriving Instances of 'Ix' - -- | Derived instance declarations for the class 'Ix' are only possible - -- for enumerations (i.e. datatypes having only nullary constructors) - -- and single-constructor datatypes, including arbitrarily large tuples, - -- whose constituent types are instances of 'Ix'. - -- - -- * For an enumeration, the nullary constructors are assumed to be - -- numbered left-to-right with the indices being 0 to n-1 inclusive. This - -- is the same numbering defined by the 'Enum' class. For example, given - -- the datatype: - -- - -- > data Colour = Red | Orange | Yellow | Green | Blue | Indigo | Violet - -- - -- we would have: - -- - -- > range (Yellow,Blue) == [Yellow,Green,Blue] - -- > index (Yellow,Blue) Green == 1 - -- > inRange (Yellow,Blue) Red == False - -- - -- * For single-constructor datatypes, the derived instance declarations - -- are as shown for tuples in chapter 19, section 2 of the Haskell 2010 report: - -- <https://www.haskell.org/onlinereport/haskell2010/haskellch19.html>. - - ) where - -import GHC.Internal.Ix ===================================== libraries/ghc-internal/src/GHC/Internal/Data/List/NonEmpty.hs ===================================== @@ -8,7 +8,7 @@ module GHC.Internal.Data.List.NonEmpty ) where import GHC.Internal.Data.NonEmpty (NonEmpty (..), map) -import qualified GHC.Internal.Data.List as List +import qualified GHC.Internal.List as List -- | The 'zip' function takes two streams and returns a stream of -- corresponding pairs. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/String.hs ===================================== @@ -35,7 +35,7 @@ module GHC.Internal.Data.String ( import GHC.Internal.Base import GHC.Internal.Data.Functor.Const (Const (Const)) import GHC.Internal.Data.Functor.Identity (Identity (Identity)) -import GHC.Internal.Data.List (lines, words, unlines, unwords) +import GHC.Internal.Data.OldList (lines, words, unlines, unwords) -- | `IsString` is used in combination with the @-XOverloadedStrings@ -- language extension to convert the literals to different string types. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Version.hs ===================================== @@ -40,7 +40,7 @@ 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.OldList ( map, sort, concat, concatMap, intersperse, (++) ) import GHC.Internal.Data.Ord import GHC.Internal.Data.String ( String ) import GHC.Internal.Base ( Applicative(..) ) ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc ===================================== @@ -103,7 +103,7 @@ import GHC.Internal.IORef import GHC.Internal.Maybe import GHC.Internal.Ptr import GHC.Internal.Word -import GHC.Internal.Data.OldList (deleteBy) +import GHC.Internal.List (deleteBy) import qualified GHC.Internal.Event.Array as A import GHC.Internal.Base import GHC.Internal.Conc.Bound ===================================== libraries/ghc-internal/src/GHC/Internal/ExecutionStack/Internal.hsc ===================================== @@ -39,7 +39,7 @@ module GHC.Internal.ExecutionStack.Internal ( import GHC.Internal.Data.Functor import GHC.Internal.Data.Maybe -import GHC.Internal.Data.List (reverse, null) +import GHC.Internal.List (reverse, null) import GHC.Internal.Word import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.String (peekCString, CString) ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Encoding/CodePage.hs ===================================== @@ -30,7 +30,7 @@ import GHC.Internal.IO.Encoding.Types import GHC.Internal.IO.Buffer import GHC.Internal.Data.Bits import GHC.Internal.Data.Maybe -import GHC.Internal.Data.OldList (lookup) +import GHC.Internal.List (lookup) import qualified GHC.Internal.IO.Encoding.CodePage.API as API import GHC.Internal.IO.Encoding.CodePage.Table ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Internal.Control.Exception import GHC.Internal.Data.Foldable (Foldable(..)) import GHC.Internal.Base import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.List (filter, unlines, concat, reverse) +import GHC.Internal.Data.OldList (filter, unlines, concat, reverse) import GHC.Internal.Text.Show (show) import GHC.Internal.System.Environment (getArgs) import GHC.Internal.System.Exit (exitFailure) ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs ===================================== @@ -36,7 +36,7 @@ import GHC.Internal.Num import GHC.Internal.Data.Bits import GHC.Internal.Data.Functor import GHC.Internal.Data.Maybe (catMaybes) -import GHC.Internal.Data.List +import GHC.Internal.List import GHC.Internal.Data.Tuple import GHC.Internal.Foreign.Ptr import GHC.Internal.Foreign.Storable ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/Blank.hsc ===================================== @@ -40,14 +40,14 @@ module GHC.Internal.System.Environment.Blank ) where import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (elem, null, takeWhile) +import GHC.Internal.List (elem, null, takeWhile) import GHC.Internal.Foreign.C.String import GHC.Internal.Base #if defined(mingw32_HOST_OS) import GHC.Internal.Foreign.Ptr import GHC.Internal.Windows import GHC.Internal.Control.Monad -import GHC.Internal.Data.List (lookup) +import GHC.Internal.List (lookup) #else import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.Types ===================================== libraries/ghc-internal/src/GHC/Internal/System/Environment/ExecutablePath.hsc ===================================== @@ -53,7 +53,7 @@ import GHC.Internal.System.IO.Error (isDoesNotExistError) import GHC.Internal.System.Posix.Internals #elif defined(linux_HOST_OS) || defined(gnu_HOST_OS) import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (isSuffixOf) +import GHC.Internal.Data.OldList (isSuffixOf) import GHC.Internal.Foreign.C.Types import GHC.Internal.Foreign.C.Error import GHC.Internal.Foreign.C.String @@ -85,7 +85,7 @@ import GHC.Internal.System.Posix.Internals import GHC.Internal.Control.Exception import GHC.Internal.Control.Monad.Fail import GHC.Internal.Data.Functor -import GHC.Internal.Data.List (isPrefixOf, drop) +import GHC.Internal.OldList (isPrefixOf, drop) import GHC.Internal.Word import GHC.Internal.Foreign.C.String import GHC.Internal.Foreign.Marshal.Array ===================================== libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs ===================================== @@ -70,7 +70,7 @@ import GHC.Internal.Foreign.Storable import qualified GHC.Internal.Foreign.C.String.Encoding as GHC #else import GHC.Internal.Int -import GHC.Internal.Data.OldList (elem) +import GHC.Internal.List (elem) #endif -- --------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Windows.hs ===================================== @@ -80,7 +80,7 @@ module GHC.Internal.Windows ( import GHC.Internal.Data.Bits (finiteBitSize, shiftL, shiftR, (.|.), (.&.)) import GHC.Internal.Unicode (isSpace) -import GHC.Internal.Data.OldList +import GHC.Internal.List import GHC.Internal.Data.Maybe import GHC.Internal.Word import GHC.Internal.Int View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966bd642640e2ccd17bbe43f2f5145… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/966bd642640e2ccd17bbe43f2f5145… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] WIP try harder
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: a3ef7ffc by sheaf at 2026-01-26T23:12:26+01:00 WIP try harder - - - - - 5 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Types/Id/Info.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -915,7 +915,7 @@ lintCoreExpr (Lit lit) ; return (literalType lit, zeroUE) } lintCoreExpr (Cast expr co) - = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) + = do { (expr_ty, ue) <- lintCoreExpr expr -- SLD TODO markAllJoinsBad (lintCoreExpr expr) -- markAllJoinsBad: see Note [Join points and casts] ; lintCoercion co @@ -1146,7 +1146,7 @@ checkDeadIdOcc id ------------------ lintJoinBndrType :: OutType -- Type of the body -> OutId -- Possibly a join Id - -> LintM () + -> LintM () -- Checks that the return type of a join Id matches the body -- E.g. join j x = rhs in body -- The type of 'rhs' must be the same as the type of 'body' ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) -import GHC.Data.Maybe( orElse ) +import GHC.Data.Maybe( orElse, isNothing ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) , stronglyConnCompFromEdgedVerticesUniq , stronglyConnCompFromEdgedVerticesUniqR ) @@ -68,6 +68,7 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi {- @@ -2299,7 +2300,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllNonTail usage2 -- SLD TODO + usage3 = markAllQuasiTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2612,7 +2613,7 @@ occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllNonTail usage1 -- SLD TODO + usage2 = markAllQuasiTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -3985,20 +3986,31 @@ adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) where exact_join = case mb_join_arity of - Nothing -> False - Just ja' -> ja' == rhs_ja - -adjustTailUsage :: Bool -- True <=> Exactly-matching join point; don't do markNonTail + Nothing -> Nothing + Just ja' -> + if ja' == rhs_ja + then Just TrueJoinPoint + else Nothing + +adjustTailUsage :: HasDebugCallStack + => Maybe JoinPointType -> CoreExpr -- Rhs usage, AFTER occAnalLamTail -> UsageDetails -> UsageDetails -adjustTailUsage exact_join rhs uds +adjustTailUsage mb_join rhs uds = -- c.f. occAnal (Lam {}) markAllInsideLamIf (not one_shot) $ - markAllNonTailIf (not exact_join) $ + mb_mark_nontail $ uds where - one_shot = isOneShotFun rhs + one_shot = isOneShotFun rhs + mb_mark_nontail = + case mb_join of + Nothing -> markAllNonTail + Just join_ty -> + case join_ty of + QuasiJoinPoint -> markAllQuasiTail + TrueJoinPoint -> id adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf not_same_arity usage @@ -4036,11 +4048,8 @@ tagNonRecBinder :: TopLevelFlag -- At top level? -- No-op on TyVars -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr - | okForJoinPoint lvl bndr tail_call_info - , AlwaysTailCalled - { tailCallArity = ar - , tailCallJoinPointType = join_ty - } <- tail_call_info + | Just join_ty <- okForJoinPoint lvl bndr tail_call_info + , AlwaysTailCalled { tailCallArity = ar } <- tail_call_info = (setBinderOcc occ bndr, JoinPoint join_ty ar) | otherwise = (setBinderOcc zapped_occ bndr, NotJoinPoint) @@ -4070,7 +4079,7 @@ tagRecBinders lvl body_uds details_s = assertPpr (rhs_ja == joinRhsArity rhs) (ppr rhs_ja $$ ppr uds $$ ppr rhs) $ uds - will_be_joins :: Bool + will_be_joins :: Maybe JoinPointType will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs -- 2. Adjust usage details of each RHS, taking into account the @@ -4108,42 +4117,50 @@ setBinderOcc occ_info bndr -- -- See Note [Invariants on join points] in "GHC.Core". decideRecJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] -> Bool -decideRecJoinPointHood lvl usage bndrs - = all ok bndrs -- Invariant 3: Either all are join points or none are + -> [CoreBndr] -> Maybe JoinPointType +decideRecJoinPointHood lvl usage bndrs = do + bndrsNE <- NE.nonEmpty bndrs + res <- Semi.sconcat <$> traverse ok bndrsNE -- Invariant 3: Either all are join points or none are + pprTraceM "decideRecJoinPointHood" $ + vcat [ text "bndrs:" <+> ppr bndrs + , text "res:" <+> ppr res ] + return res where ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) -okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool +okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Maybe JoinPointType -- See Note [Invariants on join points]; invariants cited by number below. -- Invariant 2 is always satisfiable by the simplifier by eta expansion. okForJoinPoint lvl bndr tail_call_info - | isJoinId bndr -- A current join point should still be one! + | Just join_ty <- joinId_maybe bndr + -- A current join point should still be one! = warnPprTrace lost_join "Lost join point" lost_join_doc $ - True - | valid_join - = True + Just join_ty | otherwise - = False + = mb_valid_join where - valid_join | NotTopLevel <- lvl - , AlwaysTailCalled { tailCallArity = arity } <- tail_call_info - - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - - -- Invariant 2a: stable unfoldings - -- See Note [Join points and INLINE pragmas] - , ok_unfolding arity (realIdUnfolding bndr) - - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - | otherwise - = False + mb_valid_join + | NotTopLevel <- lvl + , AlwaysTailCalled + { tailCallArity = arity + , tailCallJoinPointType = join_ty + } <- tail_call_info + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = Just join_ty + | otherwise + = Nothing lost_join | JoinPoint { joinPointArity = ja } <- idJoinPointHood bndr - = not valid_join || + = isNothing mb_valid_join || (case tail_call_info of -- Valid join but arity differs AlwaysTailCalled { tailCallArity = ja' } -> ja /= ja' _ -> False) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2056,6 +2056,17 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont of a SpecConstr-generated RULE for a join point. -} +-- SLD TODO horrible logic that must be removed +peelJoinResTy :: Int -> Type -> Type +peelJoinResTy 0 ty = ty +peelJoinResTy n ty + | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty + = peelJoinResTy n inner_ty + | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty + = peelJoinResTy (n-1) res_ty + | otherwise + = ty + simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2064,8 +2075,12 @@ simplNonRecJoinPoint env bndr rhs body cont wrapJoinCont do_case_case env cont $ \ env cont -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing - ; let mult = contHoleScaling cont - res_ty = contResultType cont + ; let (mult, res_ty) + -- SLD TODO + | Just QuasiJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) + = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr)) + | otherwise + = (contHoleScaling cont, contResultType cont) ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) @@ -2084,8 +2099,13 @@ simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] simplRecJoinPoint env pairs body cont = wrapJoinCont do_case_case env cont $ \ env cont -> do { let bndrs = map fst pairs - mult = contHoleScaling cont - res_ty = contResultType cont + (mult, res_ty) + -- SLD TODO + | [b] <- bndrs + , Just QuasiJoinPoint <- occInfoJoinPointType_maybe (idOccInfo b) + = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b)) + | otherwise + = (contHoleScaling cont, contResultType cont) ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -2135,7 +2155,7 @@ trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont | QuasiJoinPoint <- join_ty - -- As per Note [Quasi join points], don't do any trimming for quasi join points. + -- SLD TODO = cont | otherwise = trim arity cont ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -214,7 +214,7 @@ newJoinId bndrs body_ty -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs details = JoinId - { joinIdType = TrueJoinPoint -- SLD TODO this is very suspicious + { joinIdType = TrueJoinPoint -- SLD TODO this is suspicious , joinIdArity = join_arity , joinIdCbvMarks = Nothing } ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -441,7 +441,7 @@ pprIdDetails other = brackets (pp other) pp CoVarId = text "CoVarId" pp (JoinId ty arity marks) = quasi <> text "JoinId" <> parens (int arity) <> parens (ppr marks) where - quasi = case ty of { QuasiJoinPoint -> text "quasi"; TrueJoinPoint -> empty } + quasi = case ty of { QuasiJoinPoint -> text "Quasi"; TrueJoinPoint -> empty } {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ef7ffcc6418ab11ba039915f99513… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ef7ffcc6418ab11ba039915f99513… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26834
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

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

1 0

[Git][ghc/ghc][wip/T26832] 2 commits: ghc-internal: move considerAccessible to GHC.Internal.Magic
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

Teo Camarasu pushed to branch wip/T26832 at Glasgow Haskell Compiler / GHC Commits: 23516844 by Teo Camarasu at 2026-01-26T20:42:39+00:00 ghc-internal: move considerAccessible to GHC.Internal.Magic Previously it lived in GHC.Internal.Exts, but it really deserves to live along with the other magic function, which are already re-exported from .Exts - - - - - f5cee207 by Teo Camarasu at 2026-01-26T20:51:24+00:00 ghc-internal: move maxTupleSize to GHC.Internal.Tuple This previously lived in GHC.Internal.Exts but a comment already said it should be moved to .Tuple - - - - - 4 changed files: - compiler/GHC/Builtin/Names.hs - libraries/ghc-internal/src/GHC/Internal/Exts.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Tuple.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1063,7 +1063,7 @@ alternativeClassKey = mkPreludeMiscIdUnique 754 -- Functions for GHC extensions considerAccessibleName :: Name -considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey +considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") considerAccessibleIdKey -- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, ===================================== libraries/ghc-internal/src/GHC/Internal/Exts.hs ===================================== @@ -321,10 +321,7 @@ import GHC.Internal.Data.Data import GHC.Internal.Data.Ord import qualified GHC.Internal.Debug.Trace import GHC.Internal.Unsafe.Coerce ( unsafeCoerce# ) -- just for re-export - --- XXX This should really be in Data.Tuple, where the definitions are -maxTupleSize :: Int -maxTupleSize = 64 +import GHC.Internal.Tuple (maxTupleSize) -- | 'the' ensures that all the elements of the list are identical -- and then returns that unique element @@ -444,27 +441,3 @@ resizeSmallMutableArray# arr0 szNew a s0 = (# s2, arr1 #) -> case copySmallMutableArray# arr0 0# arr1 0# szOld s2 of s3 -> (# s3, arr1 #) else (# s1, arr0 #) - --- | Semantically, @considerAccessible = True@. But it has special meaning --- to the pattern-match checker, which will never flag the clause in which --- 'considerAccessible' occurs as a guard as redundant or inaccessible. --- Example: --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) -> 3 -- Warning: redundant --- --- The pattern-match checker will warn here that the third clause is redundant. --- It will stop doing so if the clause is adorned with 'considerAccessible': --- --- > case (x, x) of --- > (True, True) -> 1 --- > (False, False) -> 2 --- > (True, False) | considerAccessible -> 3 -- No warning --- --- Put 'considerAccessible' as the last statement of the guard to avoid get --- confusing results from the pattern-match checker, which takes \"consider --- accessible\" by word. -considerAccessible :: Bool -considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -24,7 +24,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..), considerAccessible ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -34,7 +34,7 @@ module GHC.Internal.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(. -- because TYPE is not exported by the source Haskell module generated by -- genprimops which Haddock will typecheck (#15935). import GHC.Internal.Prim (State#, realWorld#, RealWorld, Int#) -import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint) +import GHC.Internal.Types (RuntimeRep(BoxedRep), TYPE, Levity, Constraint, Bool(True)) -- | The call @inline f@ arranges that @f@ is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the @@ -137,3 +137,27 @@ type DataToTag :: forall {lev :: Levity}. TYPE (BoxedRep lev) -> Constraint -- So it does not get its own Unsafe module, unlike WithDict. class DataToTag a where dataToTag# :: a -> Int# + +-- | Semantically, @considerAccessible = True@. But it has special meaning +-- to the pattern-match checker, which will never flag the clause in which +-- 'considerAccessible' occurs as a guard as redundant or inaccessible. +-- Example: +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) -> 3 -- Warning: redundant +-- +-- The pattern-match checker will warn here that the third clause is redundant. +-- It will stop doing so if the clause is adorned with 'considerAccessible': +-- +-- > case (x, x) of +-- > (True, True) -> 1 +-- > (False, False) -> 2 +-- > (True, False) | considerAccessible -> 3 -- No warning +-- +-- Put 'considerAccessible' as the last statement of the guard to avoid get +-- confusing results from the pattern-match checker, which takes \"consider +-- accessible\" by word. +considerAccessible :: Bool +considerAccessible = True ===================================== libraries/ghc-internal/src/GHC/Internal/Tuple.hs ===================================== @@ -27,10 +27,11 @@ module GHC.Internal.Tuple ( Tuple40(..), Tuple41(..), Tuple42(..), Tuple43(..), Tuple44(..), Tuple45(..), Tuple46(..), Tuple47(..), Tuple48(..), Tuple49(..), Tuple50(..), Tuple51(..), Tuple52(..), Tuple53(..), Tuple54(..), Tuple55(..), Tuple56(..), Tuple57(..), Tuple58(..), Tuple59(..), Tuple60(..), Tuple61(..), Tuple62(..), Tuple63(..), Tuple64(..), + maxTupleSize, ) where -- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base -import GHC.Internal.Types () +import GHC.Internal.Types (Int) default () -- Double and Integer aren't available yet @@ -598,3 +599,6 @@ data Tuple64 a b c d e f g h i j k l m n o p q r s t u v w x y z a1 b1 c1 d1 e1 r1 s1 t1 u1 v1 w1 x1 y1 z1 a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a1,b1,c1,d1,e1,f1,g1,h1,i1,j1,k1,l1,m1,n1,o1,p1,q1, r1,s1,t1,u1,v1,w1,x1,y1,z1,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) + +maxTupleSize :: Int +maxTupleSize = 64 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af41951a5efa750a9dad9ba877ef0d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/af41951a5efa750a9dad9ba877ef0d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/ticked_joins] WIP: give up on casts
by sheaf (＠sheaf) 26 Jan '26

26 Jan '26

sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: f84e5d95 by sheaf at 2026-01-26T21:49:00+01:00 WIP: give up on casts - - - - - 3 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -2299,7 +2299,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllQuasiTail usage2 -- SLD TODO + usage3 = markAllNonTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2602,6 +2602,7 @@ occAnal env (Tick tickish body) | Breakpoint _ _ ids <- tickish = -- Never substitute for any of the Ids in a Breakpoint addManyOccs usage_lam (mkVarSet ids) + | otherwise = usage_lam @@ -2611,7 +2612,7 @@ occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllQuasiTail usage1 -- SLD TODO + usage2 = markAllNonTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -2748,7 +2749,6 @@ occAnalApp env (Var fun, args, ticks) | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg - -- SLD TODO TrueJoinPoint OK here?? = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2135,7 +2135,7 @@ trimJoinCont _ NotJoinPoint cont = cont -- Not a jump trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont | QuasiJoinPoint <- join_ty - -- SLD TODO: not sure why we can end up here. Needs further investigation. + -- As per Note [Quasi join points], don't do any trimming for quasi join points. = cont | otherwise = trim arity cont ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -214,7 +214,7 @@ newJoinId bndrs body_ty -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core join_arity = length bndrs details = JoinId - { joinIdType = TrueJoinPoint + { joinIdType = TrueJoinPoint -- SLD TODO this is very suspicious , joinIdArity = join_arity , joinIdCbvMarks = Nothing } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84e5d955ab9a3233b5ad30a61310b0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f84e5d955ab9a3233b5ad30a61310b0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26832
by Teo Camarasu (＠teo) 26 Jan '26

26 Jan '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/ghc-desugar-removal
by Wolfgang Jeltsch (＠jeltsch) 26 Jan '26

26 Jan '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/ghc-desugar-removal at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/ghc-desugar-removal You're receiving this email because of your account on gitlab.haskell.org.

1 0