[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 13 commits: Add -ddump-stg-final to dump stg as it is used for codegen.
Marge Bot
gitlab at gitlab.haskell.org
Sat Apr 13 14:27:59 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
885d2e04 by klebinger.andreas at gmx.at at 2019-04-12T18:40:04Z
Add -ddump-stg-final to dump stg as it is used for codegen.
Intermediate STG does not contain free variables which can be useful
sometimes. So adding a flag to dump that info.
- - - - -
3c759ced by Alp Mestanogullari at 2019-04-12T18:46:54Z
Hadrian: add a --test-accept/-a flag, to mimic 'make accept'
When -a or --test-accept is passed, and if one runs the 'test' target, then
any test failing because of mismatching output and which is not expected to
fail will have its expected output adjusted by the test driver, effectively
considering the new output correct from now on.
When this flag is passed, hadrian's 'test' target becomes sensitive to the
PLATFORM and OS environment variable, just like the Make build system:
- when the PLATFORM env var is set to "YES", when accepting a result, accept it
for the current platform;
- when the OS env var is set to "YES", when accepting a result, accept it
for all wordsizes of the current operating system.
This can all be combined with `--only="..."` and `TEST="..." to only accept
the new output of a subset of tests.
- - - - -
f4b5a6c0 by Alp Mestanogullari at 2019-04-12T18:46:54Z
Hadrian: document -a/--test-accept
- - - - -
30a0988d by Ben Gamari at 2019-04-12T19:41:07Z
gitlab: Disable windows-hadrian job
Not only is it reliably failing due to #16574 but all of the quickly
failing builds also causes the Windows runners to run out of disk space.
- - - - -
8870a51b by Ben Gamari at 2019-04-12T19:41:07Z
gitlab: Don't run lint-submods job on Marge branches
This broke Marge by creating a second pipeline (consisting of only the
`lint-submods` job). Marge then looked at this pipeline and concluded
that CI for her merge branch passed. However, this is ignores the fact
that the majority of the CI jobs are triggered on `merge_request` and
are therefore in another pipeline.
- - - - -
7876d088 by Ben Gamari at 2019-04-13T13:51:59Z
linters: Fix check-version-number
This should have used `grep -E`, not `grep -e`
- - - - -
2e7b2e55 by Ara Adkins at 2019-04-13T14:00:02Z
[skip ci] Update CI badge in readme
This trivial MR updates the CI badge in the readme to point to the
new CI on gitlab, rather than the very out-of-date badge from
Travis.
- - - - -
40848a43 by Ben Gamari at 2019-04-13T14:02:36Z
base: Better document implementation implications of Data.Timeout
As noted in #16546 timeout uses asynchronous exceptions internally, an
implementation detail which can leak out in surprising ways. Note this
fact.
Also expose the `Timeout` tycon.
[skip ci]
- - - - -
c632bd9f by David Eichmann at 2019-04-13T14:27:44Z
Hadrian: add rts shared library symlinks for backwards compatability
Fixes test T3807 when building with Hadrian.
Trac #16370
- - - - -
0f477c92 by Sylvain Henry at 2019-04-13T14:27:47Z
Hadrian: add binary-dist-dir target
This patch adds an Hadrian target "binary-dist-dir". Compared to
"binary-dist", it only builds a binary distribution directory without
creating the Tar archive. It makes the use/test of the bindist
installation script easier.
- - - - -
88deb623 by Krzysztof Gogolewski at 2019-04-13T14:27:47Z
Fix assertion failures reported in #16533
- - - - -
b89f2687 by Artem Pyanykh at 2019-04-13T14:27:49Z
codegen: unroll memcpy calls for small bytearrays
- - - - -
851ee22f by Artem Pyanykh at 2019-04-13T14:27:49Z
docs: mention memcpy optimization for ByteArrays in 8.10.1-notes
- - - - -
29 changed files:
- .gitlab-ci.yml
- .gitlab/linters/check-version-number.sh
- README.md
- compiler/cmm/CmmExpr.hs
- compiler/codeGen/StgCmmPrim.hs
- compiler/main/DynFlags.hs
- compiler/main/HscMain.hs
- compiler/nativeGen/X86/CodeGen.hs
- compiler/typecheck/TcCanonical.hs
- compiler/typecheck/TcSigs.hs
- compiler/types/OptCoercion.hs
- compiler/types/Type.hs
- docs/users_guide/8.10.1-notes.rst
- docs/users_guide/debugging.rst
- hadrian/doc/make.md
- hadrian/doc/testsuite.md
- hadrian/hadrian.cabal
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Utilities.hs
- hadrian/src/Rules.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Register.hs
- + hadrian/src/Rules/Rts.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/System/Timeout.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/bytearray-memcpy-unroll.asm
- + testsuite/tests/codeGen/should_gen_asm/bytearray-memcpy-unroll.hs
- testsuite/tests/dynlibs/Makefile
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -85,7 +85,14 @@ lint-submods:
refs:
- master
- /ghc-[0-9]+\.[0-9]+/
- - wip/marge_bot_batch_merge_job
+
+lint-submods-marge:
+ extends: .lint-submods
+ only:
+ refs:
+ - merge_requests
+ variables:
+ - $CI_MERGE_REQUEST_LABELS =~ /.*wip/marge_bot_batch_merge_job.*/
lint-submods-mr:
extends: .lint-submods
@@ -525,7 +532,7 @@ validate-x86_64-linux-fedora27:
paths:
- ghc.tar.xz
-validate-x86_64-windows-hadrian:
+.validate-x86_64-windows-hadrian:
extends: .build-windows-hadrian
variables:
MSYSTEM: MINGW64
=====================================
.gitlab/linters/check-version-number.sh
=====================================
@@ -2,5 +2,5 @@
set -e
-grep -e -q '\[[0-9]+\.[0-9]+\.[0-9]+\]' configure.ac ||
+grep -E -q '\[[0-9]+\.[0-9]+\.[0-9]+\]' configure.ac ||
( echo "error: configure.ac: GHC version number must have three components."; exit 1 )
=====================================
README.md
=====================================
@@ -1,7 +1,7 @@
The Glasgow Haskell Compiler
============================
-[](http://travis-ci.org/ghc/ghc)
+[](https://gitlab.haskell.org/ghc/ghc/commits/master)
This is the source tree for [GHC][1], a compiler and interactive
environment for the Haskell functional programming language.
=====================================
compiler/cmm/CmmExpr.hs
=====================================
@@ -5,7 +5,7 @@
{-# LANGUAGE UndecidableInstances #-}
module CmmExpr
- ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+ ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
, CmmReg(..), cmmRegType, cmmRegWidth
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
@@ -43,6 +43,8 @@ import Unique
import Data.Set (Set)
import qualified Data.Set as Set
+import BasicTypes (Alignment, mkAlignment, alignmentOf)
+
-----------------------------------------------------------------------------
-- CmmExpr
-- An expression. Expressions have no side effects.
@@ -239,6 +241,13 @@ cmmLabelType dflags lbl
cmmExprWidth :: DynFlags -> CmmExpr -> Width
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
+-- | Returns an alignment in bytes of a CmmExpr when it's a statically
+-- known integer constant, otherwise returns an alignment of 1 byte.
+-- The caller is responsible for using with a sensible CmmExpr
+-- argument.
+cmmExprAlignment :: CmmExpr -> Alignment
+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)
+cmmExprAlignment _ = mkAlignment 1
--------
--- Negation for conditional branches
=====================================
compiler/codeGen/StgCmmPrim.hs
=====================================
@@ -2035,8 +2035,8 @@ doCopyByteArrayOp = emitCopyByteArray copy
where
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
- copy _src _dst dst_p src_p bytes =
- emitMemcpyCall dst_p src_p bytes 1
+ copy _src _dst dst_p src_p bytes align =
+ emitMemcpyCall dst_p src_p bytes align
-- | Takes a source 'MutableByteArray#', an offset in the source
-- array, a destination 'MutableByteArray#', an offset into the
@@ -2050,22 +2050,26 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- The only time the memory might overlap is when the two arrays
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
- copy src dst dst_p src_p bytes = do
+ copy src dst dst_p src_p bytes align = do
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
- (getCode $ emitMemmoveCall dst_p src_p bytes 1)
- (getCode $ emitMemcpyCall dst_p src_p bytes 1)
+ (getCode $ emitMemmoveCall dst_p src_p bytes align)
+ (getCode $ emitMemcpyCall dst_p src_p bytes align)
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
- -> FCode ())
+ -> Alignment -> FCode ())
-> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCopyByteArray copy src src_off dst dst_off n = do
dflags <- getDynFlags
+ let byteArrayAlignment = wordAlignment dflags
+ srcOffAlignment = cmmExprAlignment src_off
+ dstOffAlignment = cmmExprAlignment dst_off
+ align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]
dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
- copy src dst dst_p src_p n
+ copy src dst dst_p src_p n align
-- | Takes a source 'ByteArray#', an offset in the source array, a
-- destination 'Addr#', and the number of bytes to copy. Copies the given
@@ -2075,7 +2079,7 @@ doCopyByteArrayToAddrOp src src_off dst_p bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
- emitMemcpyCall dst_p src_p bytes 1
+ emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-- | Takes a source 'MutableByteArray#', an offset in the source array, a
-- destination 'Addr#', and the number of bytes to copy. Copies the given
@@ -2092,7 +2096,7 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
-- Use memcpy (we are allowed to assume the arrays aren't overlapping)
dflags <- getDynFlags
dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
- emitMemcpyCall dst_p src_p bytes 1
+ emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-- ----------------------------------------------------------------------------
@@ -2107,9 +2111,7 @@ doSetByteArrayOp ba off len c = do
dflags <- getDynFlags
let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap
- offsetAlignment = case off of
- CmmLit (CmmInt intOff _) -> alignmentOf (fromInteger intOff)
- _ -> mkAlignment 1
+ offsetAlignment = cmmExprAlignment off
align = min byteArrayAlignment offsetAlignment
p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
@@ -2180,7 +2182,7 @@ doCopyArrayOp = emitCopyArray copy
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags)
+ (wordAlignment dflags)
-- | Takes a source 'MutableArray#', an offset in the source array, a
@@ -2198,9 +2200,9 @@ doCopyMutableArrayOp = emitCopyArray copy
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags))
+ (wordAlignment dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags))
+ (wordAlignment dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
@@ -2247,7 +2249,7 @@ doCopySmallArrayOp = emitCopySmallArray copy
copy _src _dst dst_p src_p bytes =
do dflags <- getDynFlags
emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags)
+ (wordAlignment dflags)
doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
@@ -2261,9 +2263,9 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
dflags <- getDynFlags
(moveCall, cpyCall) <- forkAltPair
(getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags))
+ (wordAlignment dflags))
(getCode $ emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
- (wORD_SIZE dflags))
+ (wordAlignment dflags))
emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
@@ -2328,7 +2330,7 @@ emitCloneArray info_p res_r src src_off n = do
(mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)
emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
- (wORD_SIZE dflags)
+ (wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
@@ -2365,7 +2367,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
(mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
- (wORD_SIZE dflags)
+ (wordAlignment dflags)
emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
@@ -2493,19 +2495,19 @@ doCasByteArray res mba idx idx_ty old new = do
-- Helpers for emitting function calls
-- | Emit a call to @memcpy at .
-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemcpyCall dst src n align = do
emitPrimCall
[ {-no results-} ]
- (MO_Memcpy align)
+ (MO_Memcpy (alignmentBytes align))
[ dst, src, n ]
-- | Emit a call to @memmove at .
-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemmoveCall dst src n align = do
emitPrimCall
[ {- no results -} ]
- (MO_Memmove align)
+ (MO_Memmove (alignmentBytes align))
[ dst, src, n ]
-- | Emit a call to @memset at . The second argument must fit inside an
=====================================
compiler/main/DynFlags.hs
=====================================
@@ -384,6 +384,7 @@ data DumpFlag
| Opt_D_dump_spec
| Opt_D_dump_prep
| Opt_D_dump_stg
+ | Opt_D_dump_stg_final
| Opt_D_dump_call_arity
| Opt_D_dump_exitify
| Opt_D_dump_stranal
@@ -3339,6 +3340,8 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_prep)
, make_ord_flag defGhcFlag "ddump-stg"
(setDumpFlag Opt_D_dump_stg)
+ , make_ord_flag defGhcFlag "ddump-stg-final"
+ (setDumpFlag Opt_D_dump_stg_final)
, make_ord_flag defGhcFlag "ddump-call-arity"
(setDumpFlag Opt_D_dump_call_arity)
, make_ord_flag defGhcFlag "ddump-exitify"
=====================================
compiler/main/HscMain.hs
=====================================
@@ -1470,6 +1470,8 @@ doCodeGen hsc_env this_mod data_tycons
let dflags = hsc_dflags hsc_env
let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
+ dumpIfSet_dyn dflags Opt_D_dump_stg_final
+ "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)
let cmm_stream :: Stream IO CmmGroup ()
cmm_stream = {-# SCC "StgCmm" #-}
StgCmm.codeGen dflags this_mod data_tycons
=====================================
compiler/nativeGen/X86/CodeGen.hs
=====================================
@@ -1767,12 +1767,11 @@ genCCall
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
--- Unroll memcpy calls if the source and destination pointers are at
--- least DWORD aligned and the number of bytes to copy isn't too
+-- Unroll memcpy calls if the number of bytes to copy isn't too
-- large. Otherwise, call C's memcpy.
-genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
+genCCall dflags _ (PrimTarget (MO_Memcpy align)) _
[dst, src, CmmLit (CmmInt n _)] _
- | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do
+ | fromInteger insns <= maxInlineMemcpyInsns dflags = do
code_dst <- getAnyReg dst
dst_r <- getNewRegNat format
code_src <- getAnyReg src
@@ -1785,7 +1784,9 @@ genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
-- instructions per move.
insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
- format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)
+ maxAlignment = wordAlignment dflags -- only machine word wide MOVs are supported
+ effectiveAlignment = min (alignmentOf align) maxAlignment
+ format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
-- The size of each move, in bytes.
sizeBytes :: Integer
=====================================
compiler/typecheck/TcCanonical.hs
=====================================
@@ -1015,7 +1015,7 @@ can_eq_nc_forall ev eq_rel s1 s2
-- Done: unify phi1 ~ phi2
go [] subst bndrs2
= ASSERT( null bndrs2 )
- unify loc (eqRelRole eq_rel) phi1' (substTy subst phi2)
+ unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) []
=====================================
compiler/typecheck/TcSigs.hs
=====================================
@@ -515,7 +515,7 @@ tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
, sig_inst_skols = tv_prs
, sig_inst_wcs = wcs
, sig_inst_wcx = wcx
- , sig_inst_theta = substTys subst theta
+ , sig_inst_theta = substTysUnchecked subst theta
, sig_inst_tau = substTyUnchecked subst tau }
; traceTc "End partial sig }" (ppr inst_sig)
; return inst_sig }
=====================================
compiler/types/OptCoercion.hs
=====================================
@@ -118,8 +118,8 @@ optCoercion' env co
(Pair in_ty1 in_ty2, in_role) = coercionKindRole co
(Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
in
- ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
- substTy env in_ty2 `eqType` out_ty2 &&
+ ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&
+ substTyUnchecked env in_ty2 `eqType` out_ty2 &&
in_role == out_role
, text "optCoercion changed types!"
$$ hang (text "in_co:") 2 (ppr co)
=====================================
compiler/types/Type.hs
=====================================
@@ -1044,7 +1044,7 @@ piResultTys ty orig_args@(arg:args)
init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))
go :: TCvSubst -> Type -> [Type] -> Type
- go subst ty [] = substTy subst ty
+ go subst ty [] = substTyUnchecked subst ty
go subst ty all_args@(arg:args)
| Just ty' <- coreView ty
=====================================
docs/users_guide/8.10.1-notes.rst
=====================================
@@ -61,10 +61,11 @@ Compiler
:ghc-flag:`-Wredundant-record-wildcards` which warn users when they have
redundant or unused uses of a record wildcard match.
-- Calls to `memset` are now unrolled more aggressively and the
- produced code is more efficient on `x86_64` with added support for
- 64-bit `MOV`s. In particular, `setByteArray#` calls that were not
- optimized before, now will be. See :ghc-ticket:`16052`.
+- Calls to `memset` and `memcpy` are now unrolled more aggressively
+ and the produced code is more efficient on `x86_64` with added
+ support for 64-bit `MOV`s. In particular, `setByteArray#` and
+ `copyByteArray#` calls that were not optimized before, now will
+ be. See :ghc-ticket:`16052`.
Runtime system
~~~~~~~~~~~~~~
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -380,6 +380,11 @@ These flags dump various phases of GHC's STG pipeline.
Show the output of the intermediate STG-to-STG pass. (*lots* of output!)
+.. ghc-flag:: -ddump-stg-final
+ :shortdesc: Show output of last STG pass.
+ :type: dynamic
+
+ Show the output of the last STG pass before we generate Cmm.
C-\\- representation
~~~~~~~~~~~~~~~~~~~~
=====================================
hadrian/doc/make.md
=====================================
@@ -123,6 +123,8 @@ time you fire up a build. This is not possible with the Make build system.
make test # (1)
make test TEST=plugins01 # (2)
make test TEST="plugins01 plugins02" # (3)
+ make accept # (4)
+ PLATFORM=YES OS=YES make accept # (5)
# Hadrian
@@ -134,6 +136,12 @@ time you fire up a build. This is not possible with the Make build system.
build test --only="plugins01 plugins02" # equivalent to (3)
TEST="plugins01 plugins02" build test # equivalent to (3)
TEST=plugins01 build test --only=plugins02 # equivalent to (3)
+
+ build test -a # equivalent to (4)
+ build test --test-accept # equivalent to (4)
+
+ PLATFORM=YES OS=YES build test -a # equivalent to (5)
+ PLATFORM=YES OS=YES build test --test-accept # equivalent to (5)
```
As illustrated in the examples above, you can use the `TEST` environment
=====================================
hadrian/doc/testsuite.md
=====================================
@@ -40,6 +40,31 @@ TEST="test1 test2" build test
TEST="test1 test2" build test --only="test3 test4"
```
+## Accepting new output
+
+You can use the `-a` or `--test-accept` flag to "accept" the new
+output of your tests. This has the effect of updating the expected
+output of all the tests that fail due to mismatching output, so as to
+consider the new output the correct one.
+
+When the `PLATFORM` environment variable is set to `YES`, passing this flag has
+the effect of accepting the new output for the current platform.
+
+When the `OS` environment variable is set to `YES`, passing this flag has the
+effect of accepting the new output for all word sizes on the current OS.
+
+``` sh
+# accept new output for all tests
+build test -a
+
+# just run and accept new output for 'test123' and 'test456'
+build test -a --only="test123 test456"
+
+# accept new output for current platform and all word sizes for
+# the current OS, for all tests
+PLATFORM=YES OS=YES build test -a
+```
+
## Performance tests
You can use the `--only-perf` and `--skip-perf` flags to
=====================================
hadrian/hadrian.cabal
=====================================
@@ -66,6 +66,7 @@ executable hadrian
, Rules.Nofib
, Rules.Program
, Rules.Register
+ , Rules.Rts
, Rules.Selftest
, Rules.SimpleTargets
, Rules.SourceDist
@@ -121,7 +122,7 @@ executable hadrian
build-depends: base >= 4.8 && < 5
, Cabal >= 3.0 && < 3.1
, containers >= 0.5 && < 0.7
- , directory >= 1.2 && < 1.4
+ , directory >= 1.3.1.0 && < 1.4
, extra >= 1.4.7
, filepath
, mtl == 2.2.*
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -56,7 +56,8 @@ data TestArgs = TestArgs
, testSpeed :: TestSpeed
, testSummary :: Maybe FilePath
, testVerbosity :: Maybe String
- , testWays :: [String] }
+ , testWays :: [String]
+ , testAccept :: Bool}
deriving (Eq, Show)
-- | Default value for `TestArgs`.
@@ -73,7 +74,8 @@ defaultTestArgs = TestArgs
, testSpeed = TestNormal
, testSummary = Nothing
, testVerbosity = Nothing
- , testWays = [] }
+ , testWays = []
+ , testAccept = False }
readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
readConfigure = Right $ \flags -> flags { configure = True }
@@ -124,6 +126,9 @@ readProgressInfo ms =
readTestKeepFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestKeepFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testKeepFiles = True } }
+readTestAccept :: Either String (CommandLineArgs -> CommandLineArgs)
+readTestAccept = Right $ \flags -> flags { testArgs = (testArgs flags) { testAccept = True } }
+
readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler
where
@@ -245,7 +250,8 @@ optDescrs =
, Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE")
"A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
, Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
- "only run these ways" ]
+ "only run these ways"
+ , Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests" ]
-- | A type-indexed map containing Hadrian command line arguments to be passed
-- to Shake via 'shakeExtra'.
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -16,8 +16,9 @@ module Hadrian.Utilities (
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
-- * File system operations
- copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
- createDirectory, copyDirectory, moveDirectory, removeDirectory,
+ copyFile, copyFileUntracked, createFileLinkUntracked, fixFile,
+ makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
+ moveDirectory, removeDirectory,
-- * Diagnostic info
UseColour (..), Colour (..), ANSIColour (..), putColoured,
@@ -288,6 +289,14 @@ infixl 1 <&>
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
+-- | Link a file tracking the source. Create the target directory if missing.
+createFileLinkUntracked :: FilePath -> FilePath -> Action ()
+createFileLinkUntracked linkTarget link = do
+ let dir = takeDirectory linkTarget
+ liftIO $ IO.createDirectoryIfMissing True dir
+ putProgressInfo =<< renderCreateFileLink linkTarget link
+ quietly . liftIO $ IO.createFileLink linkTarget link
+
-- | Copy a file tracking the source. Create the target directory if missing.
copyFile :: FilePath -> FilePath -> Action ()
copyFile source target = do
@@ -460,8 +469,12 @@ renderAction what input output = do
return $ case progressInfo of
None -> ""
Brief -> "| " ++ what ++ ": " ++ i ++ " => " ++ o
- Normal -> renderBox [ what, " input: " ++ i, " => output: " ++ o ]
- Unicorn -> renderUnicorn [ what, " input: " ++ i, " => output: " ++ o ]
+ Normal -> renderBox [ what
+ , " input: " ++ i
+ , " => output: " ++ o ]
+ Unicorn -> renderUnicorn [ what
+ , " input: " ++ i
+ , " => output: " ++ o ]
where
i = unifyPath input
o = unifyPath output
@@ -478,6 +491,24 @@ renderActionNoOutput what input = do
where
i = unifyPath input
+-- | Render creating a file link.
+renderCreateFileLink :: String -> FilePath -> Action String
+renderCreateFileLink linkTarget link' = do
+ progressInfo <- userSetting Brief
+ let what = "Creating file link"
+ linkString = link ++ " -> " ++ linkTarget
+ return $ case progressInfo of
+ None -> ""
+ Brief -> "| " ++ what ++ ": " ++ linkString
+ Normal -> renderBox [ what
+ , " link name: " ++ link
+ , " -> link target: " ++ linkTarget ]
+ Unicorn -> renderUnicorn [ what
+ , " link name: " ++ link
+ , " -> link target: " ++ linkTarget ]
+ where
+ link = unifyPath link'
+
-- | Render the successful build of a program.
renderProgram :: String -> String -> String -> String
renderProgram name bin synopsis = renderBox $
=====================================
hadrian/src/Rules.hs
=====================================
@@ -21,6 +21,7 @@ import qualified Rules.Libffi
import qualified Rules.Library
import qualified Rules.Program
import qualified Rules.Register
+import qualified Rules.Rts
import qualified Rules.SimpleTargets
import Settings
import Target
@@ -158,6 +159,7 @@ buildRules = do
Rules.Gmp.gmpRules
Rules.Libffi.libffiRules
Rules.Library.libraryRules
+ Rules.Rts.rtsRules
packageRules
oracleRules :: Rules ()
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -97,7 +97,7 @@ other, the install script:
bindistRules :: Rules ()
bindistRules = do
root <- buildRootRules
- phony "binary-dist" $ do
+ phony "binary-dist-dir" $ do
-- We 'need' all binaries and libraries
targets <- mapM pkgTarget =<< stagePackages Stage1
need targets
@@ -150,6 +150,16 @@ bindistRules = do
, "ghci-script", "haddock", "hpc", "hp2ps", "hsc2hs"
, "runghc"]
+
+ phony "binary-dist" $ do
+
+ need ["binary-dist-dir"]
+
+ version <- setting ProjectVersion
+ targetPlatform <- setting TargetPlatformFull
+
+ let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform
+
-- Finally, we create the archive <root>/bindist/ghc-X.Y.Z-platform.tar.xz
tarPath <- builderPath (Tar Create)
cmd [Cwd $ root -/- "bindist"] tarPath
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -8,6 +8,7 @@ import Hadrian.Haskell.Cabal
import Oracles.Setting
import Packages
import Rules.Gmp
+import Rules.Rts
import Settings
import Target
import Utilities
@@ -117,6 +118,9 @@ buildConf _ context at Context {..} conf = do
Cabal.copyPackage context
Cabal.registerPackage context
+ -- | Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
+ when (package == rts) (needRtsSymLinks stage ways)
+
-- The above two steps produce an entry in the package database, with copies
-- of many of the files we have build, e.g. Haskell interface files. We need
-- to record this side effect so that Shake can cache these files too.
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -0,0 +1,54 @@
+module Rules.Rts (rtsRules, needRtsSymLinks) where
+
+import Packages (rts)
+import Hadrian.Utilities
+import Settings.Builders.Common
+
+-- | Dynamic RTS library files need symlinks without the dummy version number.
+-- This is for backwards compatibility (the old make build system omitted the
+-- dummy version number).
+-- This rule has priority 2 to override the general rule for generating share
+-- library files (see Rules.Library.libraryRules).
+rtsRules :: Rules ()
+rtsRules = priority 2 $ do
+ root <- buildRootRules
+ [ root -/- "//libHSrts_*-ghc*.so",
+ root -/- "//libHSrts_*-ghc*.dylib",
+ root -/- "//libHSrts-ghc*.so",
+ root -/- "//libHSrts-ghc*.dylib"]
+ |%> \ rtsLibFilePath' -> createFileLinkUntracked
+ (addRtsDummyVersion $ takeFileName rtsLibFilePath')
+ rtsLibFilePath'
+
+-- Need symlinks generated by rtsRules.
+needRtsSymLinks :: Stage -> [Way] -> Action ()
+needRtsSymLinks stage rtsWays
+ = forM_ (filter (wayUnit Dynamic) rtsWays) $ \ way -> do
+ let ctx = Context stage rts way
+ libPath <- libPath ctx
+ distDir <- distDir stage
+ rtsLibFile <- takeFileName <$> pkgLibraryFile ctx
+ need [removeRtsDummyVersion (libPath </> distDir </> rtsLibFile)]
+
+prefix, versionlessPrefix :: String
+versionlessPrefix = "libHSrts"
+prefix = versionlessPrefix ++ "-1.0"
+
+-- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
+-- == "a/libHSrts-ghc1.2.3.4.so"
+removeRtsDummyVersion :: FilePath -> FilePath
+removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix
+
+-- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so"
+-- == "a/libHSrts-1.0-ghc1.2.3.4.so"
+addRtsDummyVersion :: FilePath -> FilePath
+addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix
+
+replaceLibFilePrefix :: String -> String -> FilePath -> FilePath
+replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let
+ oldFileName = takeFileName oldFilePath
+ newFileName = maybe
+ (error $ "Expected RTS library file to start with " ++ oldPrefix)
+ (newPrefix ++)
+ (stripPrefix oldPrefix oldFileName)
+ in replaceFileName oldFilePath newFileName
\ No newline at end of file
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -71,6 +71,11 @@ runTestBuilderArgs = builder RunTest ? do
debugged <- read <$> getTestSetting TestGhcDebugged
keepFiles <- expr (testKeepFiles <$> userSetting defaultTestArgs)
+ accept <- expr (testAccept <$> userSetting defaultTestArgs)
+ (acceptPlatform, acceptOS) <- expr . liftIO $
+ (,) <$> (maybe False (=="YES") <$> lookupEnv "PLATFORM")
+ <*> (maybe False (=="YES") <$> lookupEnv "OS")
+
windows <- expr windowsHost
darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions
@@ -95,6 +100,9 @@ runTestBuilderArgs = builder RunTest ? do
, arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.local=False"
, arg "-e", arg $ "config.cleanup=" ++ show (not keepFiles)
+ , arg "-e", arg $ "config.accept=" ++ show accept
+ , arg "-e", arg $ "config.accept_platform=" ++ show acceptPlatform
+ , arg "-e", arg $ "config.accept_os=" ++ show acceptOS
, arg "-e", arg $ "config.exeext=" ++ quote exe
, arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
=====================================
libraries/base/System/Timeout.hs
=====================================
@@ -16,7 +16,7 @@
--
-------------------------------------------------------------------------------
-module System.Timeout ( timeout ) where
+module System.Timeout ( Timeout, timeout ) where
#if !defined(mingw32_HOST_OS)
import Control.Monad
@@ -35,7 +35,11 @@ import Data.Unique (Unique, newUnique)
-- interrupt the running IO computation when the timeout has
-- expired.
-newtype Timeout = Timeout Unique deriving Eq -- ^ @since 4.0
+-- | An exception thrown to a thread by 'timeout' to interrupt a timed-out
+-- computation.
+--
+-- @since 4.0
+newtype Timeout = Timeout Unique deriving Eq
-- | @since 4.0
instance Show Timeout where
@@ -67,20 +71,25 @@ instance Exception Timeout where
-- another thread.
--
-- A tricky implementation detail is the question of how to abort an @IO@
--- computation. This combinator relies on asynchronous exceptions internally.
--- The technique works very well for computations executing inside of the
--- Haskell runtime system, but it doesn't work at all for non-Haskell code.
--- Foreign function calls, for example, cannot be timed out with this
--- combinator simply because an arbitrary C function cannot receive
--- asynchronous exceptions. When @timeout@ is used to wrap an FFI call that
--- blocks, no timeout event can be delivered until the FFI call returns, which
--- pretty much negates the purpose of the combinator. In practice, however,
--- this limitation is less severe than it may sound. Standard I\/O functions
--- like 'System.IO.hGetBuf', 'System.IO.hPutBuf', Network.Socket.accept, or
--- 'System.IO.hWaitForInput' appear to be blocking, but they really don't
--- because the runtime system uses scheduling mechanisms like @select(2)@ to
--- perform asynchronous I\/O, so it is possible to interrupt standard socket
--- I\/O or file I\/O using this combinator.
+-- computation. This combinator relies on asynchronous exceptions internally
+-- (namely throwing the computation the 'Timeout' exception). The technique
+-- works very well for computations executing inside of the Haskell runtime
+-- system, but it doesn't work at all for non-Haskell code. Foreign function
+-- calls, for example, cannot be timed out with this combinator simply because
+-- an arbitrary C function cannot receive asynchronous exceptions. When
+-- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be
+-- delivered until the FFI call returns, which pretty much negates the purpose
+-- of the combinator. In practice, however, this limitation is less severe than
+-- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',
+-- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'
+-- appear to be blocking, but they really don't because the runtime system uses
+-- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it
+-- is possible to interrupt standard socket I\/O or file I\/O using this
+-- combinator.
+---
+-- Note that 'timeout' cancels the computation by throwing it the 'Timeout'
+-- exception. Consequently blanket exception handlers (e.g. catching
+-- 'SomeException') within the computation will break the timeout behavior.
timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
| n < 0 = fmap Just f
=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -8,3 +8,4 @@ test('memcpy-unroll', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
test('memcpy-unroll-conprop', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
test('memset-unroll', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
test('bytearray-memset-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
+test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
=====================================
testsuite/tests/codeGen/should_gen_asm/bytearray-memcpy-unroll.asm
=====================================
@@ -0,0 +1,8 @@
+movw 0(%rax),%dx
+movw %dx,0(%rcx)
+movw 2(%rax),%dx
+movw %dx,2(%rcx)
+movw 4(%rax),%dx
+movw %dx,4(%rcx)
+movw 6(%rax),%ax
+movw %ax,6(%rcx)
=====================================
testsuite/tests/codeGen/should_gen_asm/bytearray-memcpy-unroll.hs
=====================================
@@ -0,0 +1,19 @@
+{-# language MagicHash #-}
+{-# language UnboxedTuples #-}
+
+module CopyArray
+ ( smallCopy
+ ) where
+
+import GHC.Exts
+import GHC.IO
+
+data ByteArray = ByteArray ByteArray#
+
+-- Does an 8 byte copy with sub-word (2 bytes) alignment
+-- Should be unrolled into 4 aligned stores (MOVWs)
+smallCopy :: ByteArray -> IO ByteArray
+smallCopy (ByteArray ba) = IO $ \s0 -> case newByteArray# 8# s0 of
+ (# s1, mut #) -> case copyByteArray# ba 2# mut 0# 8# s1 of
+ s2 -> case unsafeFreezeByteArray# mut s2 of
+ (# s3, frozen #) -> (# s3, ByteArray frozen #)
=====================================
testsuite/tests/dynlibs/Makefile
=====================================
@@ -9,6 +9,11 @@ T3807:
$(RM) T3807-export.o T3807-load.o
$(RM) T3807test.so
$(RM) T3807-load
+
+ # GHC does not automatically link with the RTS when building shared
+ # libraries. This is done to allow the RTS flavour to be chosen later (i.e.
+ # when linking an executable).
+ # Hence we must explicitly linking with the RTS here.
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -v0 --make -dynamic -fPIC -shared T3807Export.hs T3807-export.c -o T3807test.so -lHSrts-ghc`'$(TEST_HC)' $(TEST_HC_OPTS) --numeric-version`
'$(TEST_HC)' $(filter-out -rtsopts,$(TEST_HC_OPTS)) -no-auto-link-packages -no-hs-main T3807-load.c -o T3807-load -ldl
./T3807-load
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/3d19895f2e5739f7a96c69793b469bf521410f40...851ee22f379ca4840e75e771832cdacd89ce5693
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/3d19895f2e5739f7a96c69793b469bf521410f40...851ee22f379ca4840e75e771832cdacd89ce5693
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/20190413/a16e6c25/attachment-0001.html>
More information about the ghc-commits
mailing list