Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 86a646a6 by Andreas Klebinger at 2026-04-22T13:00:05-04:00 Revert use of generic instances for compiler time perf reasons. Revert "Derive Semigroup/Monoid for instances believed could be derived in #25871" This reverts commit 11a04cbb221cc404fe00d65d7c951558ede4caa9. Revert "add Ghc.Data.Pair deriving" This reverts commit 15d9ce449e1be8c01b89fd39bdf1e700ea7d1dce. - - - - - 10 changed files: - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Data/Pair.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Types/Unique/DSet.hs - compiler/GHC/Utils/Ppr/Colour.hs Changes: ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -2,8 +2,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} ----------------------------------------------------------------------------- -- @@ -74,8 +72,6 @@ import GHC.Cmm.CLabel import GHC.Types.Tickish ( GenTickish(..) ) import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -import GHC.Generics (Generic, Generically(..)) - -- The rest: import GHC.Data.Maybe ( expectJust ) import GHC.Types.ForeignCall ( CCallConv(..) ) @@ -440,7 +436,7 @@ getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg getRegisterReg platform (CmmGlobal mid) = case globalRegMaybe platform $ globalRegUse_reg mid of - Just reg -> RegReal reg + Just reg -> RegReal $ reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this @@ -4936,8 +4932,11 @@ data LoadArgs -- | The code to assign arguments to registers used for argument passing. , assignArgsCode :: InstrBlock } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically LoadArgs +instance Semigroup LoadArgs where + LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2 + = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2) +instance Monoid LoadArgs where + mempty = LoadArgs [] [] [] nilOL -- | An argument passed on the stack, either directly or by reference. -- ===================================== compiler/GHC/CmmToLlvm/CodeGen.hs ===================================== @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -- | Handle conversion of CmmProc to LLVM code. module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where @@ -31,8 +29,6 @@ import GHC.Data.FastString import GHC.Data.Maybe (expectJust) import GHC.Data.OrdList -import GHC.Generics (Generic, Generically(..)) - import GHC.Types.ForeignCall import GHC.Types.Unique.DSM import GHC.Types.Unique @@ -52,6 +48,7 @@ import Data.List ( nub ) import qualified Data.List as List import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import Data.Maybe ( catMaybes ) +import qualified Data.Semigroup as Semigroup type Atomic = Maybe MemoryOrdering type LlvmStatements = OrdList LlvmStatement @@ -2478,8 +2475,14 @@ getTBAARegMeta = getTBAAMeta . getTBAA -- | A more convenient way of accumulating LLVM statements and declarations. data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] - deriving (Generic) - deriving (Monoid, Semigroup) via Generically LlvmAccum + +instance Semigroup LlvmAccum where + LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = + LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) + +instance Monoid LlvmAccum where + mempty = LlvmAccum nilOL [] + mappend = (Semigroup.<>) liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar liftExprData action = do ===================================== compiler/GHC/Data/Pair.hs ===================================== @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} - {- A simple homogeneous pair type with useful Functor, Applicative, and Traversable instances. @@ -23,12 +20,8 @@ import GHC.Prelude import GHC.Utils.Outputable import qualified Data.Semigroup as Semi -import GHC.Generics (Generic, Generically(..)) - data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Foldable, Functor, Traversable, Generic) - deriving (Semigroup, Monoid) via Generically (Pair a) - + deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -40,6 +33,13 @@ instance Applicative Pair where pure x = Pair x x (Pair f g) <*> (Pair x y) = Pair (f x) (g y) +instance Semi.Semigroup a => Semi.Semigroup (Pair a) where + Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) + +instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where + mempty = Pair mempty mempty + mappend = (Semi.<>) + instance Outputable a => Outputable (Pair a) where ppr (Pair a b) = ppr a <+> char '~' <+> ppr b ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -1,8 +1,8 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} + {-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId {- @@ -117,7 +117,6 @@ import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithModifiers ) import GHC.Hs.Doc -import GHC.Generics (Generic, Generically(..)) import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -233,8 +232,6 @@ data HsTyPatRnBuilder = hstpb_imp_tvs :: Bag Name, hstpb_exp_tvs :: Bag Name } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically HsTyPatRnBuilder tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name} @@ -246,6 +243,16 @@ tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} = hstpb_imp_tvs = listToBag hsps_imp_tvs } +instance Semigroup HsTyPatRnBuilder where + HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 = + HsTPRnB + (nwcs1 `unionBags` nwcs2) + (imp_tvs1 `unionBags` imp_tvs2) + (exptvs1 `unionBags` exptvs2) + +instance Monoid HsTyPatRnBuilder where + mempty = HsTPRnB emptyBag emptyBag emptyBag + buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} = HsTPRn { ===================================== compiler/GHC/HsToCore/Pmc.hs ===================================== @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} - -- | This module coverage checks pattern matches. It finds -- -- * Uncovered patterns, certifying non-exhaustivity @@ -66,7 +63,6 @@ import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag import GHC.Data.OrdList -import GHC.Generics (Generic, Generically(..)) import Control.Monad (when, forM_) import qualified Data.Semigroup as Semi @@ -468,8 +464,13 @@ data CIRB , cirb_red :: !(OrdList SrcInfo) -- ^ Redundant clauses , cirb_bangs :: !(OrdList SrcInfo) -- ^ Redundant bang patterns } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically CIRB + +instance Semigroup CIRB where + CIRB a b c d <> CIRB e f g h = CIRB (a <> e) (b <> f) (c <> g) (d <> h) + where (<>) = (Semi.<>) + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty -- See Note [Determining inaccessible clauses] ensureOneNotRedundant :: CIRB -> CIRB ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -2,8 +2,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement @@ -71,7 +69,6 @@ import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational , FractionalExponentBase(..)) -import GHC.Generics (Generic, Generically(..)) import Numeric (fromRat) import Data.Ratio @@ -108,13 +105,19 @@ instance Outputable Nabla where -- | A disjunctive bag of 'Nabla's, representing a refinement type. newtype Nablas = MkNablas (Bag Nabla) - -- deriving 'Outputable' removes `MkNablas` label - deriving (Generic, Outputable) - deriving (Semigroup, Monoid) via Generically Nablas initNablas :: Nablas initNablas = MkNablas (unitBag initNabla) +instance Outputable Nablas where + ppr (MkNablas nablas) = ppr nablas + +instance Semigroup Nablas where + MkNablas l <> MkNablas r = MkNablas (l `unionBags` r) + +instance Monoid Nablas where + mempty = MkNablas emptyBag + -- | The type oracle state. An 'GHC.Tc.Solver.Monad.InertSet' that we -- incrementally add local type constraints to, together with a sequence -- number that counts the number of times we extended it with new facts. ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -1,5 +1,4 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeFamilies #-} @@ -62,7 +61,6 @@ import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types -import GHC.Generics (Generic, Generically(..)) import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>)) import qualified GHC.Data.Strict as Strict @@ -1349,8 +1347,13 @@ data LocRange = { loc_range_from :: !LowerLocBound, loc_range_to :: !UpperLocBound, loc_range_col :: !ColumnBound } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically LocRange + +instance Semigroup LocRange where + LocRange from1 to1 col1 <> LocRange from2 to2 col2 = + LocRange (from1 <> from2) (to1 <> to2) (col1 <> col2) + +instance Monoid LocRange where + mempty = LocRange mempty mempty mempty -- The location range from the specified position to the end of the file. locRangeFrom :: Strict.Maybe BufPos -> LocRange ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -1,8 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- @@ -147,13 +145,13 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) -import GHC.Generics (Generic, Generically(..)) - import Control.Monad import Data.IORef import GHC.Data.Maybe import GHC.Types.Name.Reader +import qualified Data.Semigroup as Semi + {- ************************************************************************ * * @@ -1281,8 +1279,17 @@ data CandidatesQTvs -- These are covars. Included only so that we don't repeatedly -- look at covars' kinds in accumulator. Not used by quantifyTyVars. } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically CandidatesQTvs + +instance Semi.Semigroup CandidatesQTvs where + (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) + <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) + = DV { dv_kvs = kv1 `unionDVarSet` kv2 + , dv_tvs = tv1 `unionDVarSet` tv2 + , dv_cvs = cv1 `unionVarSet` cv2 } + +instance Monoid CandidatesQTvs where + mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } + mappend = (Semi.<>) instance Outputable CandidatesQTvs where ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) ===================================== compiler/GHC/Types/Unique/DSet.hs ===================================== @@ -44,7 +44,6 @@ import GHC.Types.Unique import Data.Coerce import Data.Data -import Data.Semigroup -- See Note [UniqSet invariant] in GHC.Types.Unique.Set for why we want a newtype here. -- Beyond preserving invariants, we may also want to 'override' typeclass @@ -155,9 +154,3 @@ instance Outputable a => Outputable (UniqDSet a) where pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList - -instance Semigroup (UniqDSet a) where - (<>) = unionUniqDSets - -instance Monoid (UniqDSet a) where - mempty = emptyUniqDSet ===================================== compiler/GHC/Utils/Ppr/Colour.hs ===================================== @@ -1,17 +1,21 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} - module GHC.Utils.Ppr.Colour where import GHC.Prelude.Basic import Data.Maybe (fromMaybe) import GHC.Data.Bool -import GHC.Generics (Generic, Generically(..)) +import Data.Semigroup as Semi -- | A colour\/style for use with 'coloured'. newtype PprColour = PprColour { renderColour :: String } - deriving (Generic) - deriving (Semigroup, Monoid) via Generically PprColour + +instance Semi.Semigroup PprColour where + PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + mappend = (<>) renderColourAfresh :: PprColour -> String renderColourAfresh c = renderColour (colReset `mappend` c) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86a646a6b17f38e1afee644ccd691e16... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86a646a6b17f38e1afee644ccd691e16... You're receiving this email because of your account on gitlab.haskell.org.