[Git][ghc/ghc][master] Update the unification count in wrapUnifierX

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
833e250c by Simon Peyton Jones at 2023-11-05T00:25:31-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.

- - - - -


3 changed files:

- compiler/GHC/Tc/Solver/Monad.hs
- + testsuite/tests/typecheck/should_compile/T24146.hs
- testsuite/tests/typecheck/should_compile/all.T


Changes:

=====================================
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) } }
 
 
 {-


=====================================
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/-/commit/833e250c74da9899896796b6ff8d1630f8295ec3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/833e250c74da9899896796b6ff8d1630f8295ec3
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/20231105/2665f71b/attachment-0001.html>