[Git][ghc/ghc][wip/minor-cleanup-void] Minor cleanup

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Wed Aug 31 21:11:34 UTC 2022



Krzysztof Gogolewski pushed to branch wip/minor-cleanup-void at Glasgow Haskell Compiler / GHC


Commits:
40b5c4f8 by Krzysztof Gogolewski at 2022-08-31T23:11:08+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

- - - - -


12 changed files:

- compiler/GHC/Core.hs
- 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
- testsuite/tests/corelint/T21115b.stderr


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/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


=====================================
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#
       }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40b5c4f86b5ed167f03a53d8cf02880a3e6b7dfa

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40b5c4f86b5ed167f03a53d8cf02880a3e6b7dfa
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/6852da93/attachment-0001.html>


More information about the ghc-commits mailing list