[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon May 15 10:46:53 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
902f0730 by Simon Peyton Jones at 2023-05-13T14:58:34-04:00
Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever
As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the
table, failing to unpack arguments that are perfectly unpackable.
The fix is pretty easy; see Note [Recursive unboxing]
- - - - -
a5451438 by sheaf at 2023-05-13T14:59:13-04:00
Fix bad multiplicity role in tyConAppFunCo_maybe
The function tyConAppFunCo_maybe produces a multiplicity coercion
for the multiplicity argument of the function arrow, except that
it could be at the wrong role if asked to produce a representational
coercion. We fix this by using the 'funRole' function, which computes
the right roles for arguments to the function arrow TyCon.
Fixes #23386
- - - - -
eb081cb2 by sheaf at 2023-05-15T06:46:36-04:00
Turn "ambiguous import" error into a panic
This error should never occur, as a lookup of a type or data constructor
should never be ambiguous. This is because a single module cannot export
multiple Names with the same OccName, as per item (1) of
Note [Exporting duplicate declarations] in GHC.Tc.Gen.Export.
This code path was intended to handle duplicate record fields, but the
rest of the code had since been refactored to handle those in a
different way.
We also remove the AmbiguousImport constructor of IELookupError, as
it is no longer used.
Fixes #23302
- - - - -
a6b1fe86 by M Farkas-Dyck at 2023-05-15T06:46:44-04:00
Unbreak some tests with latest GNU grep, which now warns about stray '\'.
Confusingly, the testsuite mangled the error to say "stray /".
We also migrate some tests from grep to grep -E, as it seems the author actually wanted an "POSIX extended" (a.k.a. sane) regex.
Background: POSIX specifies 2 "regex" syntaxen: "basic" and "extended". Of these, only "extended" syntax is actually a regular expression. Furthermore, "basic" syntax is inconsistent in its use of the '\' character — sometimes it escapes a regex metacharacter, but sometimes it unescapes it, i.e. it makes an otherwise normal character become a metacharacter. This baffles me and it seems also the authors of these tests. Also, the regex(7) man page (at least on Linux) says "basic" syntax is obsolete. Nearly all modern tools and libraries are consistent in this use of the '\' character (of which many use "extended" syntax by default).
- - - - -
17 changed files:
- compiler/GHC/Core/Coercion.hs-boot
- compiler/GHC/Core/TyCo/Rep.hs-boot
- compiler/GHC/Core/Type.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/hsc2hs/Makefile
- testsuite/tests/numeric/should_run/Makefile
- testsuite/tests/numeric/should_run/T7014.primops
- testsuite/tests/simplCore/should_compile/Makefile
- + testsuite/tests/simplCore/should_compile/T23307.hs
- + testsuite/tests/simplCore/should_compile/T23307.stderr
- + testsuite/tests/simplCore/should_compile/T23307a.hs
- + testsuite/tests/simplCore/should_compile/T23307a.stderr
- + testsuite/tests/simplCore/should_compile/T23307b.hs
- + testsuite/tests/simplCore/should_compile/T23307c.hs
- + testsuite/tests/simplCore/should_compile/T23307c.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Coercion.hs-boot
=====================================
@@ -36,6 +36,8 @@ mkSubCo :: HasDebugCallStack => Coercion -> Coercion
mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
+funRole :: Role -> FunSel -> Role
+
isGReflCo :: Coercion -> Bool
isReflCo :: Coercion -> Bool
isReflexiveCo :: Coercion -> Bool
=====================================
compiler/GHC/Core/TyCo/Rep.hs-boot
=====================================
@@ -8,6 +8,7 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
data Type
data Coercion
+data FunSel
data CoSel
data UnivCoProvenance
data TyLit
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -274,7 +274,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
, mkTyConAppCo, mkAppCo
, mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo
, mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
- , mkKindCo, mkSubCo, mkFunCo
+ , mkKindCo, mkSubCo, mkFunCo, funRole
, decomposePiCos, coercionKind
, coercionRKind, coercionType
, isReflexiveCo, seqCo
@@ -1331,9 +1331,12 @@ tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]
-> Maybe Coercion
-- ^ Return Just if this TyConAppCo should be represented as a FunCo
tyConAppFunCo_maybe r tc cos
- | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos
- = Just (mkFunCo r af mult arg res)
- | otherwise = Nothing
+ | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos
+ = Just (mkFunCo r af mult arg res)
+ | otherwise
+ = Nothing
+ where
+ mult_refl = mkReflCo (funRole r SelMult) manyDataConTy
ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]
-> Maybe (FunTyFlag, a, a, a)
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -1196,27 +1196,42 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails
- -- Look up a RdrName used in an import, failing if it is ambiguous
- -- (e.g. because it refers to multiple record fields)
- lookup_name :: IE GhcPs -> RdrName -> IELookupM ImpOccItem
- lookup_name ie rdr = do
- xs <- lookup_names ie rdr
- case xs of
- [cax] -> return cax
- _ -> failLookupWith (AmbiguousImport rdr (map imp_item xs))
+ -- Look up a parent (type constructor, class or data constructor)
+ -- in an import.
+ lookup_parent :: IE GhcPs -> RdrName -> IELookupM ImpOccItem
+ lookup_parent ie rdr =
+ assertPpr (not $ isVarNameSpace ns)
+ (vcat [ text "filterImports lookup_parent: unexpected variable"
+ , text "rdr:" <+> ppr rdr
+ , text "namespace:" <+> pprNameSpace ns ]) $
+ do { xs <- lookup_names ie rdr
+ ; case xs of
+ cax :| [] -> return cax
+ _ -> pprPanic "filter_imports lookup_parent ambiguous" $
+ vcat [ text "rdr:" <+> ppr rdr
+ , text "lookups:" <+> ppr (fmap imp_item xs) ] }
+ -- Looking up non-variables is always unambiguous,
+ -- as there can be at most one corresponding item
+ -- in the imp_occ_env.
+ -- See item (1) of Note [Exporting duplicate declarations]
+ -- in GHC.Tc.Gen.Export.
+ where
+ occ = rdrNameOcc rdr
+ ns = occNameSpace occ
-- Look up a RdrName used in an import, returning multiple values if there
-- are several fields with the same name exposed by the module
- lookup_names :: IE GhcPs -> RdrName -> IELookupM [ImpOccItem]
+ lookup_names :: IE GhcPs -> RdrName -> IELookupM (NonEmpty ImpOccItem)
lookup_names ie rdr
| isQual rdr
= failLookupWith (QualImportError rdr)
- | null lookups
- = failLookupWith (BadImport ie BadImportIsParent)
| otherwise
- = return $ concatMap nonDetNameEnvElts lookups
+ = case lookups of
+ [] -> failLookupWith (BadImport ie BadImportIsParent)
+ item:items -> return $ item :| items
where
- lookups = lookupOccEnv_WithFields imp_occ_env (rdrNameOcc rdr)
+ lookups = concatMap nonDetNameEnvElts
+ $ lookupOccEnv_WithFields imp_occ_env (rdrNameOcc rdr)
lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])]
lookup_lie (L loc ieRdr)
@@ -1248,10 +1263,9 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
Succeeded a -> return (Just a)
lookup_err_msg err = case err of
- BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails
- IllegalImport -> pure ImportLookupIllegal
+ BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails
+ IllegalImport -> pure ImportLookupIllegal
QualImportError rdr -> pure (ImportLookupQualified rdr)
- AmbiguousImport rdr xs -> pure (ImportLookupAmbiguous rdr xs)
-- For each import item, we convert its RdrNames to Names,
-- and at the same time compute all the GlobalRdrElt corresponding
@@ -1269,12 +1283,12 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
-- See Note [Importing DuplicateRecordFields]
xs <- lookup_names ie (ieWrappedName n)
return ( [ (IEVar noExtField (L l (replaceWrappedName n name)), [gre])
- | ImpOccItem { imp_item = gre } <- xs
+ | ImpOccItem { imp_item = gre } <- NE.toList xs
, let name = greName gre ]
, [] )
IEThingAll _ (L l tc) -> do
- ImpOccItem gre child_gres _ <- lookup_name ie $ ieWrappedName tc
+ ImpOccItem gre child_gres _ <- lookup_parent ie $ ieWrappedName tc
let name = greName gre
warns
@@ -1299,19 +1313,19 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
-- Here the 'C' can be a data constructor
-- *or* a type/class, or even both
-> let tc = ieWrappedName tc'
- tc_name = lookup_name ie tc
- dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
+ tc_name = lookup_parent ie tc
+ dc_name = lookup_parent ie (setRdrNameSpace tc srcDataName)
in
case catIELookupM [ tc_name, dc_name ] of
[] -> failLookupWith (BadImport ie BadImportIsParent)
names -> return ([mkIEThingAbs tc' l (imp_item name) | name <- names], [])
| otherwise
- -> do ImpOccItem { imp_item = gre } <- lookup_name ie (ieWrappedName tc')
+ -> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc')
return ([mkIEThingAbs tc' l gre], [])
IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do
ImpOccItem { imp_item = gre, imp_bundled = subnames }
- <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)
+ <- lookup_parent (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)
let name = greName gre
-- Look up the children in the sub-names of the parent
@@ -1358,7 +1372,6 @@ data IELookupError
= QualImportError RdrName
| BadImport (IE GhcPs) BadImportIsSubordinate
| IllegalImport
- | AmbiguousImport RdrName [GlobalRdrElt] -- e.g. a duplicated field name as a top-level import
failLookupWith :: IELookupError -> IELookupM a
failLookupWith err = Failed err
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1053,8 +1053,7 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
arg_ty' = case mb_co of
{ Just redn -> scaledSet arg_ty (reductionReducedType redn)
; Nothing -> arg_ty }
- , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')
- , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'
+ , shouldUnpackArgTy bang_opts unpk_prag fam_envs arg_ty'
= if bang_opt_unbox_disable bang_opts
then HsStrict True -- Not unpacking because of -O0
-- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
@@ -1329,69 +1328,95 @@ mkUbxSumAltTy :: [Type] -> Type
mkUbxSumAltTy [ty] = ty
mkUbxSumAltTy tys = mkTupleTy Unboxed tys
-shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
+shouldUnpackArgTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool
-- True if we ought to unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
-shouldUnpackTy bang_opts prag fam_envs ty
- | Just data_cons <- unpackable_type_datacons (scaledThing ty)
- = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons
+shouldUnpackArgTy bang_opts prag fam_envs arg_ty
+ | Just data_cons <- unpackable_type_datacons (scaledThing arg_ty)
+ , all ok_con data_cons -- Returns True only if we can't get a
+ -- loop involving these data cons
+ , should_unpack prag arg_ty data_cons -- ...hence the call to dataConArgUnpack in
+ -- should_unpack won't loop
+ -- See Wrinkle (W1b) of Note [Recursive unboxing] for this loopy stuff
+ = True
+
| otherwise
= False
where
- ok_con_args :: NameSet -> DataCon -> Bool
- ok_con_args dcs con
- | dc_name `elemNameSet` dcs
- = False
- | otherwise
- = all (ok_arg dcs')
- (dataConOrigArgTys con `zip` dataConSrcBangs con)
- -- NB: dataConSrcBangs gives the *user* request;
- -- We'd get a black hole if we used dataConImplBangs
+ ok_con :: DataCon -> Bool -- True <=> OK to unpack
+ ok_con top_con -- False <=> not safe
+ = ok_args emptyNameSet top_con
where
- dc_name = getName con
- dcs' = dcs `extendNameSet` dc_name
-
- ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
- ok_arg dcs (Scaled _ ty, bang)
- = not (attempt_unpack bang) || ok_ty dcs norm_ty
- where
- norm_ty = topNormaliseType fam_envs ty
+ top_con_name = getName top_con
- ok_ty :: NameSet -> Type -> Bool
- ok_ty dcs ty
- | Just data_cons <- unpackable_type_datacons ty
- = all (ok_con_args dcs) data_cons
- | otherwise
- = True -- NB True here, in contrast to False at top level
-
- attempt_unpack :: HsSrcBang -> Bool
- attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
- = bang_opt_strict_data bang_opts
- attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
- = True
- attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
- = True -- Be conservative
- attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
- = bang_opt_strict_data bang_opts -- Be conservative
- attempt_unpack _ = False
-
- -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not.
- should_unpack data_cons =
+ ok_args dcs con
+ = all (ok_arg dcs) $
+ (dataConOrigArgTys con `zip` dataConSrcBangs con)
+ -- NB: dataConSrcBangs gives the *user* request;
+ -- We'd get a black hole if we used dataConImplBangs
+
+ ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool
+ ok_arg dcs (Scaled _ ty, HsSrcBang _ unpack_prag str_prag)
+ | strict_field str_prag
+ , Just data_cons <- unpackable_type_datacons (topNormaliseType fam_envs ty)
+ , should_unpack_conservative unpack_prag data_cons -- Wrinkle (W3)
+ = all (ok_rec_con dcs) data_cons -- of Note [Recursive unboxing]
+ | otherwise
+ = True -- NB True here, in contrast to False at top level
+
+ -- See Note [Recursive unboxing]
+ -- * Do not look at the HsImplBangs to `con`; see Wrinkle (W1a)
+ -- * For the "at the root" comments see Wrinkle (W2)
+ ok_rec_con dcs con
+ | dc_name == top_con_name = False -- Recursion at the root
+ | dc_name `elemNameSet` dcs = True -- Not at the root
+ | otherwise = ok_args (dcs `extendNameSet` dc_name) con
+ where
+ dc_name = getName con
+
+ strict_field :: SrcStrictness -> Bool
+ -- True <=> strict field
+ strict_field NoSrcStrict = bang_opt_strict_data bang_opts
+ strict_field SrcStrict = True
+ strict_field SrcLazy = False
+
+ -- Determine whether we ought to unpack a field,
+ -- based on user annotations if present.
+ -- A conservative version of should_unpack that doesn't look at how
+ -- many fields the field would unpack to... because that leads to a loop.
+ -- "Conservative" = err on the side of saying "yes".
+ should_unpack_conservative :: SrcUnpackedness -> [DataCon] -> Bool
+ should_unpack_conservative SrcNoUnpack _ = False -- {-# NOUNPACK #-}
+ should_unpack_conservative SrcUnpack _ = True -- {-# NOUNPACK #-}
+ should_unpack_conservative NoSrcUnpack dcs = not (is_sum dcs)
+ -- is_sum: we never unpack sums without a pragma; otherwise be conservative
+
+ -- Determine whether we ought to unpack a field,
+ -- based on user annotations if present, and heuristics if not.
+ should_unpack :: SrcUnpackedness -> Scaled Type -> [DataCon] -> Bool
+ should_unpack prag arg_ty data_cons =
case prag of
SrcNoUnpack -> False -- {-# NOUNPACK #-}
SrcUnpack -> True -- {-# UNPACK #-}
NoSrcUnpack -- No explicit unpack pragma, so use heuristics
- | (_:_:_) <- data_cons
- -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK.
- | otherwise
+ | is_sum data_cons
+ -> False -- Don't unpack sum types automatically, but they can
+ -- be unpacked with an explicit source UNPACK.
+ | otherwise -- Wrinkle (W4) of Note [Recursive unboxing]
-> bang_opt_unbox_strict bang_opts
|| (bang_opt_unbox_small bang_opts
&& rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
- where (rep_tys, _) = dataConArgUnpack ty
+ where
+ (rep_tys, _) = dataConArgUnpack arg_ty
+ is_sum :: [DataCon] -> Bool
+ -- We never unpack sum types automatically
+ -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)
+ is_sum (_:_:_) = True
+ is_sum _ = False
-- Given a type already assumed to have been normalized by topNormaliseType,
-- unpackable_type_datacons ty = Just datacons
@@ -1403,11 +1428,11 @@ shouldUnpackTy bang_opts prag fam_envs ty
unpackable_type_datacons :: Type -> Maybe [DataCon]
unpackable_type_datacons ty
| Just (tc, _) <- splitTyConApp_maybe ty
- , not (isNewTyCon tc)
- -- Even though `ty` has been normalised, it could still
- -- be a /recursive/ newtype, so we must check for that
+ , not (isNewTyCon tc) -- Even though `ty` has been normalised, it could still
+ -- be a /recursive/ newtype, so we must check for that
, Just cons <- tyConDataCons_maybe tc
- , not (null cons)
+ , not (null cons) -- Don't upack nullary sums; no need.
+ -- They already take zero bits
, all (null . dataConExTyCoVars) cons
= Just cons -- See Note [Unpacking GADTs and existentials]
| otherwise
@@ -1463,21 +1488,75 @@ But be careful not to try to unbox this!
data T = MkT {-# UNPACK #-} !T Int
Because then we'd get an infinite number of arguments.
-Here is a more complicated case:
- data S = MkS {-# UNPACK #-} !T Int
- data T = MkT {-# UNPACK #-} !S Int
-Each of S and T must decide independently whether to unpack
-and they had better not both say yes. So they must both say no.
-
-Also behave conservatively when there is no UNPACK pragma
- data T = MkS !T Int
-with -funbox-strict-fields or -funbox-small-strict-fields
-we need to behave as if there was an UNPACK pragma there.
-
-But it's the *argument* type that matters. This is fine:
+Note that it's the *argument* type that matters. This is fine:
data S = MkS S !Int
because Int is non-recursive.
+Wrinkles:
+
+(W1a) We have to be careful that the compiler doesn't go into a loop!
+ First, we must not look at the HsImplBang decisions of data constructors
+ in the same mutually recursive group. E.g.
+ data S = MkS {-# UNPACK #-} !T Int
+ data T = MkT {-# UNPACK #-} !S Int
+ Each of S and T must decide /independently/ whether to unpack
+ and they had better not both say yes. So they must both say no.
+ (We could detect when we leave the group, and /then/ we can rely on
+ HsImplBangs; but that requires more plumbing.)
+
+(W1b) Here is another way the compiler might go into a loop (test T23307b):
+ data data T = MkT !S Int
+ data S = MkS !T
+ Suppose we call `shouldUnpackArgTy` on the !S arg of `T`. In `should_unpack`
+ we ask if the number of fields that `MkS` unpacks to is small enough
+ (via rep_tys `lengthAtMost` 1). But how many field /does/ `MkS` unpack
+ to? Well it depends on the unpacking decision we make for `MkS`, which
+ in turn depends on `MkT`, which we are busy deciding. Black holes beckon.
+
+ So we /first/ call `ok_con` on `MkS` (and `ok_con` is conservative;
+ see `should_unpack_conservative`), and only /then/ call `should_unpack`.
+ Tricky!
+
+(W2) As #23307 shows, we /do/ want to unpack the second arg of the Yes
+ data constructor in this example, despite the recursion in List:
+ data Stream a = Cons a !(Stream a)
+ data Unconsed a = Unconsed a !(Stream a)
+ data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
+ When looking at
+ {-# UNPACK #-} (Unconsed a)
+ we can take Unconsed apart, but then get into a loop with Stream.
+ That's fine: we can still take Unconsed apart. It's only if we
+ have a loop /at the root/ that we must not unpack.
+
+(W3) Moreover (W2) can apply even if there is a recursive loop:
+ data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
+ data Unconsed a = Unconsed a !(List a)
+ Here there is mutual recursion between `Unconsed` and `List`; and yet
+ we can unpack the field of `Cons` because we will not unpack the second
+ field of `Unconsed`: we never unpack a sum type without an explicit
+ pragma (see should_unpack).
+
+(W4) Consider
+ data T = MkT !Wombat
+ data Wombat = MkW {-# UNPACK #-} !S Int
+ data S = MkS {-# NOUNPACK #-} !Wombat Int
+ Suppose we are deciding whether to unpack the first field of MkT, by
+ calling (shouldUnpackArgTy Wombat). Then we'll try to unpack the !S field
+ of MkW, and be stopped by the {-# NOUNPACK #-}, and all is fine; we can
+ unpack MkT.
+
+ If that NOUNPACK had been a UNPACK, though, we'd get a loop, and would
+ decide not to unpack the Wombat field of MkT.
+
+ But what if there was no pragma in `data S`? Then we /still/ decide not
+ to unpack the Wombat field of MkT (at least when auto-unpacking is on),
+ because we don't know for sure which decision will be taken for the
+ Wombat field of MkS.
+
+ TL;DR when there is no pragma, behave as if there was a UNPACK, at least
+ when auto-unpacking is on. See `should_unpack` in `shouldUnpackArgTy`.
+
+
************************************************************************
* *
Wrapping and unwrapping newtypes and type families
=====================================
testsuite/tests/hsc2hs/Makefile
=====================================
@@ -52,9 +52,9 @@ T11004:
T12504:
'$(HSC2HS)' $(HSC2HS_OPTS) T12504/path/to/$@.hsc
ifeq "$(WINDOWS)" "YES"
- grep '{-# LINE 1 \"T12504\\\\path\\\\to\\\\$@\.hsc\" #-}' T12504/path/to/$@.hs
+ grep '{-# LINE 1 "T12504\\\\path\\\\to\\\\$@\.hsc" #-}' T12504/path/to/$@.hs
else
- grep '{-# LINE 1 \"T12504/path/to/$@\.hsc\" #-}' T12504/path/to/$@.hs
+ grep '{-# LINE 1 "T12504/path/to/$@\.hsc" #-}' T12504/path/to/$@.hs
endif
.PHONY: T15758
=====================================
testsuite/tests/numeric/should_run/Makefile
=====================================
@@ -6,5 +6,5 @@ include $(TOP)/mk/test.mk
T7014:
rm -f T7014.simpl T7014.o T7014.hi
'$(TEST_HC)' -Wall -v0 -O --make T7014.hs -fforce-recomp -ddump-simpl > T7014.simpl
- ! grep -q -f T7014.primops T7014.simpl
+ ! grep -Eq -f T7014.primops T7014.simpl
./T7014
=====================================
testsuite/tests/numeric/should_run/T7014.primops
=====================================
@@ -2,7 +2,7 @@ and#
or#
uncheckedShift.*#
\+#
-\-#
+-#
\*#
quotInt#
remInt#
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -254,7 +254,7 @@ str-rules:
# g should have been collapsed into one defininition by CSE.
.PHONY: T13340
T13340:
- '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13340.hs -ddump-simpl -dsuppress-all | grep -c '\+#'
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13340.hs -ddump-simpl -dsuppress-all | grep -Ec '\+#'
# We expect to see all dictionaries specialized away.
=====================================
testsuite/tests/simplCore/should_compile/T23307.hs
=====================================
@@ -0,0 +1,5 @@
+module T23307 where
+
+data Stream a = Nil | Cons a !(Stream a)
+data Unconsed a = Unconsed a !(Stream a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
=====================================
testsuite/tests/simplCore/should_compile/T23307.stderr
=====================================
@@ -0,0 +1,72 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 29, types: 40, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307.$WYes [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307.Yes @a unbx unbx1
+ }}]
+T23307.$WYes
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307.Yes @a unbx unbx1
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> Stream a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Unconsed @a conrep conrep2
+ }}]
+T23307.$WUnconsed
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Unconsed @a conrep conrep2
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307.$WCons [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> Stream a %1 -> Stream a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Cons @a conrep conrep2
+ }}]
+T23307.$WCons
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: Stream a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307.Cons @a conrep conrep2
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T23307a.hs
=====================================
@@ -0,0 +1,7 @@
+module T23307a where
+
+data List a = Nil | Cons {-# UNPACK #-} !(Unconsed a)
+ -- This UNPACK should work
+
+data Unconsed a = Unconsed a !(List a)
+data MUnconsed a = No | Yes {-# UNPACK #-} !(Unconsed a)
\ No newline at end of file
=====================================
testsuite/tests/simplCore/should_compile/T23307a.stderr
=====================================
@@ -0,0 +1,68 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 28, types: 41, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WYes [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> MUnconsed a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Yes @a unbx unbx1
+ }}]
+T23307a.$WYes
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Yes @a unbx unbx1
+ }
+
+-- RHS size: {terms: 9, types: 7, coercions: 0, joins: 0/0}
+T23307a.$WUnconsed [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. a %1 -> List a %1 -> Unconsed a
+[GblId[DataConWrapper],
+ Arity=2,
+ Str=<L><SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: List a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307a.Unconsed @a conrep conrep2
+ }}]
+T23307a.$WUnconsed
+ = \ (@a)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: List a) ->
+ case conrep1 of conrep2 [Occ=Once1] { __DEFAULT ->
+ T23307a.Unconsed @a conrep conrep2
+ }
+
+-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
+T23307a.$WCons [InlPrag=INLINE[final] CONLIKE]
+ :: forall a. Unconsed a %1 -> List a
+[GblId[DataConWrapper],
+ Arity=1,
+ Str=<SL>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Cons @a unbx unbx1
+ }}]
+T23307a.$WCons
+ = \ (@a) (conrep [Occ=Once1!] :: Unconsed a) ->
+ case conrep of { Unconsed unbx [Occ=Once1] unbx1 [Occ=Once1] ->
+ T23307a.Cons @a unbx unbx1
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T23307b.hs
=====================================
@@ -0,0 +1,7 @@
+module Foo where
+
+-- It's easy to get an infinite loop
+-- when deciding what to unbox here.
+
+data T = MkT !S Int
+data S = MkS !T
\ No newline at end of file
=====================================
testsuite/tests/simplCore/should_compile/T23307c.hs
=====================================
@@ -0,0 +1,7 @@
+module Foo where
+
+newtype Identity x = MkId x
+newtype Fix f = MkFix (f (Fix f))
+
+-- This test just checks that the compiler itself doesn't loop
+data Loop = LCon {-# UNPACK #-} !(Fix Identity)
=====================================
testsuite/tests/simplCore/should_compile/T23307c.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T23307c.hs:7:13: warning: [GHC-40091]
+ • Ignoring unusable UNPACK pragma on the first argument of ‘LCon’
+ • In the definition of data constructor ‘LCon’
+ In the data type declaration for ‘Loop’
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -479,3 +479,8 @@ test('T23024', normal, multimod_compile, ['T23024', '-O -v0'])
test('T23026', normal, compile, ['-O'])
test('T23267', [expect_broken(23267), only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -fspec-constr')], ghci_script, ['T23267.script'])
test('T23362', normal, compile, ['-O'])
+test('T23307', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T23307b', normal, compile, ['-O'])
+test('T23307c', normal, compile, ['-O'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f77a8c0295986c0e7d636741a5eeb61bb5e668df...a6b1fe863df264586a91d398eeca46d29cc981d2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f77a8c0295986c0e7d636741a5eeb61bb5e668df...a6b1fe863df264586a91d398eeca46d29cc981d2
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/20230515/6a1cf7cd/attachment-0001.html>
More information about the ghc-commits
mailing list