[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Refine in-tree compiler args for --test-compiler=stage1
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Aug 31 23:29:05 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e8eaf807 by Matthew Pickering at 2022-08-31T18:27:57-04:00
Refine in-tree compiler args for --test-compiler=stage1
Some of the logic to calculate in-tree arguments was not correct for the
stage1 compiler. Namely we were not correctly reporting whether we were
building static or dynamic executables and whether debug assertions were
enabled.
Fixes #22096
- - - - -
6b2f7ffe by Matthew Pickering at 2022-08-31T18:27:57-04:00
Make ghcDebugAssertions into a Stage predicate (Stage -> Bool)
We also care whether we have debug assertions enabled for a stage one
compiler, but the way which we turned on the assertions was quite
different from the stage2 compiler. This makes the logic for turning on
consistent across both and has the advantage of being able to correct
determine in in-tree args whether a flavour enables assertions or not.
Ticket #22096
- - - - -
5371a3af by Zubin Duggal at 2022-08-31T19:28:43-04:00
Add regression test for #21550
This was fixed by ca90ffa321a31842a32be1b5b6e26743cd677ec5
"Use local instances with least superclass depth"
- - - - -
4307eb2f by Krzysztof Gogolewski at 2022-08-31T19:28:44-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
- - - - -
21 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
- hadrian/src/Flavour.hs
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/RunTest.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Flavours/Development.hs
- hadrian/src/Settings/Flavours/Validate.hs
- hadrian/src/Settings/Packages.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/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
=====================================
hadrian/src/Flavour.hs
=====================================
@@ -241,7 +241,10 @@ enableLateCCS = addArgs
-- | Enable assertions for the stage2 compiler
enableAssertions :: Flavour -> Flavour
-enableAssertions flav = flav { ghcDebugAssertions = True }
+enableAssertions flav = flav { ghcDebugAssertions = f }
+ where
+ f Stage2 = True
+ f st = ghcDebugAssertions flav st
-- | Produce fully statically-linked executables and build libraries suitable
-- for static linking.
=====================================
hadrian/src/Flavour/Type.hs
=====================================
@@ -35,7 +35,7 @@ data Flavour = Flavour {
-- | Build GHC with the debug RTS.
ghcDebugged :: Stage -> Bool,
-- | Build GHC with debug assertions.
- ghcDebugAssertions :: Bool,
+ ghcDebugAssertions :: Stage -> Bool,
-- | Build the GHC executable against the threaded runtime system.
ghcThreaded :: Stage -> Bool,
-- | Whether to build docs and which ones
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -17,6 +17,8 @@ import qualified Data.Set as Set
import Flavour
import qualified Context.Type as C
import System.Directory (findExecutable)
+import Settings.Program
+import qualified Context.Type
getTestSetting :: TestSetting -> Action String
getTestSetting key = testSetting key
@@ -91,16 +93,14 @@ inTreeCompilerArgs stg = do
return (dynamic `elem` ways, threaded `elem` ways)
-- MP: We should be able to vary if stage1/stage2 is dynamic, ie a dynamic stage1
-- should be able to built a static stage2?
- hasDynamic <- flavour >>= dynamicGhcPrograms
+ hasDynamic <- (dynamic ==) . Context.Type.way <$> (programContext stg ghc)
-- LeadingUnderscore is a property of the system so if cross-compiling stage1/stage2 could
-- have different values? Currently not possible to express.
leadingUnderscore <- flag LeadingUnderscore
- -- MP: This setting seems to only dictate whether we turn on optasm as a compiler
- -- way, but a lot of tests which use only_ways(optasm) seem to not test the NCG?
withInterpreter <- ghcWithInterpreter
unregisterised <- flag GhcUnregisterised
withSMP <- targetSupportsSMP
- debugAssertions <- ghcDebugAssertions <$> flavour
+ debugAssertions <- ($ stg) . ghcDebugAssertions <$> flavour
profiled <- ghcProfiled <$> flavour <*> pure stg
os <- setting HostOs
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -240,7 +240,7 @@ defaultFlavour = Flavour
, ghcProfiled = const False
, ghcDebugged = const False
, ghcThreaded = const True
- , ghcDebugAssertions = False
+ , ghcDebugAssertions = const False
, ghcDocs = cmdDocsArgs }
-- | Default logic for determining whether to build
=====================================
hadrian/src/Settings/Flavours/Development.hs
=====================================
@@ -15,7 +15,7 @@ developmentFlavour ghcStage = defaultFlavour
, libraryWays = pure $ Set.fromList [vanilla]
, rtsWays = pure $ Set.fromList [vanilla, debug, threaded, threadedDebug]
, dynamicGhcPrograms = return False
- , ghcDebugAssertions = True }
+ , ghcDebugAssertions = (>= Stage2) }
where
stageString Stage2 = "2"
stageString Stage1 = "1"
=====================================
hadrian/src/Settings/Flavours/Validate.hs
=====================================
@@ -23,6 +23,7 @@ validateFlavour = enableLinting $ werror $ defaultFlavour
[ dynamic, threadedDynamic, debugDynamic, threadedDebugDynamic
]
]
+ , ghcDebugAssertions = (<= Stage1)
}
validateArgs :: Args
@@ -33,15 +34,16 @@ validateArgs = sourceArgs SourceArgs
, notStage0 ? arg "-dno-debug-output"
]
, hsLibrary = pure ["-O"]
- , hsCompiler = mconcat [ stage0 ? pure ["-O2", "-DDEBUG"]
+ , hsCompiler = mconcat [ stage0 ? pure ["-O2"]
, notStage0 ? pure ["-O" ]
]
, hsGhc = pure ["-O"] }
+
slowValidateFlavour :: Flavour
slowValidateFlavour = validateFlavour
{ name = "slow-validate"
- , ghcDebugAssertions = True
+ , ghcDebugAssertions = const True
}
quickValidateArgs :: Args
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -52,7 +52,7 @@ packageArgs = do
[ builder Alex ? arg "--latin1"
, builder (Ghc CompileHs) ? mconcat
- [ debugAssertions ? notStage0 ? arg "-DDEBUG"
+ [ debugAssertions stage ? arg "-DDEBUG"
, inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto"
, input "**/Parser.hs" ?
@@ -83,7 +83,7 @@ packageArgs = do
, package ghc ? mconcat
[ builder Ghc ? mconcat
[ arg ("-I" ++ compilerPath)
- , debugAssertions ? notStage0 ? arg "-DDEBUG" ]
+ , debugAssertions stage ? arg "-DDEBUG" ]
, builder (Cabal Flags) ? mconcat
[ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
=====================================
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/ab2ecfa2f4707dbc8d8def19940884dde94cd4d4...4307eb2f67e08ed761469949ed8d8379d1decc0f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ab2ecfa2f4707dbc8d8def19940884dde94cd4d4...4307eb2f67e08ed761469949ed8d8379d1decc0f
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/3b3786e5/attachment-0001.html>
More information about the ghc-commits
mailing list