[Git][ghc/ghc][wip/minor-cleanup-void] Minor cleanup
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Wed Aug 31 19:55:57 UTC 2022
Krzysztof Gogolewski pushed to branch wip/minor-cleanup-void at Glasgow Haskell Compiler / GHC
Commits:
7c2d6a19 by Krzysztof Gogolewski at 2022-08-31T21:55:19+02: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
- - - - -
10 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/ConstantFold.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
- ghc/GHCi/UI.hs
Changes:
=====================================
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/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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c2d6a19c74398e4bbb261c0566758dce29920c7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7c2d6a19c74398e4bbb261c0566758dce29920c7
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/20220831/d3181e1d/attachment-0001.html>
More information about the ghc-commits
mailing list