[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: EPA: make locA a function, not a field name
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Nov 4 08:31:25 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8e84ca5e by Alan Zimmerman at 2023-11-04T04:31:15-04:00
EPA: make locA a function, not a field name
And use it to generalise reLoc
The following for the windows pipeline one. 5.5%
Metric Increase:
T5205
- - - - -
e229eed0 by Simon Peyton Jones at 2023-11-04T04:31:15-04:00
Update the unification count in wrapUnifierX
Omitting this caused type inference to fail in #24146.
This was an accidental omision in my refactoring of the
equality solver.
- - - - -
8 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/ThToHs.hs
- testsuite/tests/parser/should_compile/T23315/T23315.stderr
- + testsuite/tests/typecheck/should_compile/T24146.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1019,13 +1019,13 @@ exportlist1 :: { OrdList (LIE GhcPs) }
export :: { OrdList (LIE GhcPs) }
: maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }
; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)
- ; return $ unitOL $ reLocA $ sL span $ impExp } }
+ ; return $ unitOL $ reLoc $ sL span $ impExp } }
| maybe_warning_pragma 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $>
; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }
; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))
- ; return $ unitOL $ reLocA $ locImpExp } }
+ ; return $ unitOL $ reLoc $ locImpExp } }
| maybe_warning_pragma 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $>
- in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
+ in unitOL $ reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) }
export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }
: {- empty -} { sL0 ([],ImpExpAbs) }
@@ -1117,7 +1117,7 @@ importdecl :: { LImportDecl GhcPs }
, importDeclAnnAs = fst $8
}
; let loc = (comb5 $1 $6 $7 (snd $8) $9);
- ; fmap reLocA $ acs (\cs -> L loc $
+ ; fmap reLoc $ acs (\cs -> L loc $
ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False
, ideclName = $6, ideclPkgQual = snd $5
, ideclSource = snd $2, ideclSafe = snd $3
@@ -1192,9 +1192,9 @@ importlist1 :: { OrdList (LIE GhcPs) }
| import { $1 }
import :: { OrdList (LIE GhcPs) }
- : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
- | 'module' modid {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
- | 'pattern' qcon { unitOL $ reLocA $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
+ : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }
+ | 'module' modid {% fmap (unitOL . reLoc) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) }
+ | 'pattern' qcon { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) }
-----------------------------------------------------------------------------
-- Fixity Declarations
@@ -2174,7 +2174,7 @@ ctype :: { LHsType GhcPs }
, hst_xqual = NoExtField
, hst_body = $3 })) }
- | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
+ | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLoc $1) $3)) }
| type { $1 }
----------------------
@@ -2736,7 +2736,7 @@ exp :: { ECP }
-- Embed types into expressions and patterns for required type arguments
| 'type' atype
{% do { requireExplicitNamespaces (getLoc $1)
- ; return $ ECP $ mkHsEmbTyPV (comb2 $1 (reLoc $>)) (hsTok $1) $2 } }
+ ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (hsTok $1) $2 } }
infixexp :: { ECP }
: exp10 { $1 }
@@ -2998,7 +2998,7 @@ aexp2 :: { ECP }
-- Template Haskell Extension
| splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }
- | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }
+ | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }
| SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
| SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) }
@@ -3036,8 +3036,8 @@ projection
| PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
splice_exp :: { LHsExpr GhcPs }
- : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }
- | splice_typed { fmap (uncurry HsTypedSplice) (reLocA $1) }
+ : splice_untyped { fmap (HsUntypedSplice noAnn) (reLoc $1) }
+ | splice_typed { fmap (uncurry HsTypedSplice) (reLoc $1) }
splice_untyped :: { Located (HsUntypedSplice GhcPs) }
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer
@@ -3338,7 +3338,7 @@ alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }
: '->' exp { unECP $2 >>= \ $2 ->
- acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 (reLoc $2)) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }
+ acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) }
| gdpats { $1 >>= \gdpats ->
return $ sL1 gdpats (reverse (unLoc gdpats)) }
@@ -3535,7 +3535,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
+ acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLoc $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -4361,7 +4361,7 @@ acsa a = do
return (a cs)
acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
-acsA a = reLocA <$> acs a
+acsA a = reLoc <$> acs a
acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP
acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
@@ -4421,7 +4421,7 @@ mcs ll = mj AnnCloseS ll
pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)
pvA a = do { av <- a
- ; return (reLocA av) }
+ ; return (reLoc av) }
pvN :: MonadP m => m (Located a) -> m (LocatedN a)
pvN a = do { (L l av) <- a
@@ -4475,7 +4475,7 @@ hsDoAnn (L l _) (L ll _) kw
listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor
listAsAnchor [] (L l _) = spanAsAnchor l
-listAsAnchor (h:_) s = spanAsAnchor (comb2 (reLoc h) s)
+listAsAnchor (h:_) s = spanAsAnchor (comb2 h s)
listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor
listAsAnchorM [] = Nothing
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Parser.Annotation (
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
la2na, na2la, n2l, l2n, l2l, la2la,
- reLoc, reLocA, reLocL, reLocC, reLocN,
+ reLoc,
HasLoc(..), getHasLocList,
srcSpan2e, la2e, realSrcSpan,
@@ -78,6 +78,7 @@ module GHC.Parser.Annotation (
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
HasAnnotation(..),
+ locA,
noLocA,
getLocA,
noSrcSpanA,
@@ -579,7 +580,7 @@ emptyComments = EpaComments []
-- Important that the fields are strict as these live inside L nodes which
-- are live for a long time.
-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }
+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locAn :: !SrcSpan }
deriving (Data, Eq)
-- See Note [XRec and Anno in the AST]
@@ -1016,27 +1017,23 @@ l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
na2la l = noAnnSrcSpan (locA l)
-reLoc :: LocatedAn a e -> Located e
-reLoc (L (SrcSpanAnn _ l) a) = L l a
+locA :: (HasLoc a) => a -> SrcSpan
+locA = getHasLoc
-reLocA :: Located e -> LocatedAn ann e
-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)
+reLoc :: (HasLoc (GenLocated a e), HasAnnotation b)
+ => GenLocated a e -> GenLocated b e
+reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
-reLocL :: LocatedN e -> LocatedA e
-reLocL (L l a) = (L (na2la l) a)
-
-reLocC :: LocatedN e -> LocatedC e
-reLocC (L l a) = (L (na2la l) a)
-
-reLocN :: LocatedN a -> Located a
-reLocN (L (SrcSpanAnn _ l) a) = L l a
-- ---------------------------------------------------------------------
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance (NoAnn ann) => HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
+instance HasAnnotation (SrcSpan) where
+ noAnnSrcSpan l = l
+
+instance HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
noLocA :: (HasAnnotation e) => a -> GenLocated e a
@@ -1060,11 +1057,14 @@ class HasLoc a where
-- ^ conveniently calculate locations for things without locations attached
getHasLoc :: a -> SrcSpan
-instance HasLoc (Located a) where
- getHasLoc (L l _) = l
+instance (HasLoc l) => HasLoc (GenLocated l a) where
+ getHasLoc (L l _) = getHasLoc l
+
+instance HasLoc SrcSpan where
+ getHasLoc l = l
-instance HasLoc (GenLocated (SrcSpanAnn' a) e) where
- getHasLoc (L (SrcSpanAnn _ l) _) = l
+instance HasLoc (SrcSpanAnn' a) where
+ getHasLoc (SrcSpanAnn _ l) = l
instance (HasLoc a) => (HasLoc (Maybe a)) where
getHasLoc (Just a) = getHasLoc a
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1727,7 +1727,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]
+ return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
cs <- getCommentsFor l
@@ -1807,7 +1807,7 @@ instance DisambECP (HsExpr GhcPs) where
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2
+ return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLoc op) e2
mkHsCasePV l e (L lm m) anns = do
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
@@ -2092,7 +2092,7 @@ instance DisambTD DataConBuilder where
= -- When the user writes data T = {-# UNPACK #-} Int :+ Bool
-- we apply {-# UNPACK #-} to the LHS
do lhs' <- addUnpackednessP unpk lhs
- let l = combineLocsA (reLocA unpk) constr_stuff
+ let l = combineLocsA (reLoc unpk) constr_stuff
return $ L l (InfixDataConBuilder lhs' data_con rhs)
| otherwise =
do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -1197,6 +1197,9 @@ if you do so.
-- Getters and setters of GHC.Tc.Utils.Env fields
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+getUnifiedRef :: TcS (IORef Int)
+getUnifiedRef = TcS (return . tcs_unified)
+
-- Getter of inerts and worklist
getInertSetRef :: TcS (IORef InertSet)
getInertSetRef = TcS (return . tcs_inerts)
@@ -2040,21 +2043,28 @@ wrapUnifierX :: CtEvidence -> Role
-> (UnifyEnv -> TcM a) -- Some calls to uType
-> TcS (a, Bag Ct, [TcTyVar], RewriterSet)
wrapUnifierX ev role do_unifications
- = wrapTcS $
- do { defer_ref <- TcM.newTcRef emptyBag
- ; unified_ref <- TcM.newTcRef []
- ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)
- ; let env = UE { u_role = role
- , u_rewriters = rewriters
- , u_loc = ctEvLoc ev
- , u_defer = defer_ref
- , u_unified = Just unified_ref}
-
- ; res <- do_unifications env
-
- ; cts <- TcM.readTcRef defer_ref
- ; unified <- TcM.readTcRef unified_ref
- ; return (res, cts, unified, rewriters) }
+ = do { unif_count_ref <- getUnifiedRef
+ ; wrapTcS $
+ do { defer_ref <- TcM.newTcRef emptyBag
+ ; unified_ref <- TcM.newTcRef []
+ ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev)
+ ; let env = UE { u_role = role
+ , u_rewriters = rewriters
+ , u_loc = ctEvLoc ev
+ , u_defer = defer_ref
+ , u_unified = Just unified_ref}
+
+ ; res <- do_unifications env
+
+ ; cts <- TcM.readTcRef defer_ref
+ ; unified <- TcM.readTcRef unified_ref
+
+ -- Don't forget to update the count of variables
+ -- unified, lest we forget to iterate (#24146)
+ ; unless (null unified) $
+ TcM.updTcRef unif_count_ref (+ (length unified))
+
+ ; return (res, cts, unified, rewriters) } }
{-
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1016,7 +1016,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
n' <- wrapL (ipName n)
e' <- cvtl e
- returnLA (IPBind noAnn (reLocA n') e')
+ returnLA (IPBind noAnn (reLoc n') e')
-------------------------------------------------------------------
-- Expressions
@@ -1799,7 +1799,7 @@ cvtTypeKind typeOrKind ty
ImplicitParamT n t
-> do { n' <- wrapL $ ipName n
; t' <- cvtType t
- ; returnLA (HsIParamTy noAnn (reLocA n') t')
+ ; returnLA (HsIParamTy noAnn (reLoc n') t')
}
_ -> failWith (MalformedType typeOrKind ty)
=====================================
testsuite/tests/parser/should_compile/T23315/T23315.stderr
=====================================
@@ -108,5 +108,3 @@
" More docs"))
[]))
[])))))]))
-
-
=====================================
testsuite/tests/typecheck/should_compile/T24146.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+module M where
+
+class (a ~ b) => Aggregate a b where
+instance Aggregate a a where
+
+liftM :: (Aggregate ae am) => (forall r. am -> r) -> ae
+liftM _ = undefined
+
+class Positive a
+
+mytake :: (Positive n) => n -> r
+mytake = undefined
+
+x :: (Positive n) => n
+x = liftM mytake
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -902,3 +902,4 @@ test('InstanceWarnings', normal, multimod_compile, ['InstanceWarnings', ''])
test('T23861', normal, compile, [''])
test('T23918', normal, compile, [''])
test('T17564', normal, compile, [''])
+test('T24146', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c57d602fc10e218d8397035c2dd42989f0155c8b...e229eed04dbb7208ebd1781a69adf6933d5b92c0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c57d602fc10e218d8397035c2dd42989f0155c8b...e229eed04dbb7208ebd1781a69adf6933d5b92c0
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/20231104/c5459399/attachment-0001.html>
More information about the ghc-commits
mailing list