From 170aff53f6e26582c2cd868b5deba80520c1c09b Mon Sep 17 00:00:00 2001 From: Finley McIlwaine Date: Fri, 7 Jun 2024 14:44:17 +0200 Subject: [PATCH] Specializations --- .../src/Distribution/FieldGrammar/Newtypes.hs | 11 +++++++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 16 ++++++++++++++++ .../PackageDescription/FieldGrammar.hs | 15 +++++++++++++++ Cabal-syntax/src/Distribution/Parsec.hs | 2 ++ .../src/Distribution/Types/Dependency.hs | 1 + .../src/Distribution/Types/PackageName.hs | 1 + Cabal-syntax/src/Distribution/Types/Version.hs | 2 ++ .../Distribution/Types/VersionRange/Internal.hs | 7 +++++++ 8 files changed, 55 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index d39e77ebbeb..2baf3935726 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -57,6 +57,7 @@ import Distribution.Compiler (CompilerFlavor) import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty +import Distribution.Types.Dependency import Distribution.Utils.Path import Distribution.Version ( LowerBound (..) @@ -101,6 +102,16 @@ class Sep sep where instance Sep CommaVCat where prettySep _ = vcat . punctuate comma + {-# SPECIALIZE + parseSep + :: Proxy CommaVCat + -> ParsecParser Dependency + -> ParsecParser [Dependency] + #-} + -- Without this, inlining will beat specialization to the punch and we'll end + -- up with an overloaded worker for which the specialization rewrite rule will + -- not fire, even with -flate-specialise + {-# INLINE[2] parseSep #-} parseSep _ p = do v <- askCabalSpecVersion if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 4721aa4ad08..e80363e7ed5 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -66,6 +66,7 @@ module Distribution.FieldGrammar.Parsec , fieldLinesToStream ) where +import Distribution.Compat.Lens (ALens') import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Utils.Generic (fromUTF8BS) @@ -82,11 +83,14 @@ import qualified Text.Parsec.Error as P import Distribution.CabalSpecVersion import Distribution.FieldGrammar.Class +import Distribution.FieldGrammar.Newtypes import Distribution.Fields.Field import Distribution.Fields.ParseResult import Distribution.Parsec import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) +import Distribution.Types.Dependency +import Distribution.Types.SetupBuildInfo ------------------------------------------------------------------------------- -- Auxiliary types @@ -257,6 +261,18 @@ instance FieldGrammar Parsec ParsecFieldGrammar where | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + {-# SPECIALIZE + monoidalFieldAla + :: FieldName + -> ([Dependency] -> List CommaVCat (Identity Dependency) Dependency) + -> ALens' SetupBuildInfo [Dependency] + -> ParsecFieldGrammar SetupBuildInfo [Dependency] + #-} + + -- Without this, inlining will beat specialization to the punch and we'll end + -- up with an overloaded worker for which the specialization rewrite rule will + -- not fire, even with -flate-specialise + {-# INLINE[2] monoidalFieldAla #-} monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index db6b7f7607b..8881f78bc7b 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -157,6 +157,8 @@ packageDescriptionFieldGrammar = <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles <*> monoidalFieldAla "license-files" (alaList' FSep RelativePathNT) L.licenseFiles ^^^ hiddenField +{-# SPECIALIZE packageDescriptionFieldGrammar :: ParsecFieldGrammar' PackageDescription #-} +{-# SPECIALIZE packageDescriptionFieldGrammar :: PrettyFieldGrammar' PackageDescription #-} ------------------------------------------------------------------------------- -- Library @@ -907,3 +909,16 @@ _syntaxExtensions = | e <- [minBound .. maxBound] , e `notElem` [Safe, Unsafe, Trustworthy] ] + +-- This is tricky. We end up with overloaded calls to 'parsecCommaList' in this +-- module, particularly at types 'ParsecParser' and 'Identity Dependency' which +-- we care to specialize. We can't specialize at the definition site of this +-- function due to module cycles, so we specialize here. To do so, we have to +-- mark 'parsecCommaList' inlinable, which you'd think would cause the +-- specialization (for all specializable calls here) to happen, but they don't. +-- We need this specialize pragma to make it happen, but GHC warns that it is an +-- orphan rule. +{-# SPECIALIZE + parsecCommaList + :: ParsecParser (Identity Dependency) -> ParsecParser [Identity Dependency] + #-} diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 4c6e31e5aaa..c0d5476f3cb 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -298,6 +298,7 @@ parsecStandard f = do -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). +{-# INLINABLE parsecCommaList #-} parsecCommaList :: CabalParsing m => m a -> m [a] parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") @@ -377,6 +378,7 @@ parsecQuoted = P.between (P.char '"') (P.char '"') parsecMaybeQuoted :: CabalParsing m => m a -> m a parsecMaybeQuoted p = parsecQuoted p <|> p +{-# SPECIALIZE parsecUnqualComponentName :: ParsecParser String #-} parsecUnqualComponentName :: forall m. CabalParsing m => m String parsecUnqualComponentName = state0 DList.empty where diff --git a/Cabal-syntax/src/Distribution/Types/Dependency.hs b/Cabal-syntax/src/Distribution/Types/Dependency.hs index 10d0506b57e..98d0a65274d 100644 --- a/Cabal-syntax/src/Distribution/Types/Dependency.hs +++ b/Cabal-syntax/src/Distribution/Types/Dependency.hs @@ -139,6 +139,7 @@ instance Pretty Dependency where -- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] -- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] instance Parsec Dependency where + {-# SPECIALIZE parsec :: ParsecParser Dependency #-} parsec = do name <- parsec diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index 4cf9d1aeb59..623672d8f4b 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -70,6 +70,7 @@ instance Pretty PackageName where pretty = Disp.text . unPackageName instance Parsec PackageName where + {-# SPECIALIZE parsec :: ParsecParser PackageName #-} parsec = mkPackageName <$> parsecUnqualComponentName instance NFData PackageName where diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs index 90ad33b1048..ef72473a4ff 100644 --- a/Cabal-syntax/src/Distribution/Types/Version.hs +++ b/Cabal-syntax/src/Distribution/Types/Version.hs @@ -99,6 +99,7 @@ instance Pretty Version where ) instance Parsec Version where + {-# SPECIALIZE parsec :: ParsecParser Version #-} parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags where tags = do @@ -110,6 +111,7 @@ instance Parsec Version where -- | An integral without leading zeroes. -- -- @since 3.0 +{-# SPECIALIZE versionDigitParser :: ParsecParser Int #-} versionDigitParser :: CabalParsing m => m Int versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" where diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs index 7d7101d8660..9e1b2261ddc 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -332,6 +332,7 @@ prettyVersionRange16 vr = prettyVersionRange vr -- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] -- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] instance Parsec VersionRange where + {-# SPECIALIZE parsec :: ParsecParser VersionRange #-} parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser -- | 'VersionRange' parser parametrised by version digit parser. @@ -341,6 +342,12 @@ instance Parsec VersionRange where -- versions, 'PkgConfigVersionRange'. -- -- @since 3.0 +{-# SPECIALIZE + versionRangeParser + :: ParsecParser Int + -> CabalSpecVersion + -> ParsecParser VersionRange + #-} versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange versionRangeParser digitParser csv = expr where