diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2022-08-31 21:55:19 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-09-01 01:19:26 -0400 |
commit | 7d3a055d4df6842f8fbcfbc1ca96e2a45a47d351 (patch) | |
tree | 5536bc1dfd93ee52d0ce987d64911b1434e8257e | |
parent | 15111af6adb1c85af5b17088134c9e71bee025e3 (diff) | |
download | haskell-7d3a055d4df6842f8fbcfbc1ca96e2a45a47d351.tar.gz |
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
-rw-r--r-- | compiler/GHC/Core.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Coercion.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Type.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/TyCl/PatSyn.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 2 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/corelint/T21115b.stderr | 2 |
12 files changed, 19 insertions, 40 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index ad1d87feae..4e58df6fc9 100644 --- a/compiler/GHC/Core.hs +++ b/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: diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index d1a9efc843..dc3f7d277f 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/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 diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index c2fc84687e..14d5c88262 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/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 diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 5e769acaa9..86b868566c 100644 --- a/compiler/GHC/Core/Type.hs +++ b/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 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index c8dd400c23..9d03c434f6 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/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 diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 1acc52fad0..702ded54a3 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/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) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index e6ecf795dd..7eb60afd78 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/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 diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 814e5640a2..8076d575ac 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/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 diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 2806ad1bd0..be10faaca3 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/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 diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index e1c9ceb054..bd8204f856 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/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 diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 4eb9cd9324..c1ce849651 100644 --- a/ghc/GHCi/UI.hs +++ b/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 diff --git a/testsuite/tests/corelint/T21115b.stderr b/testsuite/tests/corelint/T21115b.stderr index 1b245cf3c7..199b999f1f 100644 --- a/testsuite/tests/corelint/T21115b.stderr +++ b/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# } |