[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Fix a leak in `transpose`

Marge Bot gitlab at gitlab.haskell.org
Sun Nov 1 16:24:00 UTC 2020



 Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
ce1bb995 by Hécate at 2020-11-01T08:52:08-05:00
Fix a leak in `transpose`

This patch was authored by David Feuer <david.feuer at gmail.com>

- - - - -
e63db32c by Ben Gamari at 2020-11-01T08:52:44-05:00
Scav: Use bd->gen_no instead of bd->gen->no

This potentially saves a cache miss per scavenge.

- - - - -
cff96950 by Ben Gamari at 2020-11-01T11:23:51-05:00
gitlab-ci: Add usage message to ci.sh

- - - - -
ade2f9a7 by Ben Gamari at 2020-11-01T11:23:51-05:00
gitlab-ci: Introduce a nightly cross-compilation job

This adds a job to test cross-compilation from x86-64 to AArch64 with
Hadrian.

Fixes #18234.

- - - - -
58eae6f7 by GHC GitLab CI at 2020-11-01T11:23:51-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.

- - - - -
ba741557 by Ben Gamari at 2020-11-01T11:23:52-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.

- - - - -


13 changed files:

- .gitlab-ci.yml
- .gitlab/ci.sh
- hadrian/src/Builder.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/Data/OldList.hs
- + libraries/base/tests/T18642.hs
- + libraries/base/tests/T18642.stdout
- libraries/base/tests/all.T
- rts/sm/Scav.c
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/mk/test.mk


Changes:

=====================================
.gitlab-ci.yml
=====================================
@@ -257,6 +257,20 @@ validate-x86_64-linux-deb9-unreg-hadrian:
     CONFIGURE_ARGS: --enable-unregisterised
     TEST_ENV: "x86_64-linux-deb9-unreg-hadrian"
 
+nightly-x86_64-linux-deb10-hadrian-cross-aarch64:
+  <<: *nightly
+  extends: .validate-linux-hadrian
+  stage: full-build
+  variables:
+    CONFIGURE_ARGS: --with-intree-gmp
+    CROSS_TARGET: "aarch64-linux-gnu"
+
+
+
+############################################################
+# GHC-in-GHCi (Hadrian)
+############################################################
+
 hadrian-ghc-in-ghci:
   stage: quick-build
   needs: [lint-linters, lint-submods]


=====================================
.gitlab/ci.sh
=====================================
@@ -2,6 +2,8 @@
 # shellcheck disable=SC2230
 
 # This is the primary driver of the GitLab CI infrastructure.
+# Run `ci.sh usage` for usage information.
+
 
 set -e -o pipefail
 
@@ -17,6 +19,56 @@ fi
 
 source $TOP/.gitlab/common.sh
 
+function usage() {
+  cat <<EOF
+$0 - GHC continuous integration driver
+
+Modes:
+
+  usage         Show this usage message.
+  setup         Prepare environment for a build.
+  configure     Run ./configure.
+  build_make    Build GHC via the make build system
+  build_hadrian Build GHC via the Hadrian build system
+  test_make     Test GHC via the make build system
+  test_hadrian  Test GHC via the Hadrian build system
+  clean         Clean the tree
+  shell         Run an interactive shell with a configured build environment.
+
+Environment variables:
+
+  CROSS_TARGET      Triple of cross-compilation target.
+  MSYSTEM           (Windows-only) Which platform to build form (MINGW64 or MINGW32).
+
+Environment variables determining build configuration of Make system:
+
+  BUILD_FLAVOUR     Which flavour to build.
+  BUILD_SPHINX_HTML Whether to build Sphinx HTML documentation.
+  BUILD_SPHINX_PDF  Whether to build Sphinx PDF documentation.
+  INTEGER_LIBRARY   Which integer library to use (integer-simple or integer-gmp).
+  HADDOCK_HYPERLINKED_SOURCES
+                    Whether to build hyperlinked Haddock sources.
+  TEST_TYPE         Which test rule to run.
+
+Environment variables determining build configuration of Hadrian system:
+
+  BUILD_FLAVOUR     Which flavour to build.
+
+Environment variables determining bootstrap toolchain (Linux):
+
+  GHC           Path of GHC executable to use for bootstrapping.
+  CABAL         Path of cabal-install executable to use for bootstrapping.
+  ALEX          Path of alex executable to use for bootstrapping.
+  HAPPY         Path of alex executable to use for bootstrapping.
+
+Environment variables determining bootstrap toolchain (non-Linux):
+
+  GHC_VERSION   Which GHC version to fetch for bootstrapping.
+  CABAL_INSTALL_VERSION
+                Cabal-install version to fetch for bootstrapping.
+EOF
+}
+
 function setup_locale() {
   # Musl doesn't provide locale support at all...
   if ! which locale > /dev/null; then
@@ -53,11 +105,11 @@ function setup_locale() {
 function mingw_init() {
   case "$MSYSTEM" in
     MINGW32)
-      triple="i386-unknown-mingw32"
+      target_triple="i386-unknown-mingw32"
       boot_triple="i386-unknown-mingw32" # triple of bootstrap GHC
       ;;
     MINGW64)
-      triple="x86_64-unknown-mingw32"
+      target_triple="x86_64-unknown-mingw32"
       boot_triple="x86_64-unknown-mingw32" # triple of bootstrap GHC
       ;;
     *)
@@ -320,8 +372,8 @@ function configure() {
   end_section "booting"
 
   local target_args=""
-  if [[ -n "$triple" ]]; then
-    target_args="--target=$triple"
+  if [[ -n "$target_triple" ]]; then
+    target_args="--target=$target_triple"
   fi
 
   start_section "configuring"
@@ -367,6 +419,11 @@ function determine_metric_baseline() {
 }
 
 function test_make() {
+  if [ -n "$CROSS_TARGET" ]; then
+    info "Can't test cross-compiled build."
+    return
+  fi
+
   run "$MAKE" test_bindist TEST_PREP=YES
   run "$MAKE" V=0 test \
     THREADS="$cores" \
@@ -387,6 +444,11 @@ function build_hadrian() {
 }
 
 function test_hadrian() {
+  if [ -n "$CROSS_TARGET" ]; then
+    info "Can't test cross-compiled build."
+    return
+  fi
+
   cd _build/bindist/ghc-*/
   run ./configure --prefix="$TOP"/_build/install
   run "$MAKE" install
@@ -473,9 +535,15 @@ case "$(uname)" in
   *) fail "uname $(uname) is not supported" ;;
 esac
 
+if [ -n "$CROSS_TARGET" ]; then
+  info "Cross-compiling for $CROSS_TARGET..."
+  target_triple="$CROSS_TARGET"
+fi
+
 set_toolchain_paths
 
 case $1 in
+  usage) usage ;;
   setup) setup && cleanup_submodules ;;
   configure) configure ;;
   build_make) build_make ;;


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


=====================================
libraries/base/Data/OldList.hs
=====================================
@@ -547,19 +547,57 @@ intercalate xs xss = concat (intersperse xs xss)
 --
 -- >>> transpose [[10,11],[20],[],[30,31,32]]
 -- [[10,20,30],[11,31],[32]]
-transpose               :: [[a]] -> [[a]]
-transpose []             = []
-transpose ([]   : xss)   = transpose xss
-transpose ((x:xs) : xss) = (x : hds) : transpose (xs : tls)
+transpose :: [[a]] -> [[a]]
+transpose [] = []
+transpose ([] : xss) = transpose xss
+transpose ((x : xs) : xss) = combine x hds xs tls
   where
     -- We tie the calculations of heads and tails together
     -- to prevent heads from leaking into tails and vice versa.
     -- unzip makes the selector thunk arrangements we need to
     -- ensure everything gets cleaned up properly.
-    (hds, tls) = unzip [(hd, tl) | (hd:tl) <- xss]
+    (hds, tls) = unzip [(hd, tl) | hd : tl <- xss]
+    combine y h ys t = (y:h) : transpose (ys:t)
+    {-# NOINLINE combine #-}
+  {- Implementation note:
+  If the bottom part of the function was written as such:
+
+  ```
+  transpose ((x : xs) : xss) = (x:hds) : transpose (xs:tls)
+  where
+    (hds,tls) = hdstls
+    hdstls = unzip [(hd, tl) | hd : tl <- xss]
+    {-# NOINLINE hdstls #-}
+  ```
+  Here are the steps that would take place:
+
+  1. We allocate a thunk, `hdstls`, representing the result of unzipping.
+  2. We allocate selector thunks, `hds` and `tls`, that deconstruct `hdstls`.
+  3. Install `hds` as the tail of the result head and pass `xs:tls` to
+     the recursive call in the result tail.
+
+  Once optimised, this code would amount to:
+
+  ```
+  transpose ((x : xs) : xss) = (x:hds) : (let tls = snd hdstls in transpose (xs:tls))
+  where
+    hds = fst hdstls
+    hdstls = unzip [(hd, tl) | hd : tl <- xss]
+    {-# NOINLINE hdstls #-}
+  ```
+
+  In particular, GHC does not produce the `tls` selector thunk immediately;
+  rather, it waits to do so until the tail of the result is actually demanded.
+  So when `hds` is demanded, that does not resolve `snd hdstls`; the tail of the
+  result keeps `hdstls` alive.
+
+  By writing `combine` and making it NOINLINE, we prevent GHC from delaying
+  the selector thunk allocation, requiring that `hds` and `tls` are actually
+  allocated to be passed to `combine`.
+  -}
 
 
--- | The 'partition' function takes a predicate a list and returns
+-- | The 'partition' function takes a predicate and a list, and returns
 -- the pair of lists of elements which do and do not satisfy the
 -- predicate, respectively; i.e.,
 --


=====================================
libraries/base/tests/T18642.hs
=====================================
@@ -0,0 +1,27 @@
+{-# LANGUAGE NumericUnderscores #-}
+module Main where
+
+import Data.List (transpose, foldl')
+import GHC.Stats
+import System.Exit
+
+thingy :: [[[Int]]]
+thingy = [ [[1],[2]], [[1..10^7], [3]]]
+
+thingy2 :: [[[Int]]]
+thingy2 = [ [[1],[2]], [[3], [2..10^7+1]]]
+
+main = do
+  htr : ttr <- pure $ transpose thingy
+  print $ even $ foldl' (+) 0 . head . tail $ htr
+
+  htr2 : ttr2 <- pure $ transpose thingy2
+  print $ even $ foldl' (+) 0 . head . tail . head $ ttr2
+
+  maxLiveBytes <- max_live_bytes <$> getRTSStats
+  if (maxLiveBytes) < 200_000
+  then putStrLn "Test is running in the expected residency limit"
+  else do
+    putStrLn $ "Test is running with " <> show maxLiveBytes <> " bytes of residency!"
+    exitFailure
+


=====================================
libraries/base/tests/T18642.stdout
=====================================
@@ -0,0 +1,3 @@
+True
+True
+Test is running in the expected residency limit


=====================================
libraries/base/tests/all.T
=====================================
@@ -260,3 +260,4 @@ test('T16943b', normal, compile_and_run, [''])
 test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w'])
 test('T16643', normal, compile_and_run, [''])
 test('clamp', normal, compile_and_run, [''])
+test('T18642', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['-O2'])


=====================================
rts/sm/Scav.c
=====================================
@@ -435,7 +435,7 @@ scavenge_block (bdescr *bd)
   saved_eager_promotion = gct->eager_promotion;
   gct->failed_to_evac = false;
 
-  ws = &gct->gens[bd->gen->no];
+  ws = &gct->gens[bd->gen_no];
 
   p = bd->u.scan;
 


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2af9fb1b5b7054302c7883b9d98e03e006cf7089...ba7415574a201a4db0f839ef0906982b751c92e4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2af9fb1b5b7054302c7883b9d98e03e006cf7089...ba7415574a201a4db0f839ef0906982b751c92e4
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/20201101/4e318790/attachment-0001.html>


More information about the ghc-commits mailing list