[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: testsuite: Add --top flag to driver
Marge Bot
gitlab at gitlab.haskell.org
Mon Nov 2 14:14:42 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ee6e4f5f by GHC GitLab CI at 2020-11-02T09:14:33-05:00
testsuite: Add --top flag to driver
This allows us to make `config.top` a proper Path. Previously it was a
str, which caused the Ghostscript detection logic to break.
- - - - -
dce54ee9 by Ben Gamari at 2020-11-02T09:14:34-05:00
Document that ccall convention doesn't support varargs
We do not support foreign "C" imports of varargs functions. While this
works on amd64, in general the platform's calling convention may need
more type information that our Cmm representation can currently provide.
For instance, this is the case with Darwin's AArch64 calling convention.
Document this fact in the users guide and fix T5423 which makes use of a
disallowed foreign import.
Closes #18854.
- - - - -
541a7c3f by Ryan Scott at 2020-11-02T09:14:34-05:00
Display results of GHC.Core.Lint.lint* functions consistently
Previously, the functions in `GHC.Core.Lint` used a patchwork of
different ways to display Core Lint errors:
* `lintPassResult` (which is the source of most Core Lint errors) renders
Core Lint errors with a distinctive banner (e.g.,
`*** Core Lint errors : in result of ... ***`) that sets them apart
from ordinary GHC error messages.
* `lintAxioms`, in contrast, uses a completely different code path that
displays Core Lint errors in a rather confusing manner. For example,
the program in #18770 would give these results:
```
Bug.hs:1:1: error:
Bug.hs:12:1: warning:
Non-*-like kind when *-like expected: RuntimeRep
when checking the body of forall: 'TupleRep '[r]
In the coercion axiom Bug.N:T :: []. Bug.T ~_R Any
Substitution: [TCvSubst
In scope: InScope {r}
Type env: [axl :-> r]
Co env: []]
|
1 | {-# LANGUAGE DataKinds #-}
| ^
```
* Further digging reveals that `GHC.IfaceToCore` displays Core Lint
errors for iface unfoldings as though they were a GHC panic. See, for
example, this excerpt from #17723:
```
ghc: panic! (the 'impossible' happened)
(GHC version 8.8.2 for x86_64-unknown-linux):
Iface Lint failure
In interface for Lib
...
```
This patch makes all of these code paths display Core Lint errors and
warnings consistently. I decided to adopt the conventions that
`lintPassResult` currently uses, as they appear to have been around the
longest (and look the best, in my subjective opinion). We now use the
`displayLintResult` function for all three scenarios mentioned above.
For example, here is what the Core Lint error for the program in #18770 looks
like after this patch:
```
[1 of 1] Compiling Bug ( Bug.hs, Bug.o )
*** Core Lint errors : in result of TcGblEnv axioms ***
Bug.hs:12:1: warning:
Non-*-like kind when *-like expected: RuntimeRep
when checking the body of forall: 'TupleRep '[r_axn]
In the coercion axiom N:T :: []. T ~_R Any
Substitution: [TCvSubst
In scope: InScope {r_axn}
Type env: [axn :-> r_axn]
Co env: []]
*** Offending Program ***
axiom N:T :: T = Any -- Defined at Bug.hs:12:1
*** End of Offense ***
<no location info>: error:
Compilation had errors
```
Fixes #18770.
- - - - -
7b45b66c by Simon Peyton Jones at 2020-11-02T09:14:34-05:00
Expand type synonyms with :kind!
The User's Guide claims that `:kind!` should expand type synonyms,
but GHCi wasn't doing this in practice. Let's just update the implementation
to match the specification in the User's Guide.
Fixes #13795. Fixes #18828.
Co-authored-by: Ryan Scott <ryan.gl.scott at gmail.com>
- - - - -
737d467f by Ben Gamari at 2020-11-02T09:14:35-05:00
hadrian: Don't capture RunTest output
There are a few reasons why capturing the output of the RunTest builder
is undesirable:
* there is a large amount of output which then gets unnecessarily
duplicated by Hadrian if the builder fails
* the output may contain codepoints which are unrepresentable in the
current codepage on Windows, causing Hadrian to crash
* capturing the output causes the testsuite driver to disable
its colorisation logic, making the output less legible.
- - - - -
24 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- docs/users_guide/9.2.1-notes.rst
- docs/users_guide/exts/ffi.rst
- hadrian/src/Builder.hs
- hadrian/src/Settings/Builders/RunTest.hs
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/mk/test.mk
- testsuite/tests/callarity/unittest/CallArity1.hs
- + testsuite/tests/ghci/scripts/T13795.script
- + testsuite/tests/ghci/scripts/T13795.stdout
- + testsuite/tests/ghci/scripts/T18828.hs
- + testsuite/tests/ghci/scripts/T18828.script
- + testsuite/tests/ghci/scripts/T18828.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/rts/T5423.hs
- testsuite/tests/rts/T5423.stdout
- testsuite/tests/rts/T5423_c.c
- testsuite/tests/rts/T5423_cmm.cmm
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -19,8 +19,8 @@ module GHC.Core.Lint (
-- ** Debug output
endPass, endPassIO,
- dumpPassResult,
- GHC.Core.Lint.dumpIfSet,
+ displayLintResults, dumpPassResult,
+ dumpIfSet,
) where
#include "HsVersions.h"
@@ -65,7 +65,8 @@ import GHC.Core.TyCon as TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.Unify
import GHC.Types.Basic
-import GHC.Utils.Error as Err
+import GHC.Utils.Error hiding ( dumpIfSet )
+import qualified GHC.Utils.Error as Err
import GHC.Data.List.SetOps
import GHC.Builtin.Names
import GHC.Utils.Outputable as Outputable
@@ -372,33 +373,38 @@ lintPassResult hsc_env pass binds
| not (gopt Opt_DoCoreLinting dflags)
= return ()
| otherwise
- = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+ = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
- ; displayLintResults dflags pass warns errs binds }
+ ; displayLintResults dflags (showLintWarnings pass) (ppr pass)
+ (pprCoreBindings binds) warns_and_errs }
where
dflags = hsc_dflags hsc_env
-displayLintResults :: DynFlags -> CoreToDo
- -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+displayLintResults :: DynFlags
+ -> Bool -- ^ If 'True', display linter warnings.
+ -- If 'False', ignore linter warnings.
+ -> SDoc -- ^ The source of the linted program
+ -> SDoc -- ^ The linted program, pretty-printed
+ -> WarnsAndErrs
-> IO ()
-displayLintResults dflags pass warns errs binds
+displayLintResults dflags display_warnings pp_what pp_pgm (warns, errs)
| not (isEmptyBag errs)
= do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
$ withPprStyle defaultDumpStyle
- (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+ (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs
, text "*** Offending Program ***"
- , pprCoreBindings binds
+ , pp_pgm
, text "*** End of Offense ***" ])
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
, not (hasNoDebugOutput dflags)
- , showLintWarnings pass
+ , display_warnings
-- If the Core linter encounters an error, output to stderr instead of
-- stdout (#13342)
= putLogMsg dflags NoReason Err.SevInfo noSrcSpan
$ withPprStyle defaultDumpStyle
- (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
+ (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
| otherwise = return ()
@@ -413,29 +419,18 @@ showLintWarnings :: CoreToDo -> Bool
showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True
-lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
+ -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr what hsc_env expr
| not (gopt Opt_DoCoreLinting dflags)
= return ()
| Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
- = do { display_lint_err err
- ; Err.ghcExit dflags 1 }
+ = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err)
| otherwise
= return ()
where
dflags = hsc_dflags hsc_env
- display_lint_err err
- = do { putLogMsg dflags NoReason Err.SevDump
- noSrcSpan
- $ withPprStyle defaultDumpStyle
- (vcat [ lint_banner "errors" (text what)
- , err
- , text "*** Offending Program ***"
- , pprCoreExpr expr
- , text "*** End of Offense ***" ])
- ; Err.ghcExit dflags 1 }
-
interactiveInScope :: HscEnv -> [Var]
-- In GHCi we may lint expressions, or bindings arising from 'deriving'
-- clauses, that mention variables bound in the interactive context.
@@ -464,7 +459,7 @@ interactiveInScope hsc_env
-- where t is a RuntimeUnk (see TcType)
-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
-- Returns (warnings, errors)
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
@@ -540,16 +535,16 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
-}
-lintUnfolding :: Bool -- True <=> is a compulsory unfolding
+lintUnfolding :: Bool -- True <=> is a compulsory unfolding
-> DynFlags
-> SrcLoc
- -> VarSet -- Treat these as in scope
+ -> VarSet -- Treat these as in scope
-> CoreExpr
- -> Maybe MsgDoc -- Nothing => OK
+ -> Maybe (Bag MsgDoc) -- Nothing => OK
lintUnfolding is_compulsory dflags locn var_set expr
| isEmptyBag errs = Nothing
- | otherwise = Just (pprMessageBag errs)
+ | otherwise = Just errs
where
vars = nonDetEltsUniqSet var_set
(_warns, errs) = initL dflags (defaultLintFlags dflags) vars $
@@ -563,11 +558,11 @@ lintUnfolding is_compulsory dflags locn var_set expr
lintExpr :: DynFlags
-> [Var] -- Treat these as in scope
-> CoreExpr
- -> Maybe MsgDoc -- Nothing => OK
+ -> Maybe (Bag MsgDoc) -- Nothing => OK
lintExpr dflags vars expr
| isEmptyBag errs = Nothing
- | otherwise = Just (pprMessageBag errs)
+ | otherwise = Just errs
where
(_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter
linter = addLoc TopLevelBindings $
@@ -2326,13 +2321,15 @@ lintCoercion (HoleCo h)
-}
lintAxioms :: DynFlags
+ -> SDoc -- ^ The source of the linted axioms
-> [CoAxiom Branched]
- -> WarnsAndErrs
-lintAxioms dflags axioms
- = initL dflags (defaultLintFlags dflags) [] $
- do { mapM_ lint_axiom axioms
- ; let axiom_groups = groupWith coAxiomTyCon axioms
- ; mapM_ lint_axiom_group axiom_groups }
+ -> IO ()
+lintAxioms dflags what axioms =
+ displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $
+ initL dflags (defaultLintFlags dflags) [] $
+ do { mapM_ lint_axiom axioms
+ ; let axiom_groups = groupWith coAxiomTyCon axioms
+ ; mapM_ lint_axiom_group axiom_groups }
lint_axiom :: CoAxiom Branched -> LintM ()
lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1713,7 +1713,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
-- Desugar it
ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
- liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
+ liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
handleWarnings
-- Then code-gen, and link it
@@ -1955,7 +1955,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
; prepd_expr <- corePrepExpr hsc_env tidy_expr
{- Lint if necessary -}
- ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
+ ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
{- Convert to BCOs -}
; bcos <- coreExprToBCOs hsc_env
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -62,6 +62,7 @@ import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
+import GHC.Core.Ppr
import GHC.Unit.External
import GHC.Unit.Module
@@ -73,6 +74,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import GHC.Data.Bag
import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Data.List.SetOps
@@ -1199,13 +1201,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
bndrs' ++
exprsFreeIdsList args')
; case lintExpr dflags in_scope rhs' of
- Nothing -> return ()
- Just fail_msg -> do { mod <- getIfModule
- ; pprPanic "Iface Lint failure"
- (vcat [ text "In interface for" <+> ppr mod
- , hang doc 2 fail_msg
- , ppr name <+> equals <+> ppr rhs'
- , text "Iface expr =" <+> ppr rhs ]) } }
+ Nothing -> return ()
+ Just errs -> liftIO $
+ displayLintResults dflags False doc
+ (pprCoreExpr rhs')
+ (emptyBag, errs) }
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
; this_mod <- getIfModule
@@ -1724,13 +1724,10 @@ tcPragExpr is_compulsory toplvl name expr
in_scope <- get_in_scope
dflags <- getDynFlags
case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
- Nothing -> return ()
- Just fail_msg -> do { mod <- getIfModule
- ; pprPanic "Iface Lint failure"
- (vcat [ text "In interface for" <+> ppr mod
- , hang doc 2 fail_msg
- , ppr name <+> equals <+> ppr core_expr'
- , text "Iface expr =" <+> ppr expr ]) }
+ Nothing -> return ()
+ Just errs -> liftIO $
+ displayLintResults dflags False doc
+ (pprCoreExpr core_expr') (emptyBag, errs)
return core_expr'
where
doc = ppWhen is_compulsory (text "Compulsory") <+>
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -296,11 +296,7 @@ tcRnModuleTcRnM hsc_env mod_sum
tcRnSrcDecls explicit_mod_hdr local_decls export_ies
; whenM (goptM Opt_DoCoreLinting) $
- do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env
- ; mapBagM_ (addWarn NoReason) warns
- ; mapBagM_ addErr errs
- ; failIfErrsM } -- if we have a lint error, we're only
- -- going to get in deeper trouble by proceeding
+ lintGblEnv (hsc_dflags hsc_env) tcg_env
; setGblEnv tcg_env
$ do { -- Process the export list
@@ -2629,12 +2625,13 @@ tcRnType hsc_env flexi normalise rdr_type
-- Do validity checking on type
; checkValidType (GhciCtxt True) ty
- ; ty' <- if normalise
- then do { fam_envs <- tcGetFamInstEnvs
- ; let (_, ty')
- = normaliseType fam_envs Nominal ty
- ; return ty' }
- else return ty ;
+ -- Optionally (:k vs :k!) normalise the type. Does two things:
+ -- normaliseType: expand type-family applications
+ -- expandTypeSynonyms: expand type synonyms (#18828)
+ ; fam_envs <- tcGetFamInstEnvs
+ ; let ty' | normalise = expandTypeSynonyms $ snd $
+ normaliseType fam_envs Nominal ty
+ | otherwise = ty
; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) }
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1712,7 +1712,8 @@ getRoleAnnots bndrs role_env
-- | Check the 'TcGblEnv' for consistency. Currently, only checks
-- axioms, but should check other aspects, too.
-lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc)
-lintGblEnv dflags tcg_env = lintAxioms dflags axioms
+lintGblEnv :: DynFlags -> TcGblEnv -> TcM ()
+lintGblEnv dflags tcg_env =
+ liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms
where
axioms = typeEnvCoAxioms (tcg_type_env tcg_env)
=====================================
docs/users_guide/9.2.1-notes.rst
=====================================
@@ -37,6 +37,9 @@ Compiler
- Type checker plugins which work with the natural numbers now
should use ``naturalTy`` kind instead of ``typeNatKind``, which has been removed.
+- GHCi's ``:kind!`` command now expands through type synonyms in addition to type
+ families. See :ghci-cmd:`:kind`.
+
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
docs/users_guide/exts/ffi.rst
=====================================
@@ -83,6 +83,21 @@ For more details on the implementation see the Paper:
Last known to be accessible `here
<https://www.microsoft.com/en-us/research/wp-content/uploads/2004/09/conc-ffi.pdf>`_.
+Varargs not supported by ``ccall`` calling convention
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Note that functions requiring varargs arguments are unsupported by the ``ccall``
+calling convention. Foreign imports needing to call such functions should rather
+use the ``capi`` convention, giving an explicit signature for the needed
+call-pattern. For instance, one could write: ::
+
+ foreign import "capi" "printf"
+ my_printf :: Ptr CChar -> CInt -> IO ()
+
+ printInt :: CInt -> IO ()
+ printInt n = my_printf "printed number %d" n
+
+
.. _ffi-ghcexts:
GHC extensions to the FFI Chapter
=====================================
hadrian/src/Builder.hs
=====================================
@@ -304,6 +304,11 @@ instance H.Builder Builder where
Makeindex -> unit $ cmd' [Cwd output] [path] (buildArgs ++ [input])
Tar _ -> cmd' buildOptions echo [path] buildArgs
+
+ -- RunTest produces a very large amount of (colorised) output;
+ -- Don't attempt to capture it.
+ RunTest -> cmd echo [path] buildArgs
+
_ -> cmd' echo [path] buildArgs
-- TODO: Some builders are required only on certain platforms. For example,
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -102,6 +102,7 @@ runTestBuilderArgs = builder RunTest ? do
-- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
mconcat [ arg $ "testsuite/driver/runtests.py"
, pure [ "--rootdir=" ++ testdir | testdir <- rootdirs ]
+ , arg "--top", arg (top -/- "testsuite")
, arg "-e", arg $ "windows=" ++ show windowsHost
, arg "-e", arg $ "darwin=" ++ show osxHost
, arg "-e", arg $ "config.local=False"
@@ -129,7 +130,6 @@ runTestBuilderArgs = builder RunTest ? do
, arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
- , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
, arg "-e", arg $ "config.wordsize=" ++ show wordsize
, arg "-e", arg $ "config.os=" ++ show os
, arg "-e", arg $ "config.arch=" ++ show arch
=====================================
testsuite/driver/runtests.py
=====================================
@@ -14,6 +14,7 @@ import tempfile
import time
import re
import traceback
+from pathlib import Path
# We don't actually need subprocess in runtests.py, but:
# * We do need it in testlibs.py
@@ -56,6 +57,7 @@ parser = argparse.ArgumentParser(description="GHC's testsuite driver")
perf_group = parser.add_mutually_exclusive_group()
parser.add_argument("-e", action='append', help="A string to execute from the command line.")
+parser.add_argument("--top", type=Path, help="path to top of testsuite/ tree")
parser.add_argument("--config-file", action="append", help="config file")
parser.add_argument("--config", action='append', help="config field")
parser.add_argument("--rootdir", action='append', help="root of tree containing tests (default: .)")
@@ -104,6 +106,9 @@ config.summary_file = args.summary_file
config.no_print_summary = args.no_print_summary
config.baseline_commit = args.perf_baseline
+if args.top:
+ config.top = args.top
+
if args.only:
config.only = args.only
config.run_only_some_tests = True
@@ -277,7 +282,7 @@ testopts_local.x = TestOptions()
# if timeout == -1 then we try to calculate a sensible value
if config.timeout == -1:
- config.timeout = int(read_no_crs(config.top + '/timeout/calibrate.out'))
+ config.timeout = int(read_no_crs(config.top / 'timeout' / 'calibrate.out'))
print('Timeout is ' + str(config.timeout))
print('Known ways: ' + ', '.join(config.other_ways))
=====================================
testsuite/driver/testglobals.py
=====================================
@@ -22,7 +22,7 @@ class TestConfig:
def __init__(self):
# Where the testsuite root is
- self.top = ''
+ self.top = Path('.')
# Directories below which to look for test description files (foo.T)
self.rootdirs = []
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1110,7 +1110,7 @@ def do_test(name: TestName,
dst_makefile = in_testdir('Makefile')
if src_makefile.exists():
makefile = src_makefile.read_text(encoding='UTF-8')
- makefile = re.sub('TOP=.*', 'TOP=' + config.top, makefile, 1)
+ makefile = re.sub('TOP=.*', 'TOP=%s' % config.top, makefile, 1)
dst_makefile.write_text(makefile, encoding='UTF-8')
if opts.pre_cmd:
=====================================
testsuite/mk/test.mk
=====================================
@@ -256,13 +256,13 @@ endif
RUNTEST_OPTS += \
--rootdir=. \
--config-file=$(CONFIG) \
+ --top="$(TOP_ABS)" \
-e 'config.platform="$(TARGETPLATFORM)"' \
-e 'config.os="$(TargetOS_CPP)"' \
-e 'config.arch="$(TargetARCH_CPP)"' \
-e 'config.wordsize="$(WORDSIZE)"' \
-e 'config.timeout=int($(TIMEOUT)) or config.timeout' \
- -e 'config.exeext="$(exeext)"' \
- -e 'config.top="$(TOP_ABS)"'
+ -e 'config.exeext="$(exeext)"'
# Wrap non-empty program paths in quotes, because they may contain spaces. Do
# it here, so we don't have to (and don't forget to do it) in the .T test
=====================================
testsuite/tests/callarity/unittest/CallArity1.hs
=====================================
@@ -172,7 +172,7 @@ main = do
dflags <- getSessionDynFlags
liftIO $ forM_ exprs $ \(n,e) -> do
case lintExpr dflags [f,scrutf,scruta] e of
- Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
+ Just errs -> putMsg dflags (pprMessageBag errs $$ text "in" <+> text n)
Nothing -> return ()
putMsg dflags (text n Outputable.<> char ':')
-- liftIO $ putMsg dflags (ppr e)
=====================================
testsuite/tests/ghci/scripts/T13795.script
=====================================
@@ -0,0 +1,2 @@
+type A = ()
+:kind! A
=====================================
testsuite/tests/ghci/scripts/T13795.stdout
=====================================
@@ -0,0 +1,2 @@
+A :: *
+= ()
=====================================
testsuite/tests/ghci/scripts/T18828.hs
=====================================
@@ -0,0 +1,31 @@
+{-# Language ConstraintKinds #-}
+{-# Language DataKinds #-}
+{-# Language GADTs #-}
+{-# Language PolyKinds #-}
+{-# Language RankNTypes #-}
+{-# Language StandaloneKindSignatures #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+module T18828 where
+
+import Data.Kind
+
+type Cat :: Type -> Type
+type Cat ob = ob -> ob -> Type
+
+type Dict :: Constraint -> Type
+data Dict cls where
+ Dict :: cls => Dict cls
+
+type (:-) :: Cat Constraint
+newtype cls1 :- cls2 where
+ Sub :: (cls1 => Dict cls2) -> (cls1 :- cls2)
+
+type ObjectSyn :: Cat ob -> Type
+type ObjectSyn (cat :: ob -> ob -> Type) = ob
+
+type
+ ObjectFam :: Cat ob -> Type
+type family
+ ObjectFam cat where
+ ObjectFam @ob cat = ob
=====================================
testsuite/tests/ghci/scripts/T18828.script
=====================================
@@ -0,0 +1,9 @@
+:load T18828
+:set -XDataKinds -XKindSignatures -XRankNTypes
+import Data.Type.Equality
+:k! ObjectSyn (->)
+:k! forall ob. ObjectSyn ((:~:) :: Cat ob)
+:k! ObjectSyn (:-)
+:k! ObjectFam (->)
+:k! forall ob. ObjectFam ((:~:) :: Cat ob)
+:k! ObjectFam (:-)
=====================================
testsuite/tests/ghci/scripts/T18828.stdout
=====================================
@@ -0,0 +1,12 @@
+ObjectSyn (->) :: *
+= *
+forall ob. ObjectSyn ((:~:) :: Cat ob) :: *
+= ob
+ObjectSyn (:-) :: *
+= Constraint
+ObjectFam (->) :: *
+= *
+forall ob. ObjectFam ((:~:) :: Cat ob) :: *
+= ob
+ObjectFam (:-) :: *
+= Constraint
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -279,6 +279,7 @@ test('T13591', expect_broken(13591), ghci_script, ['T13591.script'])
test('T13699', normal, ghci_script, ['T13699.script'])
test('T13988', normal, ghci_script, ['T13988.script'])
test('T13407', normal, ghci_script, ['T13407.script'])
+test('T13795', normal, ghci_script, ['T13795.script'])
test('T13963', normal, ghci_script, ['T13963.script'])
test('T14342', [extra_hc_opts("-XOverloadedStrings -XRebindableSyntax")],
ghci_script, ['T14342.script'])
@@ -322,3 +323,4 @@ test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_b
test('T18501', normal, ghci_script, ['T18501.script'])
test('T18644', normal, ghci_script, ['T18644.script'])
test('T18755', normal, ghci_script, ['T18755.script'])
+test('T18828', normal, ghci_script, ['T18828.script'])
=====================================
testsuite/tests/rts/T5423.hs
=====================================
@@ -1,3 +1,5 @@
+-- | Verify that @foreign import prim@ calls with more than 10 arguments
+-- are lowered correctly.
{-# LANGUAGE MagicHash, GHCForeignImportPrim, UnliftedFFITypes #-}
=====================================
testsuite/tests/rts/T5423.stdout
=====================================
@@ -1,2 +1,2 @@
-111 112 113 114 115 116 117 118 119 120
+111 112 113 114 115 116 117 118 119 120
120
=====================================
testsuite/tests/rts/T5423_c.c
=====================================
@@ -1,6 +1,34 @@
+#include <Rts.h>
#include <stdio.h>
void flush_stdout(void)
{
fflush(stdout);
}
+
+void print_it(
+ StgWord r1,
+ StgWord r2,
+ StgWord r3,
+ StgWord r4,
+ StgWord r5,
+ StgWord r6,
+ StgWord r7,
+ StgWord r8,
+ StgWord r9,
+ StgWord r10
+ )
+{
+ printf("%" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word
+ " %" FMT_Word "\n",
+ r1, r2, r3, r4, r5,
+ r6, r7, r8, r9, r10);
+}
=====================================
testsuite/tests/rts/T5423_cmm.cmm
=====================================
@@ -10,7 +10,6 @@ test (W_ r1,
W_ r9,
W_ r10)
{
- foreign "C" printf("%d %d %d %d %d %d %d %d %d %d\n",
- r1, r2, r3, r4, r5, r6, r7, r8, r9, r10);
+ foreign "C" print_it(r1, r2, r3, r4, r5, r6, r7, r8, r9, r10);
return (r10);
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e015d2824c5c17dd3be9fbb7f1467c800b219a75...737d467ffc0200dbe173ccd345a16fc3d8e1bac3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e015d2824c5c17dd3be9fbb7f1467c800b219a75...737d467ffc0200dbe173ccd345a16fc3d8e1bac3
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/20201102/a38d8e32/attachment-0001.html>
More information about the ghc-commits
mailing list