[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Add regression test for #21550
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 1 09:51:17 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
15111af6 by Zubin Duggal at 2022-09-01T01:18:50-04:00
Add regression test for #21550
This was fixed by ca90ffa321a31842a32be1b5b6e26743cd677ec5
"Use local instances with least superclass depth"
- - - - -
7d3a055d by Krzysztof Gogolewski at 2022-09-01T01:19:26-04:00
Minor cleanup
- Remove mkHeteroCoercionType, sdocImpredicativeTypes, isStateType (unused),
isCoVar_maybe (duplicated by getCoVar_maybe)
- Replace a few occurrences of voidPrimId with (# #).
void# is a deprecated synonym for the unboxed tuple.
- Use showSDoc in :show linker.
This makes it consistent with the other :show commands
- - - - -
3ccc27db by Tommy Bidne at 2022-09-01T05:50:57-04:00
Change Ord defaults per CLC proposal
Approved by CLC in https://github.com/haskell/core-libraries-committee/issues/24#issuecomment-1233331267
- - - - -
fce81df1 by Matthew Pickering at 2022-09-01T05:50:57-04:00
Fix bootstrap with ghc-9.0
It turns out Solo is a very recent addition to base, so for older GHC
versions we just defined it inline here the one place we use it in the
compiler.
- - - - -
18 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Types/Id/Make.hs
- compiler/GHC/Utils/Outputable.hs
- docs/users_guide/9.6.1-notes.rst
- ghc/GHCi/UI.hs
- libraries/base/changelog.md
- libraries/ghc-prim/GHC/Classes.hs
- testsuite/tests/corelint/T21115b.stderr
- + testsuite/tests/typecheck/should_compile/T21550.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -772,7 +772,7 @@ However, join points have simpler invariants in other ways
e.g. let j :: Int# = factorial x in ...
6. The RHS of join point is not required to have a fixed runtime representation,
- e.g. let j :: r :: TYPE l = fail void# in ...
+ e.g. let j :: r :: TYPE l = fail (##) in ...
This happened in an intermediate program #13394
Examples:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -45,7 +45,6 @@ module GHC.Core.Coercion (
mkKindCo,
castCoercionKind, castCoercionKind1, castCoercionKind2,
- mkHeteroCoercionType,
mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
@@ -77,7 +76,6 @@ module GHC.Core.Coercion (
-- ** Coercion variables
mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
- isCoVar_maybe,
-- ** Free variables
tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,
@@ -521,7 +519,9 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args
-- didn't have enough binders
go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)
--- | Attempts to obtain the type variable underlying a 'Coercion'
+-- | Extract a covar, if possible. This check is dirty. Be ashamed
+-- of yourself. (It's dirty because it cares about the structure of
+-- a coercion, which is morally reprehensible.)
getCoVar_maybe :: Coercion -> Maybe CoVar
getCoVar_maybe (CoVarCo cv) = Just cv
getCoVar_maybe _ = Nothing
@@ -953,13 +953,6 @@ it's a relatively expensive test and perhaps better done in
optCoercion. Not a big deal either way.
-}
--- | Extract a covar, if possible. This check is dirty. Be ashamed
--- of yourself. (It's dirty because it cares about the structure of
--- a coercion, which is morally reprehensible.)
-isCoVar_maybe :: Coercion -> Maybe CoVar
-isCoVar_maybe (CoVarCo cv) = Just cv
-isCoVar_maybe _ = Nothing
-
mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion]
-> Coercion
-- mkAxInstCo can legitimately be called over-staturated;
@@ -2558,11 +2551,6 @@ mkCoercionType Phantom = \ty1 ty2 ->
in
TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]
-mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type
-mkHeteroCoercionType Nominal = mkHeteroPrimEqPred
-mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred
-mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType"
-
-- | Creates a primitive type equality predicate.
-- Invariant: the types are not Coercions
mkPrimEqPred :: Type -> Type -> Type
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Prelude
import GHC.Platform
-import GHC.Types.Id.Make ( voidPrimId )
+import GHC.Types.Id.Make ( unboxedUnitExpr )
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Types.Name.Occurrence ( occNameFS )
@@ -2107,7 +2107,7 @@ builtinBignumRules =
let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v
platform <- getPlatform
if x < y
- then ret 1 $ Var voidPrimId
+ then ret 1 unboxedUnitExpr
else ret 2 $ mkNaturalExpr platform (x - y)
-- unary operations
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-
ToDo [Oct 2013]
~~~~~~~~~~~~~~~
@@ -974,6 +975,14 @@ lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
scSubstId :: ScEnv -> InId -> OutExpr
scSubstId env v = lookupIdSubst (sc_subst env) v
+
+-- Solo is only defined in base starting from ghc-9.2
+#if !(MIN_VERSION_base(4, 16, 0))
+
+data Solo a = Solo a
+
+#endif
+
-- The !subst ensures that we force the selection `(sc_subst env)`, which avoids
-- retaining all of `env` when we only need `subst`. The `Solo` means that the
-- substitution itself is lazy, because that type is often discarded.
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -129,7 +129,6 @@ module GHC.Core.Type (
isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,
kindBoxedRepLevity_maybe,
mightBeLiftedType, mightBeUnliftedType,
- isStateType,
isAlgType, isDataFamilyAppType,
isPrimitiveType, isStrictType,
isLevityTy, isLevityVar,
@@ -2482,13 +2481,6 @@ isUnliftedType ty =
Nothing ->
pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))
--- | State token type.
-isStateType :: Type -> Bool
-isStateType ty
- = case tyConAppTyCon_maybe ty of
- Just tycon -> tycon == statePrimTyCon
- _ -> False
-
-- | Returns:
--
-- * 'False' if the type is /guaranteed/ unlifted or
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -5023,7 +5023,6 @@ initSDocContext dflags style = SDC
, sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags
, sdocErrorSpans = gopt Opt_ErrorSpans dflags
, sdocStarIsType = xopt LangExt.StarIsType dflags
- , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
, sdocListTuplePuns = True
, sdocPrintTypeAbbreviations = True
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -795,7 +795,7 @@ dsHsConLike (PatSynCon ps)
= do { builder_id <- dsLookupGlobalId builder_name
; return (if add_void
then mkCoreApp (text "dsConLike" <+> ppr ps)
- (Var builder_id) (Var voidPrimId)
+ (Var builder_id) unboxedUnitExpr
else Var builder_id) }
| otherwise
= pprPanic "dsConLike" (ppr ps)
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -917,7 +917,7 @@ mkFailurePair expr
; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy
; let real_arg = setOneShotLambda fail_fun_arg
; return (NonRec fail_fun_var (Lam real_arg expr),
- App (Var fail_fun_var) (Var voidPrimId)) }
+ App (Var fail_fun_var) unboxedUnitExpr) }
where
ty = exprType expr
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -56,7 +56,6 @@ import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Types.Var.Set
-import GHC.Types.Id.Make
import GHC.Tc.TyCl.Utils
import GHC.Core.ConLike
import GHC.Types.FieldLabel
@@ -796,8 +795,8 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
res_ty = mkTyVarTy res_tv
is_unlifted = null args && null prov_dicts
(cont_args, cont_arg_tys)
- | is_unlifted = ([nlHsVar voidPrimId], [unboxedUnitTy])
- | otherwise = (args, arg_tys)
+ | is_unlifted = ([nlHsDataCon unboxedUnitDataCon], [unboxedUnitTy])
+ | otherwise = (args, arg_tys)
cont_ty = mkInfSigmaTy ex_tvs prov_theta $
mkVisFunTysMany cont_arg_tys res_ty
@@ -818,7 +817,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
- fail' = nlHsApps fail [nlHsVar voidPrimId]
+ fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon]
args = map nlVarPat [scrutinee, cont, fail]
lwpat = noLocA $ WildPat pat_ty
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -25,6 +25,7 @@ module GHC.Types.Id.Make (
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
DataConBangOpts (..), BangOpts (..),
+ unboxedUnitExpr,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
@@ -1812,9 +1813,10 @@ voidPrimId :: Id -- Global constant :: Void#
-- We cannot define it in normal Haskell, since it's
-- a top-level unlifted value.
voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy
- (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs)
- where rhs = Var (dataConWorkId unboxedUnitDataCon)
+ (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts unboxedUnitExpr)
+unboxedUnitExpr :: CoreExpr
+unboxedUnitExpr = Var (dataConWorkId unboxedUnitDataCon)
voidArgId :: Id -- Local lambda-bound :: Void#
voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many unboxedUnitTy
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -390,7 +390,6 @@ data SDocContext = SDC
, sdocErrorSpans :: !Bool
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
- , sdocImpredicativeTypes :: !Bool
, sdocListTuplePuns :: !Bool
, sdocPrintTypeAbbreviations :: !Bool
, sdocUnitIdForUser :: !(FastString -> SDoc)
@@ -450,7 +449,6 @@ defaultSDocContext = SDC
, sdocSuppressStgExts = False
, sdocErrorSpans = False
, sdocStarIsType = False
- , sdocImpredicativeTypes = False
, sdocLinearTypes = False
, sdocListTuplePuns = True
, sdocPrintTypeAbbreviations = True
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -94,6 +94,10 @@ This can be convenient when pasting large multi-line blocks of code into GHCi.
label (:base-ref:`GHC.Conc.threadLabel`) and status
(:base-ref:`GHC.Conc.threadStatus`).
+- Change default ``Ord`` implementation of ``(>=)``, ``(>)``, and ``(<)`` to use
+ ``(<=)`` instead of ``compare`` per CLC proposal:
+ https://github.com/haskell/core-libraries-committee/issues/24
+
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Driver.Config.Diagnostic
import qualified GHC
import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
Resume, SingleStep, Ghc,
- GetDocsFailure(..), putLogMsgM, pushLogHookM,
+ GetDocsFailure(..), pushLogHookM,
getModuleGraph, handleSourceError, ms_mod )
import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)
import GHC.Hs.ImpExp
@@ -3289,7 +3289,8 @@ showCmd str = do
, action "bindings" $ showBindings
, action "linker" $ do
msg <- liftIO $ Loader.showLoaderState (hscInterp hsc_env)
- putLogMsgM MCDump noSrcSpan msg
+ dflags <- getDynFlags
+ liftIO $ putStrLn $ showSDoc dflags msg
, action "breaks" $ showBkptTable
, action "context" $ showContext
, action "packages" $ showUnits
=====================================
libraries/base/changelog.md
=====================================
@@ -22,6 +22,9 @@
* `GHC.Conc.Sync.threadLabel` was added, allowing the user to query the label
of a given `ThreadId`.
* Add `inits1` and `tails1` to `Data.List.NonEmpty`.
+ * Change default `Ord` implementation of `(>=)`, `(>)`, and `(<)` to use
+ `(<=)` instead of `compare` per
+ [Core Libraries proposal](https://github.com/haskell/core-libraries-committee/issues/24).
## 4.17.0.0 *August 2022*
=====================================
libraries/ghc-prim/GHC/Classes.hs
=====================================
@@ -333,10 +333,11 @@ class (Eq a) => Ord a where
else if x <= y then LT
else GT
- x < y = case compare x y of { LT -> True; _ -> False }
x <= y = case compare x y of { GT -> False; _ -> True }
- x > y = case compare x y of { GT -> True; _ -> False }
- x >= y = case compare x y of { LT -> False; _ -> True }
+ x >= y = y <= x
+ x > y = not (x <= y)
+ x < y = not (y <= x)
+
-- These two default methods use '<=' rather than 'compare'
-- because the latter is often more expensive
=====================================
testsuite/tests/corelint/T21115b.stderr
=====================================
@@ -22,7 +22,7 @@ foo
case patError "T21115b.hs:(10,4)-(15,4)|\\case"# of wild { } } in
let { fail = \ ds -> 5# } in
case ds of ds {
- __DEFAULT -> fail void#;
+ __DEFAULT -> fail (##);
0.0## -> 2#;
2.0## -> 3#
}
=====================================
testsuite/tests/typecheck/should_compile/T21550.hs
=====================================
@@ -0,0 +1,39 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Main where
+
+import Data.Function
+import Data.Kind
+import GHC.Generics
+import GHC.TypeLits
+
+-- inlined generic-data imports:
+from' :: Generic a => a -> Rep a ()
+from' = from
+
+geq :: (Generic a, Eq (Rep a ())) => a -> a -> Bool
+geq = (==) `on` from'
+
+gcompare :: (Generic a, Ord (Rep a ())) => a -> a -> Ordering
+gcompare = compare `on` from'
+
+
+-- test case:
+data A (v :: Symbol -> Type -> Type) a b deriving (Generic,Generic1)
+
+instance (Eq a , (forall w z . Eq z => Eq (v w z)) , Eq b) => Eq (A v a b) where
+ {-# INLINE (==) #-}
+ (==) = geq
+
+instance (Ord a , (forall w z . Eq z => Eq (v w z)) , (forall w z . Ord z => Ord (v w z)) , Ord b) => Ord (A v a b) where
+ {-# INLINE compare #-}
+ compare = gcompare
+
+main :: IO ()
+main = pure ()
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -855,3 +855,4 @@ test('DeepSubsumption08', normal, compile, [''])
test('DeepSubsumption09', normal, compile, [''])
test('T21951a', normal, compile, ['-Wredundant-strictness-flags'])
test('T21951b', normal, compile, ['-Wredundant-strictness-flags'])
+test('T21550', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4307eb2f67e08ed761469949ed8d8379d1decc0f...fce81df1c5d187c23acc16cb3f8e6978bf003d2a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4307eb2f67e08ed761469949ed8d8379d1decc0f...fce81df1c5d187c23acc16cb3f8e6978bf003d2a
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/20220901/80c9df76/attachment-0001.html>
More information about the ghc-commits
mailing list