From 5e4f4ba835fd24135759ee7a2d0d5c636a8a1505 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Fri, 12 Apr 2024 07:23:11 -0400
Subject: [PATCH] Don't generate wrappers for `type data` constructors with
StrictData
Previously, the logic for checking if a data constructor needs a wrapper or not
would take into account whether the constructor's fields have explicit
strictness (e.g., `data T = MkT !Int`), but the logic would _not_ take into
account whether `StrictData` was enabled. This meant that something like `type
data T = MkT Int` would incorrectly generate a wrapper for `MkT` if
`StrictData` was enabled, leading to the horrible errors seen in #24620. To fix
this, we disable generating wrappers for `type data` constructors altogether.
Fixes #24620.
Co-authored-by: Ryan Scott <ryan.gl.scott@gmail.com>
---
compiler/GHC/Iface/Tidy.hs | 7 +++--
compiler/GHC/Rename/Module.hs | 2 ++
compiler/GHC/Types/Id/Make.hs | 30 +++++++++----------
.../tests/type-data/should_run/T24620.hs | 9 ++++++
testsuite/tests/type-data/should_run/all.T | 1 +
5 files changed, 31 insertions(+), 18 deletions(-)
create mode 100644 testsuite/tests/type-data/should_run/T24620.hs
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index eb5fa0df263c..26194d9d1c39 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -645,8 +645,11 @@ getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds tc
- | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
- | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
+ | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
+ | otherwise = []
+ -- The 'otherwise' includes family TyCons of course, but also (less obviously)
+ -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
+ -- * type data: we don't want any code for type-only stuff (#24620)
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds cls
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index be6cf3b3fe30..b55cef4e5162 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1972,6 +1972,8 @@ Wrinkles:
is never used (invariant (I1)), so it barely makes sense to talk about
the worker. A `type data` constructor only shows up in types, where it
appears as a TyCon, specifically a PromotedDataCon -- no Id in sight.
+ See #24620 for an example of what happens if you accidentally include
+ a wrapper.
See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where
this check is implemented.
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 9111c0634b61..0d0bd98bf12c 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -902,15 +902,25 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- needs a wrapper. This wrapper is injected into the program later in the
-- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy,
-- along with the accompanying implementation in getTyConImplicitBinds.
- wrapper_reqd =
- (not new_tycon
+ wrapper_reqd
+ | isTypeDataTyCon tycon
+ -- `type data` declarations never have data-constructor wrappers
+ -- Their data constructors only live at the type level, in the
+ -- form of PromotedDataCon, and therefore do not need wrappers.
+ -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.
+ = False
+
+ | otherwise
+ = (not new_tycon
-- (Most) newtypes have only a worker, with the exception
-- of some newtypes written with GADT syntax.
-- See dataConUserTyVarsNeedWrapper below.
&& (any isBanged (ev_ibangs ++ arg_ibangs)))
-- Some forcing/unboxing (includes eq_spec)
+
|| isFamInstTyCon tycon -- Cast result
- || (dataConUserTyVarsNeedWrapper data_con
+
+ || dataConUserTyVarsNeedWrapper data_con
-- If the data type was written with GADT syntax and
-- orders the type variables differently from what the
-- worker expects, it needs a data con wrapper to reorder
@@ -919,19 +929,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
--
-- NB: All GADTs return true from this function, but there
-- is one exception that we must check below.
- && not (isTypeDataTyCon tycon))
- -- An exception to this rule is `type data` declarations.
- -- Their data constructors only live at the type level and
- -- therefore do not need wrappers.
- -- See Note [Type data declarations] in GHC.Rename.Module.
- --
- -- Note that the other checks in this definition will
- -- return False for `type data` declarations, as:
- --
- -- - They cannot be newtypes
- -- - They cannot have strict fields
- -- - They cannot be data family instances
- -- - They cannot have datatype contexts
+
|| not (null stupid_theta)
-- If the data constructor has a datatype context,
-- we need a wrapper in order to drop the stupid arguments.
diff --git a/testsuite/tests/type-data/should_run/T24620.hs b/testsuite/tests/type-data/should_run/T24620.hs
new file mode 100644
index 000000000000..bbb1a9c7276c
--- /dev/null
+++ b/testsuite/tests/type-data/should_run/T24620.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeData #-}
+
+module Main where
+
+type data Nat = Zero | Succ Nat
+
+main :: IO ()
+main = pure ()
diff --git a/testsuite/tests/type-data/should_run/all.T b/testsuite/tests/type-data/should_run/all.T
index a929da530bb8..115705d8d2c8 100644
--- a/testsuite/tests/type-data/should_run/all.T
+++ b/testsuite/tests/type-data/should_run/all.T
@@ -2,3 +2,4 @@ test('T22332a', exit_code(1), compile_and_run, [''])
test('T22315b', extra_files(['T22315b.hs']), ghci_script, ['T22315b.script'])
test('T22500', normal, compile_and_run, [''])
test('T22948a', normal, compile_and_run, [''])
+test('T24620', normal, compile_and_run, [''])
--
GitLab