[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: EPA: Introduce HasAnnotation class
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 10 02:08:12 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
94066d58 by Alan Zimmerman at 2023-10-09T21:35:53-04:00
EPA: Introduce HasAnnotation class
The class is defined as
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
This generalises noAnnSrcSpan, and allows
noLocA :: (HasAnnotation e) => a -> GenLocated e a
noLocA = L (noAnnSrcSpan noSrcSpan)
- - - - -
8792a1bc by Ben Gamari at 2023-10-09T21:36:29-04:00
Bump unix submodule to v2.8.3.0
- - - - -
6b62df36 by Sebastian Graf at 2023-10-09T22:07:38-04:00
Stricter Binary.get in GHC.Types.Unit (#23964)
I noticed some thunking while looking at Core.
This change has very modest, but throughout positive ghc/alloc effect:
```
hard_hole_fits(normal) ghc/alloc 283,057,664 281,620,872 -0.5%
geo. mean -0.1%
minimum -0.5%
maximum +0.0%
```
Fixes #23964.
- - - - -
9bea471d by doyougnu at 2023-10-09T22:07:53-04:00
ci: add javascript label rule
This adds a rule which triggers the javascript job when the "javascript"
label is assigned to an MR.
- - - - -
e37a1a3c by Matthew Craven at 2023-10-09T22:07:53-04:00
Make 'wWarningFlagsDeps' include every WarningFlag
Fixes #24071.
- - - - -
16 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Unit/Types.hs
- libraries/unix
- utils/check-exact/Orphans.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -604,6 +604,7 @@ data Rule = ReleaseOnly -- ^ Only run this job in a release pipeline
data ValidateRule =
FullCI -- ^ Run this job when the "full-ci" label is present.
| LLVMBackend -- ^ Run this job when the "LLVM backend" label is present
+ | JSBackend -- ^ Run this job when the "javascript" label is present
| FreeBSDLabel -- ^ Run this job when the "FreeBSD" label is set.
| NonmovingGc -- ^ Run this job when the "non-moving GC" label is set.
| IpeData -- ^ Run this job when the "IPE" label is set
@@ -648,11 +649,12 @@ validateRuleString FullCI = or_all ([ labelString "full-ci"
, branchStringLike "ghc-[0-9]+\\.[0-9]+"
])
-validateRuleString LLVMBackend = labelString "LLVM backend"
+validateRuleString LLVMBackend = labelString "LLVM backend"
+validateRuleString JSBackend = labelString "javascript"
validateRuleString FreeBSDLabel = labelString "FreeBSD"
-validateRuleString NonmovingGc = labelString "non-moving GC"
-validateRuleString IpeData = labelString "IPE"
-validateRuleString TestPrimops = labelString "test-primops"
+validateRuleString NonmovingGc = labelString "non-moving GC"
+validateRuleString IpeData = labelString "IPE"
+validateRuleString TestPrimops = labelString "test-primops"
-- | A 'Job' is the description of a single job in a gitlab pipeline. The
-- job contains all the information about how to do the build but can be further
@@ -1010,10 +1012,9 @@ job_groups =
, disableValidate (standardBuildsWithConfig AArch64 (Linux Alpine318) (splitSectionsBroken vanilla))
, fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt)))
, validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
- , validateBuilds Amd64 (Linux Debian11) (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure")
- )
- { bignumBackend = Native
- }
+
+ , addValidateRule JSBackend (validateBuilds Amd64 (Linux Debian11) javascriptConfig)
+
, make_wasm_jobs wasm_build_config
, modifyValidateJobs manual $
make_wasm_jobs wasm_build_config {bignumBackend = Native}
@@ -1024,6 +1025,8 @@ job_groups =
]
where
+ javascriptConfig = (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure"))
+ { bignumBackend = Native }
-- ghcilink002 broken due to #17869
--
=====================================
.gitlab/jobs.yaml
=====================================
@@ -5255,7 +5255,7 @@
],
"rules": [
{
- "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/))) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
+ "if": "((($CI_MERGE_REQUEST_LABELS =~ /.*full-ci.*/) || ($CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/) || ($CI_COMMIT_BRANCH == \"master\") || ($CI_COMMIT_BRANCH =~ /ghc-[0-9]+\\.[0-9]+/)) || ($CI_MERGE_REQUEST_LABELS =~ /.*javascript.*/)) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null)",
"when": "on_success"
}
],
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -695,7 +695,7 @@ data WarningFlag =
| Opt_WarnIncompleteRecordSelectors -- Since 9.10
| Opt_WarnBadlyStagedTypes -- Since 9.10
| Opt_WarnInconsistentFlags -- Since 9.8
- deriving (Eq, Ord, Show, Enum)
+ deriving (Eq, Ord, Show, Enum, Bounded)
-- | Return the names of a WarningFlag
--
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2165,127 +2165,125 @@ wWarningFlags :: [FlagSpec WarningFlag]
wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)
wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]
-wWarningFlagsDeps = mconcat [
+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
-- See Note [Updating flag description in the User's Guide]
-- See Note [Supporting CLI completion]
--- Please keep the list of flags below sorted alphabetically
- warnSpec Opt_WarnAlternativeLayoutRuleTransitional,
- warnSpec Opt_WarnAmbiguousFields,
- depWarnSpec Opt_WarnAutoOrphans
- "it has no effect",
- warnSpec Opt_WarnCPPUndef,
- warnSpec Opt_WarnUnbangedStrictPatterns,
- warnSpec Opt_WarnDeferredTypeErrors,
- warnSpec Opt_WarnDeferredOutOfScopeVariables,
- warnSpec Opt_WarnDeprecatedFlags,
- warnSpec Opt_WarnDerivingDefaults,
- warnSpec Opt_WarnDerivingTypeable,
- warnSpec Opt_WarnDodgyExports,
- warnSpec Opt_WarnDodgyForeignImports,
- warnSpec Opt_WarnDodgyImports,
- warnSpec Opt_WarnEmptyEnumerations,
- subWarnSpec "duplicate-constraints"
- Opt_WarnDuplicateConstraints
- "it is subsumed by -Wredundant-constraints",
- warnSpec Opt_WarnRedundantConstraints,
- warnSpec Opt_WarnDuplicateExports,
- depWarnSpec Opt_WarnHiShadows
- "it is not used, and was never implemented",
- warnSpec Opt_WarnInaccessibleCode,
- warnSpec Opt_WarnImplicitPrelude,
- depWarnSpec Opt_WarnImplicitKindVars
- "it is now an error",
- warnSpec Opt_WarnIncompletePatterns,
- warnSpec Opt_WarnIncompletePatternsRecUpd,
- warnSpec Opt_WarnIncompleteUniPatterns,
- warnSpec Opt_WarnInlineRuleShadowing,
- warnSpec Opt_WarnIdentities,
- warnSpec Opt_WarnMissingFields,
- warnSpec Opt_WarnMissingImportList,
- warnSpec Opt_WarnMissingExportList,
- subWarnSpec "missing-local-sigs"
- Opt_WarnMissingLocalSignatures
- "it is replaced by -Wmissing-local-signatures",
- warnSpec Opt_WarnMissingLocalSignatures,
- warnSpec Opt_WarnMissingMethods,
- depWarnSpec Opt_WarnMissingMonadFailInstances
- "fail is no longer a method of Monad",
- warnSpec Opt_WarnSemigroup,
- warnSpec Opt_WarnMissingSignatures,
- warnSpec Opt_WarnMissingKindSignatures,
- warnSpec Opt_WarnMissingPolyKindSignatures,
- subWarnSpec "missing-exported-sigs"
- Opt_WarnMissingExportedSignatures
- "it is replaced by -Wmissing-exported-signatures",
- warnSpec Opt_WarnMissingExportedSignatures,
- warnSpec Opt_WarnMonomorphism,
- warnSpec Opt_WarnNameShadowing,
- warnSpec Opt_WarnNonCanonicalMonadInstances,
- depWarnSpec Opt_WarnNonCanonicalMonadFailInstances
- "fail is no longer a method of Monad",
- warnSpec Opt_WarnNonCanonicalMonoidInstances,
- warnSpec Opt_WarnOrphans,
- warnSpec Opt_WarnOverflowedLiterals,
- warnSpec Opt_WarnOverlappingPatterns,
- warnSpec Opt_WarnMissedSpecs,
- warnSpec Opt_WarnAllMissedSpecs,
- warnSpec' Opt_WarnSafe setWarnSafe,
- warnSpec Opt_WarnTrustworthySafe,
- warnSpec Opt_WarnInferredSafeImports,
- warnSpec Opt_WarnMissingSafeHaskellMode,
- warnSpec Opt_WarnTabs,
- warnSpec Opt_WarnTypeDefaults,
- warnSpec Opt_WarnTypedHoles,
- warnSpec Opt_WarnPartialTypeSignatures,
- warnSpec Opt_WarnUnrecognisedPragmas,
- warnSpec Opt_WarnMisplacedPragmas,
- warnSpec' Opt_WarnUnsafe setWarnUnsafe,
- warnSpec Opt_WarnUnsupportedCallingConventions,
- warnSpec Opt_WarnUnsupportedLlvmVersion,
- warnSpec Opt_WarnMissedExtraSharedLib,
- warnSpec Opt_WarnUntickedPromotedConstructors,
- warnSpec Opt_WarnUnusedDoBind,
- warnSpec Opt_WarnUnusedForalls,
- warnSpec Opt_WarnUnusedImports,
- warnSpec Opt_WarnUnusedLocalBinds,
- warnSpec Opt_WarnUnusedMatches,
- warnSpec Opt_WarnUnusedPatternBinds,
- warnSpec Opt_WarnUnusedTopBinds,
- warnSpec Opt_WarnUnusedTypePatterns,
- warnSpec Opt_WarnUnusedRecordWildcards,
- warnSpec Opt_WarnRedundantBangPatterns,
- warnSpec Opt_WarnRedundantRecordWildcards,
- warnSpec Opt_WarnRedundantStrictnessFlags,
- warnSpec Opt_WarnWrongDoBind,
- warnSpec Opt_WarnMissingPatternSynonymSignatures,
- warnSpec Opt_WarnMissingDerivingStrategies,
- warnSpec Opt_WarnSimplifiableClassConstraints,
- warnSpec Opt_WarnMissingHomeModules,
- warnSpec Opt_WarnUnrecognisedWarningFlags,
- warnSpec Opt_WarnStarBinder,
- warnSpec Opt_WarnStarIsType,
- depWarnSpec Opt_WarnSpaceAfterBang
- "bang patterns can no longer be written with a space",
- warnSpec Opt_WarnPartialFields,
- warnSpec Opt_WarnPrepositiveQualifiedModule,
- warnSpec Opt_WarnUnusedPackages,
- warnSpec Opt_WarnCompatUnqualifiedImports,
- warnSpec Opt_WarnInvalidHaddock,
- warnSpec Opt_WarnOperatorWhitespaceExtConflict,
- warnSpec Opt_WarnOperatorWhitespace,
- warnSpec Opt_WarnImplicitLift,
- warnSpec Opt_WarnMissingExportedPatternSynonymSignatures,
- warnSpec Opt_WarnForallIdentifier,
- warnSpec Opt_WarnUnicodeBidirectionalFormatCharacters,
- warnSpec Opt_WarnGADTMonoLocalBinds,
- warnSpec Opt_WarnTypeEqualityOutOfScope,
- warnSpec Opt_WarnTypeEqualityRequiresOperators,
- warnSpec Opt_WarnTermVariableCapture,
- warnSpec Opt_WarnMissingRoleAnnotations,
- warnSpec Opt_WarnImplicitRhsQuantification,
- warnSpec Opt_WarnIncompleteExportWarnings,
- warnSpec Opt_WarnIncompleteRecordSelectors
- ]
+ Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x
+ Opt_WarnAmbiguousFields -> warnSpec x
+ Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"
+ Opt_WarnCPPUndef -> warnSpec x
+ Opt_WarnBadlyStagedTypes -> warnSpec x
+ Opt_WarnUnbangedStrictPatterns -> warnSpec x
+ Opt_WarnDeferredTypeErrors -> warnSpec x
+ Opt_WarnDeferredOutOfScopeVariables -> warnSpec x
+ Opt_WarnDeprecatedFlags -> warnSpec x
+ Opt_WarnDerivingDefaults -> warnSpec x
+ Opt_WarnDerivingTypeable -> warnSpec x
+ Opt_WarnDodgyExports -> warnSpec x
+ Opt_WarnDodgyForeignImports -> warnSpec x
+ Opt_WarnDodgyImports -> warnSpec x
+ Opt_WarnEmptyEnumerations -> warnSpec x
+ Opt_WarnDuplicateConstraints
+ -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"
+ Opt_WarnRedundantConstraints -> warnSpec x
+ Opt_WarnDuplicateExports -> warnSpec x
+ Opt_WarnHiShadows
+ -> depWarnSpec x "it is not used, and was never implemented"
+ Opt_WarnInaccessibleCode -> warnSpec x
+ Opt_WarnImplicitPrelude -> warnSpec x
+ Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"
+ Opt_WarnIncompletePatterns -> warnSpec x
+ Opt_WarnIncompletePatternsRecUpd -> warnSpec x
+ Opt_WarnIncompleteUniPatterns -> warnSpec x
+ Opt_WarnInconsistentFlags -> warnSpec x
+ Opt_WarnInlineRuleShadowing -> warnSpec x
+ Opt_WarnIdentities -> warnSpec x
+ Opt_WarnLoopySuperclassSolve -> warnSpec x
+ Opt_WarnMissingFields -> warnSpec x
+ Opt_WarnMissingImportList -> warnSpec x
+ Opt_WarnMissingExportList -> warnSpec x
+ Opt_WarnMissingLocalSignatures
+ -> subWarnSpec "missing-local-sigs" x
+ "it is replaced by -Wmissing-local-signatures"
+ ++ warnSpec x
+ Opt_WarnMissingMethods -> warnSpec x
+ Opt_WarnMissingMonadFailInstances
+ -> depWarnSpec x "fail is no longer a method of Monad"
+ Opt_WarnSemigroup -> warnSpec x
+ Opt_WarnMissingSignatures -> warnSpec x
+ Opt_WarnMissingKindSignatures -> warnSpec x
+ Opt_WarnMissingPolyKindSignatures -> warnSpec x
+ Opt_WarnMissingExportedSignatures
+ -> subWarnSpec "missing-exported-sigs" x
+ "it is replaced by -Wmissing-exported-signatures"
+ ++ warnSpec x
+ Opt_WarnMonomorphism -> warnSpec x
+ Opt_WarnNameShadowing -> warnSpec x
+ Opt_WarnNonCanonicalMonadInstances -> warnSpec x
+ Opt_WarnNonCanonicalMonadFailInstances
+ -> depWarnSpec x "fail is no longer a method of Monad"
+ Opt_WarnNonCanonicalMonoidInstances -> warnSpec x
+ Opt_WarnOrphans -> warnSpec x
+ Opt_WarnOverflowedLiterals -> warnSpec x
+ Opt_WarnOverlappingPatterns -> warnSpec x
+ Opt_WarnMissedSpecs -> warnSpec x
+ Opt_WarnAllMissedSpecs -> warnSpec x
+ Opt_WarnSafe -> warnSpec' x setWarnSafe
+ Opt_WarnTrustworthySafe -> warnSpec x
+ Opt_WarnInferredSafeImports -> warnSpec x
+ Opt_WarnMissingSafeHaskellMode -> warnSpec x
+ Opt_WarnTabs -> warnSpec x
+ Opt_WarnTypeDefaults -> warnSpec x
+ Opt_WarnTypedHoles -> warnSpec x
+ Opt_WarnPartialTypeSignatures -> warnSpec x
+ Opt_WarnUnrecognisedPragmas -> warnSpec x
+ Opt_WarnMisplacedPragmas -> warnSpec x
+ Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe
+ Opt_WarnUnsupportedCallingConventions -> warnSpec x
+ Opt_WarnUnsupportedLlvmVersion -> warnSpec x
+ Opt_WarnMissedExtraSharedLib -> warnSpec x
+ Opt_WarnUntickedPromotedConstructors -> warnSpec x
+ Opt_WarnUnusedDoBind -> warnSpec x
+ Opt_WarnUnusedForalls -> warnSpec x
+ Opt_WarnUnusedImports -> warnSpec x
+ Opt_WarnUnusedLocalBinds -> warnSpec x
+ Opt_WarnUnusedMatches -> warnSpec x
+ Opt_WarnUnusedPatternBinds -> warnSpec x
+ Opt_WarnUnusedTopBinds -> warnSpec x
+ Opt_WarnUnusedTypePatterns -> warnSpec x
+ Opt_WarnUnusedRecordWildcards -> warnSpec x
+ Opt_WarnRedundantBangPatterns -> warnSpec x
+ Opt_WarnRedundantRecordWildcards -> warnSpec x
+ Opt_WarnRedundantStrictnessFlags -> warnSpec x
+ Opt_WarnWrongDoBind -> warnSpec x
+ Opt_WarnMissingPatternSynonymSignatures -> warnSpec x
+ Opt_WarnMissingDerivingStrategies -> warnSpec x
+ Opt_WarnSimplifiableClassConstraints -> warnSpec x
+ Opt_WarnMissingHomeModules -> warnSpec x
+ Opt_WarnUnrecognisedWarningFlags -> warnSpec x
+ Opt_WarnStarBinder -> warnSpec x
+ Opt_WarnStarIsType -> warnSpec x
+ Opt_WarnSpaceAfterBang
+ -> depWarnSpec x "bang patterns can no longer be written with a space"
+ Opt_WarnPartialFields -> warnSpec x
+ Opt_WarnPrepositiveQualifiedModule -> warnSpec x
+ Opt_WarnUnusedPackages -> warnSpec x
+ Opt_WarnCompatUnqualifiedImports -> warnSpec x
+ Opt_WarnInvalidHaddock -> warnSpec x
+ Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x
+ Opt_WarnOperatorWhitespace -> warnSpec x
+ Opt_WarnImplicitLift -> warnSpec x
+ Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x
+ Opt_WarnForallIdentifier -> warnSpec x
+ Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x
+ Opt_WarnGADTMonoLocalBinds -> warnSpec x
+ Opt_WarnTypeEqualityOutOfScope -> warnSpec x
+ Opt_WarnTypeEqualityRequiresOperators -> warnSpec x
+ Opt_WarnTermVariableCapture -> warnSpec x
+ Opt_WarnMissingRoleAnnotations -> warnSpec x
+ Opt_WarnImplicitRhsQuantification -> warnSpec x
+ Opt_WarnIncompleteExportWarnings -> warnSpec x
+ Opt_WarnIncompleteRecordSelectors -> warnSpec x
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
warningGroupsDeps = map mk warningGroups
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2187,6 +2187,6 @@ type instance Anno FastString = SrcAnn NoEpAnns
type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
-instance (Anno a ~ SrcSpanAnn' (EpAnn an))
+instance (Anno a ~ SrcSpanAnn' (EpAnn an), NoAnn an)
=> WrapXRec (GhcPass p) a where
wrapXRec = noLocA
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -108,6 +108,7 @@ type instance Anno Name = SrcSpanAnnN
type instance Anno Id = SrcSpanAnnN
type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),
+ NoAnn a,
IsPass p)
instance UnXRec (GhcPass p) where
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -541,7 +541,7 @@ mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2
mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy t1 t2
- = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))
+ = addCLocA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))
mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
@@ -550,7 +550,7 @@ mkHsAppTys = foldl' mkHsAppTy
mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy ty at k
- = addCLocAA ty k (HsAppKindTy noExtField ty at k)
+ = addCLocA ty k (HsAppKindTy noExtField ty at k)
{-
************************************************************************
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -232,14 +232,14 @@ mkLamCaseMatchGroup origin lam_variant (L l matches)
= mkMatchGroup origin (L l $ map fixCtxt matches)
where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant}
-mkLocatedList :: Semigroup a
+mkLocatedList :: (Semigroup a, NoAnn an)
=> [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList ms = case nonEmpty ms of
Nothing -> noLocA []
Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)
+mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noComments e1 e2)
mkHsAppWith
:: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
@@ -250,7 +250,7 @@ mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)
mkHsApps
:: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
-mkHsApps = mkHsAppsWith addCLocAA
+mkHsApps = mkHsAppsWith addCLocA
mkHsAppsWith
:: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
@@ -260,7 +260,7 @@ mkHsAppsWith
mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)
mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
-mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct)
+mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e noHsTok paren_wct)
where
t_body = hswc_body t
paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
@@ -1832,5 +1832,3 @@ rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })
= ImplicitFieldBinders
{ implFlBndr_field = foExt fld
, implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
-
-
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4120,7 +4120,7 @@ sL1 :: HasLoc a => a -> b -> Located b
sL1 x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1a #-}
-sL1a :: HasLoc a => a -> b -> LocatedAn t b
+sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b
sL1a x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1n #-}
@@ -4132,7 +4132,7 @@ sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLa #-}
-sLLa :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedAn t c
+sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c
sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLl #-}
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -71,13 +71,14 @@ module GHC.Parser.Annotation (
mapLocA,
combineLocsA,
combineSrcSpansA,
- addCLocA, addCLocAA,
+ addCLocA,
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
- noLocA, getLocA,
+ HasAnnotation(..),
+ noLocA,
+ getLocA,
noSrcSpanA,
- noAnnSrcSpan,
-- ** Working with comments in annotations
noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
@@ -994,15 +995,15 @@ la2na l = noAnnSrcSpan (locA l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2
+la2la :: (NoAnn ann2) => LocatedAn ann1 a2 -> LocatedAn ann2 a2
la2la (L la a) = L (noAnnSrcSpan (locA la)) a
l2l :: SrcSpanAnn' a -> SrcAnn ann
-l2l l = noAnnSrcSpan (locA l)
+l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-na2la :: SrcSpanAnn' a -> SrcAnn ann
+na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
na2la l = noAnnSrcSpan (locA l)
reLoc :: LocatedAn a e -> Located e
@@ -1022,18 +1023,21 @@ reLocN (L (SrcSpanAnn _ l) a) = L l a
-- ---------------------------------------------------------------------
-noLocA :: a -> LocatedAn an a
-noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)
+class HasAnnotation e where
+ noAnnSrcSpan :: SrcSpan -> e
+
+instance (NoAnn ann) => HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
+ noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
+
+noLocA :: (HasAnnotation e) => a -> GenLocated e a
+noLocA = L (noAnnSrcSpan noSrcSpan)
getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA = getHasLoc
-noSrcSpanA :: SrcAnn ann
+noSrcSpanA :: (HasAnnotation e) => e
noSrcSpanA = noAnnSrcSpan noSrcSpan
-noAnnSrcSpan :: SrcSpan -> SrcAnn ann
-noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
-
-- ---------------------------------------------------------------------
class NoAnn a where
@@ -1163,7 +1167,7 @@ epAnnComments (EpAnn _ _ cs) = cs
sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
sortLocatedA = sortBy (leftmost_smallest `on` getLocA)
-mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
+mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)
-- AZ:TODO: move this somewhere sane
@@ -1179,11 +1183,9 @@ combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)
SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l
-- | Combine locations from two 'Located' things and add them to a third thing
-addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
-addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c
-
-addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3
-addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c
+addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l)
+ => a -> b -> c -> GenLocated l c
+addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (getHasLoc a) (getHasLoc b)) c
-- ---------------------------------------------------------------------
-- Utilities for manipulating EpAnnComments
@@ -1332,26 +1334,33 @@ instance Semigroup EpAnnComments where
EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2)
-instance NoAnn NoEpAnns where
- noAnn = NoEpAnns
-
instance Semigroup AnnListItem where
(AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)
-instance NoAnn AnnListItem where
- noAnn = AnnListItem []
-
-
instance Semigroup (AnnSortKey tag) where
NoAnnSortKey <> x = x
x <> NoAnnSortKey = x
AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)
+instance Monoid (AnnSortKey tag) where
+ mempty = NoAnnSortKey
+
+-- ---------------------------------------------------------------------
+-- NoAnn instances
+
+instance NoAnn NoEpAnns where
+ noAnn = NoEpAnns
+
+instance NoAnn AnnListItem where
+ noAnn = AnnListItem []
+
+instance NoAnn AnnContext where
+ noAnn = AnnContext Nothing [] []
+
instance NoAnn AnnList where
noAnn = AnnList Nothing Nothing Nothing [] []
-instance Monoid (AnnSortKey tag) where
- mempty = NoAnnSortKey
+-- ---------------------------------------------------------------------
instance NoAnn NameAnn where
noAnn = NameAnnTrailing []
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -714,7 +714,7 @@ checkCTupSize tup_size
* *
********************************************************************* -}
-wrapGenSpan :: a -> LocatedAn an a
+wrapGenSpan :: (NoAnn an) => a -> LocatedAn an a
-- Wrap something in a "generatedSrcSpan"
-- See Note [Rebindable syntax and HsExpansion]
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
@@ -742,10 +742,10 @@ genHsVar nm = HsVar noExtField $ wrapGenSpan nm
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty))
-genLHsLit :: HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
+genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
genLHsLit = wrapGenSpan . HsLit noAnn
-genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
+genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit = genLHsLit . HsInt noExtField
genHsTyLit :: FastString -> HsType GhcRn
@@ -767,11 +767,15 @@ genWildPat = wrapGenSpan $ WildPat noExtField
genSimpleFunBind :: Name -> [LPat GhcRn]
-> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind fun pats expr
- = L gen $ genFunBind (L gen fun)
- [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr
+ = L genA $ genFunBind (L genN fun)
+ [mkMatch (mkPrefixFunRhs (L genN fun)) pats expr
emptyLocalBinds]
where
- gen = noAnnSrcSpan generatedSrcSpan
+ genA :: SrcSpanAnnA
+ genA = noAnnSrcSpan generatedSrcSpan
+
+ genN :: SrcSpanAnnN
+ genN = noAnnSrcSpan generatedSrcSpan
genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -142,13 +142,13 @@ getL = CvtM (\_ loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ _ -> Right (loc, ()))
-returnLA :: e -> CvtM (LocatedAn ann e)
+returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e)
returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
returnJustLA :: a -> CvtM (Maybe (LocatedA a))
returnJustLA = fmap Just . returnLA
-wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
+wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))
wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -149,7 +149,8 @@ instance Uniquable Module where
instance Binary a => Binary (GenModule a) where
put_ bh (Module p n) = put_ bh p >> put_ bh n
- get bh = do p <- get bh; n <- get bh; return (Module p 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` ()
@@ -317,13 +318,14 @@ instance Binary InstantiatedUnit where
cid <- get bh
insts <- get bh
let fs = mkInstantiatedUnitHash cid insts
- return InstantiatedUnit {
- instUnitInstanceOf = cid,
- instUnitInsts = insts,
- instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
- instUnitFS = fs,
- instUnitKey = getUnique fs
- }
+ -- 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
@@ -369,10 +371,12 @@ instance Binary Unit where
put_ bh HoleUnit =
putByte bh 2
get bh = do b <- getByte bh
- case b of
+ 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
=====================================
libraries/unix
=====================================
@@ -1 +1 @@
-Subproject commit 3f0d217b5b3de5ccec54154d5cd5c7b0d07708df
+Subproject commit 5211c230903aee8c09485e8246993e2a1eb74563
=====================================
utils/check-exact/Orphans.hs
=====================================
@@ -62,9 +62,6 @@ instance NoAnn AddEpAnn where
instance NoAnn AnnKeywordId where
noAnn = Annlarrowtail {- gotta pick one -}
-instance NoAnn AnnContext where
- noAnn = AnnContext Nothing [] []
-
instance NoAnn EpAnnSumPat where
noAnn = EpAnnSumPat noAnn noAnn noAnn
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -371,9 +371,9 @@ setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn =
-- |Version of l2l that preserves the anchor, immportant if it has an
-- updated AnchorOperation
-moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b
+moveAnchor :: NoAnn b => SrcAnn a -> SrcAnn b
moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l
-moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l
+moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc noAnn cs) l
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a703f29084c7e4580bf9f55a5b8ed5a6d87a5566...e37a1a3cdfaa6b44888b18526c5e1567fddf7733
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a703f29084c7e4580bf9f55a5b8ed5a6d87a5566...e37a1a3cdfaa6b44888b18526c5e1567fddf7733
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231009/5c03077f/attachment-0001.html>
More information about the ghc-commits
mailing list