[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 12:01:54 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
52ab903b by Alan Zimmerman at 2023-11-04T08:01:31-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

- - - - -
6334b1f5 by Simon Peyton Jones at 2023-11-04T08:01:32-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/e229eed04dbb7208ebd1781a69adf6933d5b92c0...6334b1f53080be6ea7dabc1a346a564db012d884

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e229eed04dbb7208ebd1781a69adf6933d5b92c0...6334b1f53080be6ea7dabc1a346a564db012d884
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/58d2bf2b/attachment-0001.html>


More information about the ghc-commits mailing list