[Git][ghc/ghc][master] Localise a case-binder in SpecConstr.mkSeqs

[Marge Bot (@marge-bot)]

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


Commits:
246bc3a4 by Simon Peyton Jones at 2024-06-14T14:44:56-04:00
Localise a case-binder in SpecConstr.mkSeqs

This small change fixes #24944

See (SCF1) in Note [SpecConstr and strict fields]

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/SpecConstr.hs
- + testsuite/tests/simplCore/should_compile/T24944.hs
- + testsuite/tests/simplCore/should_compile/T24944a.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -639,6 +639,17 @@ That is we make the specialized function strict in arguments
 representing strict fields. See Note [Call-by-value for worker args]
 for why we do this.
 
+(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944).
+  We don't want to make
+     case M.foo_acf of M.foo_acf { DEFAULT -> blah }
+  because the binder of a case-expression should never be imported.  Rather,
+  we must localise it thus:
+     case M.foo_acf of foo_acf { DEFAULT -> blah }
+  We keep the same unique, so in the next round of simplification we'll replace
+  any M.foo_acf's in `blah` by `foo_acf`.
+
+  c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils.
+
 Note [Specialising on dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In #21386, SpecConstr saw this call:
@@ -2030,8 +2041,8 @@ generaliseDictPats qvars pats
        | otherwise
        = return (extra_qvs, pat)
 
--- See Note [SpecConstr and strict fields]
 mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
+-- See Note [SpecConstr and strict fields]
 mkSeqs seqees res_ty rhs =
   foldr addEval rhs seqees
     where
@@ -2039,7 +2050,11 @@ mkSeqs seqees res_ty rhs =
       addEval arg_id rhs
         -- Argument representing strict field and it's worth passing via cbv
         | shouldStrictifyIdForCbv arg_id
-        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])
+        = Case (Var arg_id)
+               (localiseId arg_id)  -- See (SCF1) in Note [SpecConstr and strict fields]
+               res_ty
+               ([Alt DEFAULT [] rhs])
+
         | otherwise
         = rhs
 


=====================================
testsuite/tests/simplCore/should_compile/T24944.hs
=====================================
@@ -0,0 +1,26 @@
+module T24944 where
+
+import T24944a
+
+data DataCon = DC TyCon
+
+data AltCon = DataAlt DataCon | LitAlt
+
+data GenStgAlt pass = GenStgAlt
+  { alt_con :: !AltCon
+  }
+
+data Type = TyVarTy | FunTy | TyConApp TyCon
+
+mkStgAltTypeFromStgAlts :: Type -> [GenStgAlt Int] -> Maybe TyCon
+mkStgAltTypeFromStgAlts bndr_ty alts
+  = let may = case bndr_ty of
+                TyConApp tc -> Just tc
+                FunTy -> Just myTyCon
+                TyVarTy -> Nothing
+    in case may of
+          Just (TyCon { tyConDetails = AlgTyCon True })
+             -> case alt_con <$> alts of
+                  DataAlt (DC con) : _ -> Just con
+                  _ -> Nothing
+          _ -> Nothing


=====================================
testsuite/tests/simplCore/should_compile/T24944a.hs
=====================================
@@ -0,0 +1,20 @@
+module T24944a where
+
+data TyCon = TyCon {
+        tyConNullaryTy :: TyCon,
+        tyConDetails :: !TyConDetails
+        }
+
+data TyConDetails =
+    AlgTyCon Bool
+  | PrimTyCon Int
+  | PromotedDataCon
+
+myTyCon :: TyCon
+myTyCon = TyCon { tyConDetails          = PrimTyCon 1
+                , tyConNullaryTy        = id' myTyCon
+                }
+
+id' :: TyCon -> TyCon
+id' a = a
+{-# NOINLINE id' #-}


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -522,3 +522,6 @@ test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
 test('T24768', normal, compile, ['-O'])
 test('T24770', [ grep_errmsg(r'Dead') ], compile, ['-O'])
 test('T24808', [ grep_errmsg(r'myFunction') ], compile, ['-O -ddump-simpl'])
+
+# T24944 needs -O2 because it's about SpecConstr
+test('T24944', [extra_files(['T24944a.hs'])], multimod_compile, ['T24944', '-v0 -O2'])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/246bc3a43a57b7c9ea907bd9ef15b7ef7c490681
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/20240614/52c3cc8b/attachment-0001.html>