[Git][ghc/ghc][master] Make decomposeRuleLhs a bit more clever

[Marge Bot (@marge-bot)]

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


Commits:
ca2e919e by Simon Peyton Jones at 2024-01-31T09:29:45+00:00
Make decomposeRuleLhs a bit more clever

This fixes #24370 by making decomposeRuleLhs undertand
dictionary /functions/ as well as plain /dictionaries/

- - - - -


5 changed files:

- compiler/GHC.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/HsToCore/Binds.hs
- + testsuite/tests/simplCore/should_compile/T24370.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC.hs
=====================================
@@ -1515,9 +1515,7 @@ modInfoModBreaks :: ModuleInfo -> ModBreaks
 modInfoModBreaks = minf_modBreaks
 
 isDictonaryId :: Id -> Bool
-isDictonaryId id
-  = case tcSplitSigmaTy (idType id) of {
-      (_tvs, _theta, tau) -> isDictTy tau }
+isDictonaryId id = isDictTy (idType id)
 
 -- | Looks up a global name: that is, any top-level name in any
 -- visible module.  Unlike 'lookupName', lookupGlobalName does not use


=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -99,7 +99,14 @@ mkClassPred :: Class -> [Type] -> PredType
 mkClassPred clas tys = mkTyConApp (classTyCon clas) tys
 
 isDictTy :: Type -> Bool
-isDictTy = isClassPred
+-- True of dictionaries (Eq a) and
+--         dictionary functions (forall a. Eq a => Eq [a])
+-- See Note [Type determines value]
+-- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs)
+--     for why it's important to catch dictionary bindings
+isDictTy ty = isClassPred pred
+  where
+    (_, pred) = splitInvisPiTys ty
 
 typeDeterminesValue :: Type -> Bool
 -- See Note [Type determines value]


=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -987,7 +987,16 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
   = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]
 
   | otherwise = case decompose fun2 args2 of
-        Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2)
+        Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+                   --                                    , text "orig_lhs:" <+> ppr orig_lhs
+                   --                                    , text "rhs_fvs:" <+> ppr rhs_fvs
+                   --                                    , text "orig_lhs:" <+> ppr orig_lhs
+                   --                                    , text "lhs1:" <+> ppr lhs1
+                   --                                    , text "lhs2:" <+> ppr lhs2
+                   --                                    , text "fun2:" <+> ppr fun2
+                   --                                    , text "args2:" <+> ppr args2
+                   --                                    ]) $
+                   Left (DsRuleLhsTooComplicated orig_lhs lhs2)
         Just (fn_id, args)
           | not (null unbound) ->
             -- Check for things unbound on LHS
@@ -1059,7 +1068,9 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
 
    split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
    split_lets (Let (NonRec d r) body)
-     | isDictId d
+     | isDictId d  -- Catches dictionaries, yes, but also catches dictionary
+                   -- /functions/ arising from solving a
+                   -- quantified contraint (#24370)
      = ((d,r):bs, body')
      where (bs, body') = split_lets body
 


=====================================
testsuite/tests/simplCore/should_compile/T24370.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
+
+-- This gave "RULE left-hand side too complicated to desugar"
+-- in GHC 9.8
+
+module T24370 where
+
+f :: (Eq a, Eq a) => a -> b -> Int
+f = error "urk"
+
+{-# SPECIALISE f :: T Maybe -> b -> Int #-}
+
+instance (forall a. Eq a => Eq (f a)) => Eq (T f) where
+  a == b = False
+
+data T f = MkT (f Int)


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -511,3 +511,4 @@ test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules'])
 test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O'])
 test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
 test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
+test('T24370', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca2e919ecca35db412e772d7eadd6a7c4fb20e4b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca2e919ecca35db412e772d7eadd6a7c4fb20e4b
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/20240201/fc39434a/attachment-0001.html>