[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ErrUtils: Emit progress messages to eventlog
Marge Bot
gitlab at gitlab.haskell.org
Sun Apr 21 19:53:30 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cba7b62a by Ben Gamari at 2019-04-21T19:53:23Z
ErrUtils: Emit progress messages to eventlog
- - - - -
51103b30 by Ben Gamari at 2019-04-21T19:53:23Z
Emit GHC timing events to eventlog
- - - - -
c8203128 by Matthew Pickering at 2019-04-21T19:53:23Z
Correct off by one error in ghci +c
Fixes #16569
- - - - -
7ba837b4 by Alp Mestanogullari at 2019-04-21T19:53:24Z
Hadrian: use the testsuite driver's config.haddock arg more correctly
4 haddock tests assume that .haddock files have been produced, by using the
'req_haddock' modifier. The testsuite driver assumes that this condition is
satisfied if 'config.haddock' is non-empty, but before this patch Hadrian was
always passing the path to where the haddock executable should be, regardless
of whether it is actually there or not.
Instead, we now pass an empty config.haddock when we can't find all of
<build root>/docs/html/libraries/<pkg>/<pkg>.haddock>, where <pkg> ranges over
array, base, ghc-prim, process and template-haskell, and pass the path
to haddock when all those file exists. This has the (desired) effect of skipping
the 4 tests (marked as 'missing library') when the docs haven't been built,
and running the haddock tests when they have.
- - - - -
757b0f47 by Vladislav Zavialov at 2019-04-21T19:53:25Z
Stop misusing EWildPat in pattern match coverage checking
EWildPat is a constructor of HsExpr used in the parser to represent
wildcards in ambiguous positions:
* in expression context, EWildPat is turned into hsHoleExpr (see rnExpr)
* in pattern context, EWildPat is turned into WildPat (see checkPattern)
Since EWildPat exists solely for the needs of the parser, we could
remove it by improving the parser.
However, EWildPat has also been used for a different purpose since
8a50610: to represent patterns that the coverage checker cannot handle.
Not only this is a misuse of EWildPat, it also stymies the removal of
EWildPat.
- - - - -
11 changed files:
- .gitlab-ci.yml
- compiler/deSugar/Check.hs
- compiler/main/ErrUtils.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- hadrian/src/Settings/Builders/RunTest.hs
- + testsuite/tests/ghci/scripts/T16569.hs
- + testsuite/tests/ghci/scripts/T16569.script
- + testsuite/tests/ghci/scripts/T16569.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/should_run/T15369.stdout
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -144,6 +144,7 @@ lint-release-changelogs:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
+ - hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache:
key: hadrian
=====================================
compiler/deSugar/Check.hs
=====================================
@@ -157,7 +157,9 @@ data PmPat :: PatTy -> * where
PmNLit :: { pm_lit_id :: Id
, pm_lit_not :: [PmLit] } -> PmPat 'VA
PmGrd :: { pm_grd_pv :: PatVec
- , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ , pm_grd_expr :: PmExpr } -> PmPat 'PAT
+ -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.
+ PmFake :: PmPat 'PAT
instance Outputable (PmPat a) where
ppr = pprPmPatDebug
@@ -928,24 +930,11 @@ truePattern :: Pattern
truePattern = nullaryConPattern (RealDataCon trueDataCon)
{-# INLINE truePattern #-}
--- | A fake guard pattern (True <- _) used to represent cases we cannot handle
-fake_pat :: Pattern
-fake_pat = PmGrd { pm_grd_pv = [truePattern]
- , pm_grd_expr = PmExprOther (EWildPat noExt) }
-{-# INLINE fake_pat #-}
-
--- | Check whether a guard pattern is generated by the checker (unhandled)
-isFakeGuard :: [Pattern] -> PmExpr -> Bool
-isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
- | c == trueDataCon = True
- | otherwise = False
-isFakeGuard _pats _e = False
-
-- | Generate a `canFail` pattern vector of a specific type
mkCanFailPmPat :: Type -> DsM PatVec
mkCanFailPmPat ty = do
var <- mkPmVar ty
- return [var, fake_pat]
+ return [var, PmFake]
vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
-- ADT constructor pattern => no existentials, no local constraints
@@ -1295,7 +1284,7 @@ translateGuards fam_insts guards = do
then pure all_guards
else do
kept <- filterM shouldKeep all_guards
- pure (fake_pat : kept)
+ pure (PmFake : kept)
-- | Check whether a pattern can fail to match
cantFailPattern :: Pattern -> DsM Bool
@@ -1377,7 +1366,7 @@ cases:
expressivity in our warnings.
Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
- @fake_pat@: @True <- _ at . That is, we record that there is a possibility
+ @PmFake@: @True <- _ at . That is, we record that there is a possibility
of failure but we minimize it to a True/False. This generates a single
warning and much smaller uncovered sets.
@@ -1421,7 +1410,7 @@ in the pattern bind case). Hence, we safely drop them.
Additionally, top-level guard translation (performed by @translateGuards@)
replaces guards that cannot be reasoned about (like the ones we described in
-1-4) with a single @fake_pat@ to record the possibility of failure to match.
+1-4) with a single @PmFake@ to record the possibility of failure to match.
Note [Translate CoPats]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -1457,6 +1446,7 @@ pmPatType (PmNLit { pm_lit_id = x }) = idType x
pmPatType (PmGrd { pm_grd_pv = pv })
= ASSERT(patVecArity pv == 1) (pmPatType p)
where Just p = find ((==1) . patternArity) pv
+pmPatType PmFake = pmPatType truePattern
-- | Information about a conlike that is relevant to coverage checking.
-- It is called an \"inhabitation candidate\" since it is a value which may
@@ -1679,7 +1669,7 @@ mkGuard pv e = do
let expr = hsExprToPmExpr e
tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])
if | res -> pure (PmGrd pv expr)
- | PmExprOther {} <- expr -> pure fake_pat
+ | PmExprOther {} <- expr -> pure PmFake
| otherwise -> pure (PmGrd pv expr)
-- | Create a term equality of the form: `(False ~ (x ~ lit))`
@@ -1753,6 +1743,7 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
, pm_con_tvs = tvs, pm_con_dicts = dicts
, pm_con_args = coercePatVec args }]
coercePmPat (PmGrd {}) = [] -- drop the guards
+coercePmPat PmFake = [] -- drop the guards
-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether
-- it is the only possible match in the given context. See also
@@ -1765,7 +1756,7 @@ singleMatchConstructor cl tys =
Note [Single match constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When translating pattern guards for consumption by the checker, we desugar
-every pattern guard that might fail ('cantFailPattern') to 'fake_pat'
+every pattern guard that might fail ('cantFailPattern') to 'PmFake'
(True <- _). Which patterns can't fail? Exactly those that only match on
'singleMatchConstructor's.
@@ -2023,13 +2014,15 @@ pmcheck [] guards vva@(ValVec [] _)
| otherwise = pmcheckGuardsI guards vva
-- Guard
-pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
- -- short-circuit if the guard pattern is useless.
- -- we just have two possible outcomes: fail here or match and recurse
- -- none of the two contains any useful information about the failure
- -- though. So just have these two cases but do not do all the boilerplate
- | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
- | otherwise = do
+pmcheck (PmFake : ps) guards vva =
+ -- short-circuit if the guard pattern is useless.
+ -- we just have two possible outcomes: fail here or match and recurse
+ -- none of the two contains any useful information about the failure
+ -- though. So just have these two cases but do not do all the boilerplate
+ forces . mkCons vva <$> pmcheckI ps guards vva
+pmcheck (p : ps) guards (ValVec vas delta)
+ | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p
+ = do
y <- liftD $ mkPmId (pmPatType p)
let tm_state = extendSubst y e (delta_tm_cs delta)
delta' = delta { delta_tm_cs = tm_state }
@@ -2182,6 +2175,7 @@ pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
= pmcheckHdI p ps guards (PmVar x) vva
-- Impossible: handled by pmcheck
+pmcheckHd PmFake _ _ _ _ = panic "pmcheckHd: Fake"
pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
{-
@@ -2742,6 +2736,7 @@ pprPmPatDebug (PmLit li) = text "PmLit" <+> ppr li
pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
<+> ppr ge
+pprPmPatDebug PmFake = text "PmFake"
pprPatVec :: PatVec -> SDoc
pprPatVec ps = hang (text "Pattern:") 2
=====================================
compiler/main/ErrUtils.hs
=====================================
@@ -81,6 +81,7 @@ import Data.IORef
import Data.Maybe ( fromMaybe )
import Data.Ord
import Data.Time
+import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import System.IO
@@ -608,9 +609,10 @@ fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
-compilationProgressMsg dflags msg
- = ifVerbose dflags 1 $
- logOutput dflags (defaultUserStyle dflags) (text msg)
+compilationProgressMsg dflags msg = do
+ traceEventIO $ "GHC progress: " ++ msg
+ ifVerbose dflags 1 $
+ logOutput dflags (defaultUserStyle dflags) (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
@@ -651,10 +653,12 @@ withTiming getDFlags what force_result action
if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do liftIO $ logInfo dflags (defaultUserStyle dflags)
$ text "***" <+> what <> colon
+ liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
+ liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2146,7 +2146,9 @@ parseSpanArg s = do
let fs = mkFastString fp
span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
- (mkRealSrcLoc fs el ec)
+ -- End column of RealSrcSpan is the column
+ -- after the end of the span.
+ (mkRealSrcLoc fs el (ec + 1))
return (span',trailer)
where
@@ -2192,7 +2194,9 @@ showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
sl = srcSpanStartLine spn
sc = srcSpanStartCol spn
el = srcSpanEndLine spn
- ec = srcSpanEndCol spn
+ -- The end column is the column after the end of the span see the
+ -- RealSrcSpan module
+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1
-----------------------------------------------------------------------------
-- | @:kind@ command
=====================================
ghc/GHCi/UI/Info.hs
=====================================
@@ -75,6 +75,9 @@ data SpanInfo = SpanInfo
-- locality, definition location, etc.
}
+instance Outputable SpanInfo where
+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i
+
-- | Test whether second span is contained in (or equal to) first span.
-- This is basically 'containsSpan' for 'SpanInfo'
containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -147,6 +147,7 @@ getTestArgs = do
bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
+ haveDocs <- areDocsPresent
let configFileArg= ["--config-file=" ++ (testConfigFile args)]
testOnlyArg = map ("--only=" ++) (testOnly args ++ testEnvTargets)
onlyPerfArg = if testOnlyPerf args
@@ -169,7 +170,9 @@ getTestArgs = do
wayArgs = map ("--way=" ++) (testWays args)
compilerArg = ["--config", "compiler=" ++ show (compiler)]
ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
- haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
+ haddockArg = if haveDocs
+ then [ "--config", "haddock=" ++ show (bindir -/- "haddock") ]
+ else [ "--config", "haddock=" ]
hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
@@ -181,6 +184,17 @@ getTestArgs = do
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
+ where areDocsPresent = expr $ do
+ root <- buildRoot
+ and <$> traverse doesFileExist (docFiles root)
+
+ docFiles root =
+ [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
+ -- list of packages from
+ -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
+ | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
+ ]
+
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed TestSlow = "0"
=====================================
testsuite/tests/ghci/scripts/T16569.hs
=====================================
@@ -0,0 +1,4 @@
+module T16569 where
+
+main :: IO ()
+main = putStrLn (case (undefined :: Int) of _ -> undefined)
=====================================
testsuite/tests/ghci/scripts/T16569.script
=====================================
@@ -0,0 +1,3 @@
+:set +c
+:l T16569.hs
+::type-at T16569.hs 4 8 4 59
=====================================
testsuite/tests/ghci/scripts/T16569.stdout
=====================================
@@ -0,0 +1,2 @@
+Collecting type info for 1 module(s) ...
+ :: IO ()
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -295,3 +295,4 @@ test('T16089', normal, ghci_script, ['T16089.script'])
test('T14828', normal, ghci_script, ['T14828.script'])
test('T16376', normal, ghci_script, ['T16376.script'])
test('T16527', normal, ghci_script, ['T16527.script'])
+test('T16569', normal, ghci_script, ['T16569.script'])
=====================================
testsuite/tests/ghci/should_run/T15369.stdout
=====================================
@@ -1,8 +1,8 @@
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
-T15369.hs:(3,1)-(3,2): GHC.Types.Int
-T15369.hs:(3,5)-(3,6): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
+T15369.hs:(3,1)-(3,1): GHC.Types.Int
+T15369.hs:(3,5)-(3,5): GHC.Types.Int
Collecting type info for 1 module(s) ...
-T15369.hs:(3,1)-(3,2): GHC.Types.Double
-T15369.hs:(3,5)-(3,6): GHC.Types.Double
+T15369.hs:(3,1)-(3,1): GHC.Types.Double
+T15369.hs:(3,5)-(3,5): GHC.Types.Double
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/03adc3929b7949fc38f454b0e22c283034f6e276...757b0f4749a9e72033cb3b78cb07e0056be5b3c5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/03adc3929b7949fc38f454b0e22c283034f6e276...757b0f4749a9e72033cb3b78cb07e0056be5b3c5
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/20190421/09c00081/attachment-0001.html>
More information about the ghc-commits
mailing list